diff options
Diffstat (limited to 'lib')
165 files changed, 7720 insertions, 2502 deletions
diff --git a/lib/common_test/doc/src/ct_master_chapter.xml b/lib/common_test/doc/src/ct_master_chapter.xml index 37a0805055..adfe79e41a 100644 --- a/lib/common_test/doc/src/ct_master_chapter.xml +++ b/lib/common_test/doc/src/ct_master_chapter.xml @@ -198,7 +198,7 @@ <section> <title>Automatic startup of test target nodes</title> <marker id="ct_slave"></marker> - <p>Is is possible to automatically start, and perform initial actions, on + <p>It is possible to automatically start, and perform initial actions, on test target nodes by using the test specification term <c>init</c>.</p> <p>Currently, two sub-terms are supported, <c>node_start</c> and <c>eval</c>.</p> <p>Example:</p> diff --git a/lib/common_test/src/Makefile b/lib/common_test/src/Makefile index 8d74546880..2723b066f0 100644 --- a/lib/common_test/src/Makefile +++ b/lib/common_test/src/Makefile @@ -1,7 +1,7 @@ # # %CopyrightBegin% # -# Copyright Ericsson AB 2003-2013. All Rights Reserved. +# Copyright Ericsson AB 2003-2014. 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 @@ -75,7 +75,8 @@ MODULES= \ ct_conn_log_h \ cth_conn_log \ ct_groups \ - ct_property_test + ct_property_test \ + ct_release_test TARGET_MODULES= $(MODULES:%=$(EBIN)/%) BEAM_FILES= $(MODULES:%=$(EBIN)/%.$(EMULATOR)) diff --git a/lib/common_test/src/ct_netconfc.erl b/lib/common_test/src/ct_netconfc.erl index a3861dc745..2f66c7613c 100644 --- a/lib/common_test/src/ct_netconfc.erl +++ b/lib/common_test/src/ct_netconfc.erl @@ -190,6 +190,7 @@ get_config/4, edit_config/3, edit_config/4, + edit_config/5, delete_config/2, delete_config/3, copy_config/3, @@ -678,15 +679,39 @@ get_config(Client, Source, Filter, Timeout) -> %%---------------------------------------------------------------------- %% @spec edit_config(Client, Target, Config) -> Result -%% @equiv edit_config(Client, Target, Config, infinity) +%% @equiv edit_config(Client, Target, Config, [], infinity) edit_config(Client, Target, Config) -> edit_config(Client, Target, Config, ?DEFAULT_TIMEOUT). %%---------------------------------------------------------------------- --spec edit_config(Client, Target, Config, Timeout) -> Result when +-spec edit_config(Client, Target, Config, OptParamsOrTimeout) -> Result when Client :: client(), Target :: netconf_db(), Config :: simple_xml(), + OptParamsOrTimeout :: [simple_xml()] | timeout(), + Result :: ok | {error,error_reason()}. +%% @doc +%% +%% If `OptParamsOrTimeout' is a timeout value, then this is +%% equivalent to {@link edit_config/5. edit_config(Client, Target, +%% Config, [], Timeout)}. +%% +%% If `OptParamsOrTimeout' is a list of simple XML, then this is +%% equivalent to {@link edit_config/5. edit_config(Client, Target, +%% Config, OptParams, infinity)}. +%% +%% @end +edit_config(Client, Target, Config, Timeout) when ?is_timeout(Timeout) -> + edit_config(Client, Target, Config, [], Timeout); +edit_config(Client, Target, Config, OptParams) when is_list(OptParams) -> + edit_config(Client, Target, Config, OptParams, ?DEFAULT_TIMEOUT). + +%%---------------------------------------------------------------------- +-spec edit_config(Client, Target, Config, OptParams, Timeout) -> Result when + Client :: client(), + Target :: netconf_db(), + Config :: simple_xml(), + OptParams :: [simple_xml()], Timeout :: timeout(), Result :: ok | {error,error_reason()}. %% @doc Edit configuration data. @@ -695,10 +720,20 @@ edit_config(Client, Target, Config) -> %% include `:candidate' or `:startup' in its list of %% capabilities. %% +%% `OptParams' can be used for specifying optional parameters +%% (`default-operation', `test-option' or `error-option') that will be +%% added to the `edit-config' request. The value must be a list +%% containing valid simple XML, for example +%% +%% ``` +%% [{'default-operation', ["none"]}, +%% {'error-option', ["rollback-on-error"]}] +%%''' +%% %% @end %%---------------------------------------------------------------------- -edit_config(Client, Target, Config, Timeout) -> - call(Client, {send_rpc_op, edit_config, [Target,Config], Timeout}). +edit_config(Client, Target, Config, OptParams, Timeout) -> + call(Client, {send_rpc_op, edit_config, [Target,Config,OptParams], Timeout}). %%---------------------------------------------------------------------- @@ -1086,6 +1121,7 @@ handle_msg({get_event_streams=Op,Streams,Timeout}, From, State) -> SimpleXml = encode_rpc_operation(get,[Filter]), do_send_rpc(Op, SimpleXml, Timeout, From, State). +%% @private handle_msg({ssh_cm, CM, {data, Ch, _Type, Data}}, State) -> ssh_connection:adjust_window(CM,Ch,size(Data)), handle_data(Data, State); @@ -1234,8 +1270,8 @@ encode_rpc_operation(get,[Filter]) -> {get,filter(Filter)}; encode_rpc_operation(get_config,[Source,Filter]) -> {'get-config',[{source,[Source]}] ++ filter(Filter)}; -encode_rpc_operation(edit_config,[Target,Config]) -> - {'edit-config',[{target,[Target]},{config,[Config]}]}; +encode_rpc_operation(edit_config,[Target,Config,OptParams]) -> + {'edit-config',[{target,[Target]}] ++ OptParams ++ [{config,[Config]}]}; encode_rpc_operation(delete_config,[Target]) -> {'delete-config',[{target,[Target]}]}; encode_rpc_operation(copy_config,[Target,Source]) -> @@ -1707,6 +1743,7 @@ log(#connection{host=Host,port=Port,name=Name},Action,Data) -> %% Log callback - called from the error handler process +%% @private format_data(How,Data) -> %% Assuming that the data is encoded as UTF-8. If it is not, then %% the printout might be wrong, but the format function will not diff --git a/lib/common_test/src/ct_release_test.erl b/lib/common_test/src/ct_release_test.erl new file mode 100644 index 0000000000..eb9e9c832f --- /dev/null +++ b/lib/common_test/src/ct_release_test.erl @@ -0,0 +1,847 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2014. All Rights Reserved. +%% +%% The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved online at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% %CopyrightEnd% +%% +%%----------------------------------------------------------------- +%% @doc EXPERIMENTAL support for testing of upgrade. +%% +%% This is a library module containing support for test of release +%% related activities in one or more applications. Currenty it +%% supports upgrade only. +%% +%% == Configuration == +%% +%% In order to find version numbers of applications to upgrade from, +%% `{@module}' needs to access and start old OTP +%% releases. A `common_test' configuration file can be used for +%% specifying the location of such releases, for example: +%% +%% ``` +%% %% old-rels.cfg +%% {otp_releases,[{r16b,"/path/to/R16B03-1/bin/erl"}, +%% {'17',"/path/to/17.3/bin/erl"}]}.''' +%% +%% The configuration file should preferably point out the latest patch +%% level on each major release. +%% +%% If no such configuration file is given, {@link init/1} will return +%% `{skip,Reason}' and any attempt at running {@link upgrade/4} +%% will fail. +%% +%% == Callback functions == +%% +%% The following functions should be exported from a {@module} +%% callback module. +%% +%% All callback functions are called on the node where the upgrade is +%% executed. +%% +%% <dl> +%% <dt>Module:upgrade_init(State) -> NewState</dt> +%% <dd>Types: +%% +%% <b><c>State = NewState = cb_state()</c></b> +%% +%% Initialyze system before upgrade test starts. +%% +%% This function is called before the upgrade is started. All +%% applications given in {@link upgrade/4} are already started by +%% the boot script, so this callback is intended for additional +%% initialization, if necessary. +%% +%% Example: +%% +%% ``` +%% upgrade_init(State) -> +%% open_connection(State).''' +%% </dd> +%% +%% <dt>Module:upgrade_upgraded(State) -> NewState</dt> +%% <dd>Types: +%% +%% <b><c>State = NewState = cb_state()</c></b> +%% +%% Check that upgrade was successful. +%% +%% This function is called after the release_handler has +%% successfully unpacked and installed the new release, and it has +%% been made permanent. It allows application specific checks to +%% ensure that the upgrade was successful. +%% +%% Example: +%% +%% ``` +%% upgrade_upgraded(State) -> +%% check_connection_still_open(State).''' +%% </dd> +%% +%% <dt>Module:upgrade_downgraded(State) -> NewState</dt> +%% <dd>Types: +%% +%% <b><c>State = NewState = cb_state()</c></b> +%% +%% Check that downgrade was successful. +%% +%% This function is called after the release_handler has +%% successfully re-installed the original release, and it has been +%% made permanent. It allows application specific checks to ensure +%% that the downgrade was successful. +%% +%% Example: +%% +%% ``` +%% upgrade_init(State) -> +%% check_connection_closed(State).''' +%% </dd> +%% </dl> +%% @end +%%----------------------------------------------------------------- +-module(ct_release_test). + +-export([init/1, upgrade/4, cleanup/1]). + +-include_lib("kernel/include/file.hrl"). + +%%----------------------------------------------------------------- +-define(testnode, otp_upgrade). +-define(exclude_apps, [hipe, typer, dialyzer]). % never include these apps + +%%----------------------------------------------------------------- +-type config() :: [{atom(),term()}]. +-type cb_state() :: term(). + +-callback upgrade_init(cb_state()) -> cb_state(). +-callback upgrade_upgraded(cb_state()) -> cb_state(). +-callback upgrade_downgraded(cb_state()) -> cb_state(). + +%%----------------------------------------------------------------- +-spec init(Config) -> Result when + Config :: config(), + Result :: config() | SkipOrFail, + SkipOrFail :: {skip,Reason} | {fail,Reason}. +%% @doc Initialize `{@module}'. +%% +%% This function can be called from any of the +%% `init_per_*' functions in the test suite. It updates +%% the given `Config' with data that will be +%% used by future calls to other functions in this module. The +%% returned configuration must therefore also be returned from +%% the calling `init_per_*'. +%% +%% If the initialization fails, e.g. if a required release can +%% not be found, the function returns `{skip,Reason}'. In +%% this case the other test support functions in this mudule +%% can not be used. +%% +%% Example: +%% +%% ``` +%% init_per_suite(Config) -> +%% ct_release_test:init(Config).''' +%% +init(Config) -> + try init_upgrade_test() of + {Major,Minor} -> + [{release_test,[{major,Major},{minor,Minor}]} | Config] + catch throw:Thrown -> + Thrown + end. + +%%----------------------------------------------------------------- +-spec upgrade(App,Level,Callback,Config) -> any() when + App :: atom(), + Level :: minor | major, + Callback :: {module(),InitState}, + InitState :: cb_state(), + Config :: config(); + (Apps,Level,Callback,Config) -> any() when + Apps :: [App], + App :: atom(), + Level :: minor | major, + Callback :: {module(),InitState}, + InitState :: cb_state(), + Config :: config(). +%% @doc Test upgrade of the given application(s). +%% +%% This function can be called from a test case. It requires that +%% `Config' has been initialized by calling {@link +%% init/1} prior to this, for example from `init_per_suite/1'. +%% +%% Upgrade tests are performed as follows: +%% +%% <ol> +%% <li>Figure out which OTP release to test upgrade +%% from. Start a node running that release and find the +%% application versions on that node. Terminate the +%% node.</li> +%% <li>Figure out all dependencies for the applications under +%% test.</li> +%% <li>Create a release containing the core +%% applications `kernel', `stdlib' and `sasl' +%% in addition to the application(s) under test and all +%% dependencies of these. The versions of the applications +%% under test will be the ones found on the OTP release to +%% upgrade from. The versions of all other applications will +%% be those found on the current node, i.e. the common_test +%% node. This is the "From"-release.</li> +%% <li>Create another release containing the same +%% applications as in the previous step, but with all +%% application versions taken from the current node. This is +%% the "To"-release.</li> +%% <li>Install the "From"-release and start a new node +%% running this release.</li> +%% <li>Perform the upgrade test and allow customized +%% control by using callbacks: +%% <ol> +%% <li>Callback: `upgrade_init/1'</li> +%% <li>Unpack the new release</li> +%% <li>Install the new release</li> +%% <li>Callback: `upgrade_upgraded/1'</li> +%% <li>Install the original release</li> +%% <li>Callback: `upgrade_downgraded/1'</li> +%% </ol> +%% </li> +%% </ol> +%% +%% `App' or `Apps' +%% specifies the applications under test, i.e. the applications +%% which shall be upgraded. All other applications that are +%% included have the same releases in the "From"- and +%% "To"-releases and will therefore not be upgraded. +%% +%% `Level' specifies which OTP release to +%% pick the "From" versions from. +%% <dl> +%% <dt>major</dt> +%% <dd>From verions are picked from the previous major +%% release. For example, if the test is run on an OTP-17 +%% node, `{@module}' will pick the application +%% "From" versions from an OTP installation running OTP +%% R16B.</dd> +%% +%% <dt>minor</dt> +%% <dd>From verions are picked from the current major +%% release. For example, if the test is run on an OTP-17 +%% node, `{@module}' will pick the application +%% "From" versions from an OTP installation running an +%% earlier patch level of OTP-17.</dd> +%% </dl> +%% +%% The application "To" versions are allways picked from the +%% current node, i.e. the common_test node. +%% +%% `Callback' specifies the module (normally the +%% test suite) which implements the {@section Callback functions}, and +%% the initial value of the `State' variable used in these +%% functions. +%% +%% `Config' is the input argument received +%% in the test case function. +%% +%% Example: +%% +%% ``` +%% minor_upgrade(Config) -> +%% ct_release_test:upgrade(ssl,minor,{?MODULE,[]},Config). +%% ''' +%% +upgrade(App,Level,Callback,Config) when is_atom(App) -> + upgrade([App],Level,Callback,Config); +upgrade(Apps,Level,Callback,Config) -> + Dir = proplists:get_value(priv_dir,Config), + CreateDir = filename:join([Dir,Level,create]), + InstallDir = filename:join([Dir,Level,install]), + ok = filelib:ensure_dir(filename:join(CreateDir,"*")), + ok = filelib:ensure_dir(filename:join(InstallDir,"*")), + try upgrade(Apps,Level,Callback,CreateDir,InstallDir,Config) of + ok -> + %%rm_rf(CreateDir), + Tars = filelib:wildcard(filename:join(CreateDir,"*.tar.gz")), + _ = [file:delete(Tar) || Tar <- Tars], + rm_rf(InstallDir), + ok + catch throw:{fail,Reason} -> + ct:fail(Reason); + throw:{skip,Reason} -> + rm_rf(CreateDir), + rm_rf(InstallDir), + {skip,Reason} + after + %% Brutally kill all nodes that erroneously survived the test. + %% Note, we will not reach this if the test fails with a + %% timetrap timeout in the test suite! Thus we can have + %% hanging nodes... + Nodes = nodes(), + [rpc:call(Node,erlang,halt,[]) || Node <- Nodes] + end. + +%%----------------------------------------------------------------- +-spec cleanup(Config) -> Result when + Config :: config(), + Result :: config(). +%% @doc Clean up after tests. +%% +%% This function shall be called from the `end_per_*' function +%% complementing the `init_per_*' function where {@link init/1} +%% is called. +%% +%% It cleans up after the test, for example kills hanging +%% nodes. +%% +%% Example: +%% +%% ``` +%% end_per_suite(Config) -> +%% ct_release_test:cleanup(Config).''' +%% +cleanup(Config) -> + Nodes = [node_name(?testnode)|nodes()], + [rpc:call(Node,erlang,halt,[]) || Node <- Nodes], + Config. + +%%----------------------------------------------------------------- +init_upgrade_test() -> + %% Check that a real release is running, not e.g. cerl + ok = application:ensure_started(sasl), + case release_handler:which_releases() of + [{_,_,[],_}] -> + %% Fake release, no applications + throw({skip, "Need a real release running to create other releases"}); + _ -> + Major = init_upgrade_test(major), + Minor = init_upgrade_test(minor), + {Major,Minor} + end. + +init_upgrade_test(Level) -> + {FromVsn,ToVsn} = get_rels(Level), + OldRel = + case test_server:is_release_available(FromVsn) of + true -> + {release,FromVsn}; + false -> + case ct:get_config({otp_releases,list_to_atom(FromVsn)}) of + undefined -> + false; + Prog0 -> + case os:find_executable(Prog0) of + false -> + false; + Prog -> + {prog,Prog} + end + end + end, + case OldRel of + false -> + ct:log("Release ~p is not available." + " Upgrade on '~p' level can not be tested.", + [FromVsn,Level]), + undefined; + _ -> + init_upgrade_test(FromVsn,ToVsn,OldRel) + end. + +get_rels(major) -> + %% Given that the current major release is X, then this is an + %% upgrade from major release X-1 to the current release. + Current = erlang:system_info(otp_release), + PreviousMajor = previous_major(Current), + {PreviousMajor,Current}; +get_rels(minor) -> + %% Given that this is a (possibly) patched version of major + %% release X, then this is an upgrade from major release X to the + %% current release. + CurrentMajor = erlang:system_info(otp_release), + Current = CurrentMajor++"_patched", + {CurrentMajor,Current}. + +init_upgrade_test(FromVsn,ToVsn,OldRel) -> + OtpRel = list_to_atom("otp-"++FromVsn), + ct:log("Starting node to fetch application versions to upgrade from"), + {ok,Node} = test_server:start_node(OtpRel,peer,[{erl,[OldRel]}]), + {Apps,Path} = fetch_all_apps(Node), + test_server:stop_node(Node), + {FromVsn,ToVsn,Apps,Path}. + +fetch_all_apps(Node) -> + Paths = rpc:call(Node,code,get_path,[]), + %% Find all possible applications in the path + AppFiles = + lists:flatmap( + fun(P) -> + filelib:wildcard(filename:join(P,"*.app")) + end, + Paths), + %% Figure out which version of each application is running on this + %% node. Using application:load and application:get_key instead of + %% reading the .app files since there might be multiple versions + %% of a .app file and we only want the one that is actually + %% running. + AppVsns = + lists:flatmap( + fun(F) -> + A = list_to_atom(filename:basename(filename:rootname(F))), + _ = rpc:call(Node,application,load,[A]), + case rpc:call(Node,application,get_key,[A,vsn]) of + {ok,V} -> [{A,V}]; + _ -> [] + end + end, + AppFiles), + ErtsVsn = rpc:call(Node, erlang, system_info, [version]), + {[{erts,ErtsVsn}|AppVsns], Paths}. + + +%%----------------------------------------------------------------- +upgrade(Apps,Level,Callback,CreateDir,InstallDir,Config) -> + ct:log("Test upgrade of the following applications: ~p",[Apps]), + ct:log(".rel files and start scripts are created in:~n~ts",[CreateDir]), + ct:log("The release is installed in:~n~ts",[InstallDir]), + case proplists:get_value(release_test,Config) of + undefined -> + throw({fail,"ct_release_test:init/1 not run"}); + RTConfig -> + case proplists:get_value(Level,RTConfig) of + undefined -> + throw({skip,"Old release not available"}); + Data -> + {FromVsn,FromRel,FromAppsVsns} = + target_system(Apps, CreateDir, InstallDir, Data), + {ToVsn,ToRel,ToAppsVsns} = + upgrade_system(Apps, FromRel, CreateDir, + InstallDir, Data), + ct:log("Upgrade from: OTP-~ts, ~p",[FromVsn, FromAppsVsns]), + ct:log("Upgrade to: OTP-~ts, ~p",[ToVsn, ToAppsVsns]), + do_upgrade(Callback, FromVsn, FromAppsVsns, ToRel, + ToAppsVsns, InstallDir) + end + end. + +%%% This is similar to sasl/examples/src/target_system.erl, but with +%%% the following adjustments: +%%% - add a log directory +%%% - use an own 'start' script +%%% - chmod 'start' and 'start_erl' +target_system(Apps,CreateDir,InstallDir,{FromVsn,_,AllAppsVsns,Path}) -> + RelName0 = "otp-"++FromVsn, + + AppsVsns = [{A,V} || {A,V} <- AllAppsVsns, lists:member(A,Apps)], + {RelName,ErtsVsn} = create_relfile(AppsVsns,CreateDir,RelName0,FromVsn), + + %% Create .script and .boot + ok = systools(make_script,[RelName,[{path,Path}]]), + + %% Create base tar file - i.e. erts and all apps + ok = systools(make_tar,[RelName,[{erts,code:root_dir()}, + {path,Path}]]), + + %% Unpack the tar to complete the installation + erl_tar:extract(RelName ++ ".tar.gz", [{cwd, InstallDir}, compressed]), + + %% Add bin and log dirs + BinDir = filename:join([InstallDir, "bin"]), + file:make_dir(BinDir), + file:make_dir(filename:join(InstallDir,"log")), + + %% Delete start scripts - they will be added later + ErtsBinDir = filename:join([InstallDir, "erts-" ++ ErtsVsn, "bin"]), + file:delete(filename:join([ErtsBinDir, "erl"])), + file:delete(filename:join([ErtsBinDir, "start"])), + file:delete(filename:join([ErtsBinDir, "start_erl"])), + + %% Copy .boot to bin/start.boot + copy_file(RelName++".boot",filename:join([BinDir, "start.boot"])), + + %% Copy scripts from erts-xxx/bin to bin + copy_file(filename:join([ErtsBinDir, "epmd"]), + filename:join([BinDir, "epmd"]), [preserve]), + copy_file(filename:join([ErtsBinDir, "run_erl"]), + filename:join([BinDir, "run_erl"]), [preserve]), + copy_file(filename:join([ErtsBinDir, "to_erl"]), + filename:join([BinDir, "to_erl"]), [preserve]), + + %% create start_erl.data, sys.config and start.src + StartErlData = filename:join([InstallDir, "releases", "start_erl.data"]), + write_file(StartErlData, io_lib:fwrite("~s ~s~n", [ErtsVsn, FromVsn])), + SysConfig = filename:join([InstallDir, "releases", FromVsn, "sys.config"]), + write_file(SysConfig, "[]."), + StartSrc = filename:join(ErtsBinDir,"start.src"), + write_file(StartSrc,start_script()), + ok = file:change_mode(StartSrc,8#0755), + + %% Make start_erl executable + %% (this has been fixed in OTP 17 - it is now installed with + %% $INSTALL_SCRIPT instead of $INSTALL_DATA and should therefore + %% be executable from the start) + ok = file:change_mode(filename:join(ErtsBinDir,"start_erl.src"),8#0755), + + %% Substitute variables in erl.src, start.src and start_erl.src + %% (.src found in erts-xxx/bin - result stored in bin) + subst_src_scripts(["erl", "start", "start_erl"], ErtsBinDir, BinDir, + [{"FINAL_ROOTDIR", InstallDir}, {"EMU", "beam"}], + [preserve]), + + %% Create RELEASES + RelFile = filename:join([InstallDir, "releases", + filename:basename(RelName) ++ ".rel"]), + release_handler:create_RELEASES(InstallDir, RelFile), + + {FromVsn, RelName,AppsVsns}. + +systools(Func,Args) -> + case apply(systools,Func,Args) of + ok -> + ok; + error -> + throw({fail,{systools,Func,Args}}) + end. + +%%% This is a copy of $ROOT/erts-xxx/bin/start.src, modified to add +%%% sname and heart +start_script() -> + ["#!/bin/sh\n" + "ROOTDIR=%FINAL_ROOTDIR%\n" + "\n" + "if [ -z \"$RELDIR\" ]\n" + "then\n" + " RELDIR=$ROOTDIR/releases\n" + "fi\n" + "\n" + "START_ERL_DATA=${1:-$RELDIR/start_erl.data}\n" + "\n" + "$ROOTDIR/bin/run_erl -daemon /tmp/ $ROOTDIR/log \"exec $ROOTDIR/bin/start_erl $ROOTDIR $RELDIR $START_ERL_DATA -sname ",atom_to_list(?testnode)," -heart\"\n"]. + +%%% Create a release containing the current (the test node) OTP +%%% release, including relup to allow upgrade from an earlier OTP +%%% release. +upgrade_system(Apps, FromRel, CreateDir, InstallDir, {_,ToVsn,_,_}) -> + ct:log("Generating release to upgrade to."), + + RelName0 = "otp-"++ToVsn, + + AppsVsns = get_vsns(Apps), + {RelName,_} = create_relfile(AppsVsns,CreateDir,RelName0,ToVsn), + FromPath = filename:join([InstallDir,lib,"*",ebin]), + + ok = systools(make_script,[RelName]), + ok = systools(make_relup,[RelName,[FromRel],[FromRel], + [{path,[FromPath]}, + {outdir,CreateDir}]]), + SysConfig = filename:join([CreateDir, "sys.config"]), + write_file(SysConfig, "[]."), + + ok = systools(make_tar,[RelName,[{erts,code:root_dir()}]]), + + {ToVsn, RelName,AppsVsns}. + +%%% Start a new node running the release from target_system/6 +%%% above. Then upgrade to the system from upgrade_system/6. +do_upgrade({Cb,InitState},FromVsn,FromAppsVsns,ToRel,ToAppsVsns,InstallDir) -> + ct:log("Upgrade test attempting to start node.~n" + "If test fails, logs can be found in:~n~ts", + [filename:join(InstallDir,log)]), + Start = filename:join([InstallDir,bin,start]), + {ok,Node} = start_node(Start,FromVsn,FromAppsVsns), + + ct:log("Node started: ~p",[Node]), + State1 = do_callback(Node,Cb,upgrade_init,InitState), + + [{"OTP upgrade test",FromVsn,_,permanent}] = + rpc:call(Node,release_handler,which_releases,[]), + ToRelName = filename:basename(ToRel), + copy_file(ToRel++".tar.gz", + filename:join([InstallDir,releases,ToRelName++".tar.gz"])), + ct:log("Unpacking new release"), + {ok,ToVsn} = rpc:call(Node,release_handler,unpack_release,[ToRelName]), + [{"OTP upgrade test",ToVsn,_,unpacked}, + {"OTP upgrade test",FromVsn,_,permanent}] = + rpc:call(Node,release_handler,which_releases,[]), + ct:log("Installing new release"), + case rpc:call(Node,release_handler,install_release,[ToVsn]) of + {ok,FromVsn,_} -> + ok; + {continue_after_restart,FromVsn,_} -> + ct:log("Waiting for node restart") + end, + %% even if install_release returned {ok,...} there might be an + %% emulator restart (instruction restart_emulator), so we must + %% always make sure the node is running. + wait_node_up(current,ToVsn,ToAppsVsns), + + [{"OTP upgrade test",ToVsn,_,current}, + {"OTP upgrade test",FromVsn,_,permanent}] = + rpc:call(Node,release_handler,which_releases,[]), + ct:log("Permanenting new release"), + ok = rpc:call(Node,release_handler,make_permanent,[ToVsn]), + [{"OTP upgrade test",ToVsn,_,permanent}, + {"OTP upgrade test",FromVsn,_,old}] = + rpc:call(Node,release_handler,which_releases,[]), + + State2 = do_callback(Node,Cb,upgrade_upgraded,State1), + + ct:log("Re-installing old release"), + case rpc:call(Node,release_handler,install_release,[FromVsn]) of + {ok,FromVsn,_} -> + ok; + {continue_after_restart,FromVsn,_} -> + ct:log("Waiting for node restart") + end, + %% even if install_release returned {ok,...} there might be an + %% emulator restart (instruction restart_emulator), so we must + %% always make sure the node is running. + wait_node_up(current,FromVsn,FromAppsVsns), + + [{"OTP upgrade test",ToVsn,_,permanent}, + {"OTP upgrade test",FromVsn,_,current}] = + rpc:call(Node,release_handler,which_releases,[]), + ct:log("Permanenting old release"), + ok = rpc:call(Node,release_handler,make_permanent,[FromVsn]), + [{"OTP upgrade test",ToVsn,_,old}, + {"OTP upgrade test",FromVsn,_,permanent}] = + rpc:call(Node,release_handler,which_releases,[]), + + _State3 = do_callback(Node,Cb,upgrade_downgraded,State2), + + ct:log("Terminating node ~p",[Node]), + erlang:monitor_node(Node,true), + _ = rpc:call(Node,init,stop,[]), + receive {nodedown,Node} -> ok end, + ct:log("Node terminated"), + + ok. + +do_callback(Node,Mod,Func,State) -> + Dir = filename:dirname(code:which(Mod)), + _ = rpc:call(Node,code,add_path,[Dir]), + ct:log("Calling ~p:~p/1",[Mod,Func]), + R = rpc:call(Node,Mod,Func,[State]), + ct:log("~p:~p/1 returned: ~p",[Mod,Func,R]), + case R of + {badrpc,Error} -> + test_server:fail({test_upgrade_callback,Mod,Func,State,Error}); + NewState -> + NewState + end. + +%%% Library functions +previous_major("17") -> + "r16b"; +previous_major(Rel) -> + integer_to_list(list_to_integer(Rel)-1). + +create_relfile(AppsVsns,CreateDir,RelName0,RelVsn) -> + UpgradeAppsVsns = [{A,V,restart_type(A)} || {A,V} <- AppsVsns], + + CoreAppVsns0 = get_vsns([kernel,stdlib,sasl]), + CoreAppVsns = + [{A,V,restart_type(A)} || {A,V} <- CoreAppVsns0, + false == lists:keymember(A,1,AppsVsns)], + + Apps = [App || {App,_} <- AppsVsns], + StartDepsVsns = get_start_deps(Apps,CoreAppVsns), + StartApps = [StartApp || {StartApp,_,_} <- StartDepsVsns] ++ Apps, + + {RuntimeDepsVsns,_} = get_runtime_deps(StartApps,StartApps,[],[]), + + AllAppsVsns0 = StartDepsVsns ++ UpgradeAppsVsns ++ RuntimeDepsVsns, + + %% Should test tools really be included? Some library functions + %% here could be used by callback, but not everything since + %% processes of these applications will not be running. + TestToolAppsVsns0 = get_vsns([test_server,common_test]), + TestToolAppsVsns = + [{A,V,none} || {A,V} <- TestToolAppsVsns0, + false == lists:keymember(A,1,AllAppsVsns0)], + + AllAppsVsns1 = AllAppsVsns0 ++ TestToolAppsVsns, + AllAppsVsns = [AV || AV={A,_,_} <- AllAppsVsns1, + false == lists:member(A,?exclude_apps)], + + ErtsVsn = erlang:system_info(version), + + %% Create the .rel file + RelContent = {release,{"OTP upgrade test",RelVsn},{erts,ErtsVsn},AllAppsVsns}, + RelName = filename:join(CreateDir,RelName0), + RelFile = RelName++".rel", + {ok,Fd} = file:open(RelFile,[write,{encoding,utf8}]), + io:format(Fd,"~tp.~n",[RelContent]), + ok = file:close(Fd), + {RelName,ErtsVsn}. + +get_vsns(Apps) -> + [begin + _ = application:load(A), + {ok,V} = application:get_key(A,vsn), + {A,V} + end || A <- Apps]. + +get_start_deps([App|Apps],Acc) -> + _ = application:load(App), + {ok,StartDeps} = application:get_key(App,applications), + StartDepsVsns = + [begin + _ = application:load(StartApp), + {ok,StartVsn} = application:get_key(StartApp,vsn), + {StartApp,StartVsn,restart_type(StartApp)} + end || StartApp <- StartDeps, + false == lists:keymember(StartApp,1,Acc)], + DepsStartDeps = get_start_deps(StartDeps,Acc ++ StartDepsVsns), + get_start_deps(Apps,DepsStartDeps); +get_start_deps([],Acc) -> + Acc. + +get_runtime_deps([App|Apps],StartApps,Acc,Visited) -> + case lists:member(App,Visited) of + true -> + get_runtime_deps(Apps,StartApps,Acc,Visited); + false -> + %% runtime_dependencies should be possible to read with + %% application:get_key/2, but still isn't so we need to + %% read the .app file... + AppFile = code:where_is_file(atom_to_list(App) ++ ".app"), + {ok,[{application,App,Attrs}]} = file:consult(AppFile), + RuntimeDeps = + lists:flatmap( + fun(Str) -> + [RuntimeAppStr,_] = string:tokens(Str,"-"), + RuntimeApp = list_to_atom(RuntimeAppStr), + case {lists:keymember(RuntimeApp,1,Acc), + lists:member(RuntimeApp,StartApps)} of + {false,false} when RuntimeApp=/=erts -> + [RuntimeApp]; + _ -> + [] + end + end, + proplists:get_value(runtime_dependencies,Attrs,[])), + RuntimeDepsVsns = + [begin + _ = application:load(RuntimeApp), + {ok,RuntimeVsn} = application:get_key(RuntimeApp,vsn), + {RuntimeApp,RuntimeVsn,none} + end || RuntimeApp <- RuntimeDeps], + {DepsRuntimeDeps,NewVisited} = + get_runtime_deps(RuntimeDeps,StartApps,Acc++RuntimeDepsVsns,[App|Visited]), + get_runtime_deps(Apps,StartApps,DepsRuntimeDeps,NewVisited) + end; +get_runtime_deps([],_,Acc,Visited) -> + {Acc,Visited}. + +restart_type(App) when App==kernel; App==stdlib; App==sasl -> + permanent; +restart_type(_) -> + temporary. + +copy_file(Src, Dest) -> + copy_file(Src, Dest, []). + +copy_file(Src, Dest, Opts) -> + {ok,_} = file:copy(Src, Dest), + case lists:member(preserve, Opts) of + true -> + {ok, FileInfo} = file:read_file_info(Src), + file:write_file_info(Dest, FileInfo); + false -> + ok + end. + +write_file(FName, Conts) -> + Enc = file:native_name_encoding(), + {ok, Fd} = file:open(FName, [write]), + file:write(Fd, unicode:characters_to_binary(Conts,Enc,Enc)), + file:close(Fd). + +%% Substitute all occurrences of %Var% for Val in the given scripts +subst_src_scripts(Scripts, SrcDir, DestDir, Vars, Opts) -> + lists:foreach(fun(Script) -> + subst_src_script(Script, SrcDir, DestDir, + Vars, Opts) + end, Scripts). + +subst_src_script(Script, SrcDir, DestDir, Vars, Opts) -> + subst_file(filename:join([SrcDir, Script ++ ".src"]), + filename:join([DestDir, Script]), + Vars, Opts). + +subst_file(Src, Dest, Vars, Opts) -> + {ok, Bin} = file:read_file(Src), + Conts = binary_to_list(Bin), + NConts = subst(Conts, Vars), + write_file(Dest, NConts), + case lists:member(preserve, Opts) of + true -> + {ok, FileInfo} = file:read_file_info(Src), + file:write_file_info(Dest, FileInfo); + false -> + ok + end. + +subst(Str, [{Var,Val}|Vars]) -> + subst(re:replace(Str,"%"++Var++"%",Val,[{return,list}]),Vars); +subst(Str, []) -> + Str. + +%%% Start a node by executing the given start command. This node will +%%% be used for upgrade. +start_node(Start,ExpVsn,ExpAppsVsns) -> + Port = open_port({spawn_executable, Start}, []), + unlink(Port), + erlang:port_close(Port), + wait_node_up(permanent,ExpVsn,ExpAppsVsns). + +wait_node_up(ExpStatus,ExpVsn,ExpAppsVsns) -> + Node = node_name(?testnode), + wait_node_up(Node,ExpStatus,ExpVsn,lists:keysort(1,ExpAppsVsns),60). + +wait_node_up(Node,ExpStatus,ExpVsn,ExpAppsVsns,0) -> + test_server:fail({node_not_started,app_check_failed,ExpVsn,ExpAppsVsns, + rpc:call(Node,release_handler,which_releases,[ExpStatus]), + rpc:call(Node,application,which_applications,[])}); +wait_node_up(Node,ExpStatus,ExpVsn,ExpAppsVsns,N) -> + case {rpc:call(Node,release_handler,which_releases,[ExpStatus]), + rpc:call(Node, application, which_applications, [])} of + {[{_,ExpVsn,_,_}],Apps} when is_list(Apps) -> + case [{A,V} || {A,_,V} <- lists:keysort(1,Apps), + lists:keymember(A,1,ExpAppsVsns)] of + ExpAppsVsns -> + {ok,Node}; + _ -> + timer:sleep(2000), + wait_node_up(Node,ExpStatus,ExpVsn,ExpAppsVsns,N-1) + end; + _ -> + timer:sleep(2000), + wait_node_up(Node,ExpStatus,ExpVsn,ExpAppsVsns,N-1) + end. + +node_name(Sname) -> + {ok,Host} = inet:gethostname(), + list_to_atom(atom_to_list(Sname) ++ "@" ++ Host). + +rm_rf(Dir) -> + case file:read_file_info(Dir) of + {ok, #file_info{type = directory}} -> + {ok, Content} = file:list_dir_all(Dir), + [rm_rf(filename:join(Dir,C)) || C <- Content], + ok=file:del_dir(Dir), + ok; + {ok, #file_info{}} -> + ok=file:delete(Dir); + _ -> + ok + end. diff --git a/lib/common_test/test/ct_netconfc_SUITE.erl b/lib/common_test/test/ct_netconfc_SUITE.erl index c89a4cdabe..2959f77087 100644 --- a/lib/common_test/test/ct_netconfc_SUITE.erl +++ b/lib/common_test/test/ct_netconfc_SUITE.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2009-2012. All Rights Reserved. +%% Copyright Ericsson AB 2009-2014. 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 @@ -63,7 +63,8 @@ suite() -> [{ct_hooks,[ts_install_cth]}]. all() -> [ - default + netconfc1_SUITE, + netconfc_remote_SUITE ]. %%-------------------------------------------------------------------- @@ -72,14 +73,21 @@ all() -> %%%----------------------------------------------------------------- %%% -default(Config) when is_list(Config) -> +netconfc1_SUITE(Config) when is_list(Config) -> DataDir = ?config(data_dir, Config), Suite = filename:join(DataDir, "netconfc1_SUITE"), CfgFile = filename:join(DataDir, "netconfc1.cfg"), {Opts,ERPid} = setup([{suite,Suite},{config,CfgFile}, - {label,default}], Config), + {label,netconfc1_SUITE}], Config), - ok = execute(default, Opts, ERPid, Config). + ok = execute(netconfc1_SUITE, Opts, ERPid, Config). + +netconfc_remote_SUITE(Config) when is_list(Config) -> + DataDir = ?config(data_dir, Config), + Suite = filename:join(DataDir, "netconfc_remote_SUITE"), + {Opts,ERPid} = setup([{suite,Suite},{label,netconfc_remote_SUITE}], Config), + + ok = execute(netconfc_remote_SUITE, Opts, ERPid, Config). %%%----------------------------------------------------------------- @@ -112,16 +120,15 @@ reformat(Events, EH) -> %%%----------------------------------------------------------------- %%% TEST EVENTS %%%----------------------------------------------------------------- -events_to_check(default,Config) -> - {module,_} = code:load_abs(filename:join(?config(data_dir,Config), - netconfc1_SUITE)), - TCs = netconfc1_SUITE:all(), - code:purge(netconfc1_SUITE), - code:delete(netconfc1_SUITE), +events_to_check(Suite,Config) -> + {module,_} = code:load_abs(filename:join(?config(data_dir,Config),Suite)), + TCs = Suite:all(), + code:purge(Suite), + code:delete(Suite), OneTest = [{?eh,start_logging,{'DEF','RUNDIR'}}] ++ - [{?eh,tc_done,{netconfc1_SUITE,TC,ok}} || TC <- TCs] ++ + [{?eh,tc_done,{Suite,TC,ok}} || TC <- TCs] ++ [{?eh,stop_logging,[]}], %% 2 tests (ct:run_test + script_start) is default diff --git a/lib/common_test/test/ct_netconfc_SUITE_data/netconfc1_SUITE.erl b/lib/common_test/test/ct_netconfc_SUITE_data/netconfc1_SUITE.erl index 2bcfeeec0c..332e54d1a7 100644 --- a/lib/common_test/test/ct_netconfc_SUITE_data/netconfc1_SUITE.erl +++ b/lib/common_test/test/ct_netconfc_SUITE_data/netconfc1_SUITE.erl @@ -1,7 +1,7 @@ %%-------------------------------------------------------------------- %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2013. All Rights Reserved. +%% Copyright Ericsson AB 2013-2014. 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 @@ -30,25 +30,10 @@ -module(netconfc1_SUITE). -include_lib("common_test/include/ct.hrl"). -include_lib("common_test/src/ct_netconfc.hrl"). --include_lib("public_key/include/public_key.hrl"). +-include("netconfc_test_lib.hrl"). -compile(export_all). -%% Default timetrap timeout (set in init_per_testcase). --define(default_timeout, ?t:minutes(1)). - --define(NS,ns). --define(LOCALHOST, "127.0.0.1"). --define(SSH_PORT, 2060). - --define(DEFAULT_SSH_OPTS,[{ssh,?LOCALHOST}, - {port,?SSH_PORT}, - {user,"xxx"}, - {password,"xxx"}]). --define(DEFAULT_SSH_OPTS(Dir), ?DEFAULT_SSH_OPTS++[{user_dir,Dir}]). - --define(ok,ok). - suite() -> [{ct_hooks, [{cth_conn_log, [{ct_netconfc,[{log_type,html}, %will be overwritten by config @@ -91,6 +76,7 @@ all() -> get_config, get_config_xpath, edit_config, + edit_config_opt_params, copy_config, delete_config, lock, @@ -136,8 +122,8 @@ end_per_testcase(_Case, Config) -> init_per_suite(Config) -> case catch {crypto:start(), ssh:start()} of {ok, ok} -> - {ok, _} = get_id_keys(Config), - make_dsa_files(Config), + {ok, _} = netconfc_test_lib:get_id_keys(Config), + netconfc_test_lib:make_dsa_files(Config), Server = ?NS:start(?config(data_dir,Config)), [{server,Server}|Config]; _ -> @@ -148,7 +134,7 @@ end_per_suite(Config) -> ?NS:stop(?config(server,Config)), ssh:stop(), crypto:stop(), - remove_id_keys(Config), + netconfc_test_lib:remove_id_keys(Config), Config. hello(Config) -> @@ -415,6 +401,18 @@ edit_config(Config) -> ?ok = ct_netconfc:close_session(Client), ok. +edit_config_opt_params(Config) -> + DataDir = ?config(data_dir,Config), + {ok,Client} = open_success(DataDir), + ?NS:expect_reply({'edit-config',{'default-operation',"none"}},ok), + ?ok = ct_netconfc:edit_config(Client,running, + {server,[{xmlns,"myns"}], + [{name,["myserver"]}]}, + [{'default-operation',["none"]}]), + ?NS:expect_do_reply('close-session',close,ok), + ?ok = ct_netconfc:close_session(Client), + ok. + copy_config(Config) -> DataDir = ?config(data_dir,Config), {ok,Client} = open_success(DataDir), @@ -1001,165 +999,3 @@ pad(I) when I<10 -> "0"++integer_to_list(I); pad(I) -> integer_to_list(I). - - -%%%----------------------------------------------------------------- -%%% BEGIN SSH key management -%% copy private keys to given dir from ~/.ssh -get_id_keys(Config) -> - DstDir = ?config(priv_dir, Config), - SrcDir = filename:join(os:getenv("HOME"), ".ssh"), - RsaOk = copyfile(SrcDir, DstDir, "id_rsa"), - DsaOk = copyfile(SrcDir, DstDir, "id_dsa"), - case {RsaOk, DsaOk} of - {{ok, _}, {ok, _}} -> {ok, both}; - {{ok, _}, _} -> {ok, rsa}; - {_, {ok, _}} -> {ok, dsa}; - {Error, _} -> Error - end. - -%% Remove later on. Use make_dsa_files instead. -remove_id_keys(Config) -> - Dir = ?config(priv_dir, Config), - file:delete(filename:join(Dir, "id_rsa")), - file:delete(filename:join(Dir, "id_dsa")). - - -make_dsa_files(Config) -> - make_dsa_files(Config, rfc4716_public_key). -make_dsa_files(Config, Type) -> - {DSA, EncodedKey} = gen_dsa(128, 20), - PKey = DSA#'DSAPrivateKey'.y, - P = DSA#'DSAPrivateKey'.p, - Q = DSA#'DSAPrivateKey'.q, - G = DSA#'DSAPrivateKey'.g, - Dss = #'Dss-Parms'{p=P, q=Q, g=G}, - {ok, Hostname} = inet:gethostname(), - {ok, {A, B, C, D}} = inet:getaddr(Hostname, inet), - IP = lists:concat([A, ".", B, ".", C, ".", D]), - Attributes = [], % Could be [{comment,"user@" ++ Hostname}], - HostNames = [{hostnames,[IP, IP]}], - PublicKey = [{{PKey, Dss}, Attributes}], - KnownHosts = [{{PKey, Dss}, HostNames}], - - KnownHostsEnc = public_key:ssh_encode(KnownHosts, known_hosts), - KnownHosts = public_key:ssh_decode(KnownHostsEnc, known_hosts), - - PublicKeyEnc = public_key:ssh_encode(PublicKey, Type), - - SystemTmpDir = ?config(data_dir, Config), - filelib:ensure_dir(SystemTmpDir), - file:make_dir(SystemTmpDir), - - DSAFile = filename:join(SystemTmpDir, "ssh_host_dsa_key.pub"), - file:delete(DSAFile), - - DSAPrivateFile = filename:join(SystemTmpDir, "ssh_host_dsa_key"), - file:delete(DSAPrivateFile), - - KHFile = filename:join(SystemTmpDir, "known_hosts"), - file:delete(KHFile), - - PemBin = public_key:pem_encode([EncodedKey]), - - file:write_file(DSAFile, PublicKeyEnc), - file:write_file(KHFile, KnownHostsEnc), - file:write_file(DSAPrivateFile, PemBin), - ok. - - -%%-------------------------------------------------------------------- -%% @doc Creates a dsa key (OBS: for testing only) -%% the sizes are in bytes -%% @spec (::integer()) -> {::atom(), ::binary(), ::opaque()} -%% @end -%%-------------------------------------------------------------------- -gen_dsa(LSize,NSize) when is_integer(LSize), is_integer(NSize) -> - Key = gen_dsa2(LSize, NSize), - {Key, encode_key(Key)}. - -encode_key(Key = #'DSAPrivateKey'{}) -> - Der = public_key:der_encode('DSAPrivateKey', Key), - {'DSAPrivateKey', Der, not_encrypted}. - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% DSA key generation (OBS: for testing only) -%% See http://en.wikipedia.org/wiki/Digital_Signature_Algorithm -%% and the fips_186-3.pdf -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -gen_dsa2(LSize, NSize) -> - Q = prime(NSize), %% Choose N-bit prime Q - X0 = prime(LSize), - P0 = prime((LSize div 2) +1), - - %% Choose L-bit prime modulus P such that p-1 is a multiple of q. - case dsa_search(X0 div (2*Q*P0), P0, Q, 1000) of - error -> - gen_dsa2(LSize, NSize); - P -> - G = crypto:mod_pow(2, (P-1) div Q, P), % Choose G a number whose multiplicative order modulo p is q. - %% such that This may be done by setting g = h^(p-1)/q mod p, commonly h=2 is used. - - X = prime(20), %% Choose x by some random method, where 0 < x < q. - Y = crypto:mod_pow(G, X, P), %% Calculate y = g^x mod p. - - #'DSAPrivateKey'{version=0, p = P, q = Q, - g = crypto:bytes_to_integer(G), y = crypto:bytes_to_integer(Y), x = X} - end. - -%% See fips_186-3.pdf -dsa_search(T, P0, Q, Iter) when Iter > 0 -> - P = 2*T*Q*P0 + 1, - case is_prime(P, 50) of - true -> P; - false -> dsa_search(T+1, P0, Q, Iter-1) - end; -dsa_search(_,_,_,_) -> - error. - - -%%%%%%% Crypto Math %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -prime(ByteSize) -> - Rand = odd_rand(ByteSize), - prime_odd(Rand, 0). - -prime_odd(Rand, N) -> - case is_prime(Rand, 50) of - true -> - Rand; - false -> - prime_odd(Rand+2, N+1) - end. - -%% see http://en.wikipedia.org/wiki/Fermat_primality_test -is_prime(_, 0) -> true; -is_prime(Candidate, Test) -> - CoPrime = odd_rand(10000, Candidate), - Result = crypto:mod_pow(CoPrime, Candidate, Candidate) , - is_prime(CoPrime, crypto:bytes_to_integer(Result), Candidate, Test). - -is_prime(CoPrime, CoPrime, Candidate, Test) -> - is_prime(Candidate, Test-1); -is_prime(_,_,_,_) -> - false. - -odd_rand(Size) -> - Min = 1 bsl (Size*8-1), - Max = (1 bsl (Size*8))-1, - odd_rand(Min, Max). - -odd_rand(Min,Max) -> - Rand = crypto:rand_uniform(Min,Max), - case Rand rem 2 of - 0 -> - Rand + 1; - _ -> - Rand - end. - -copyfile(SrcDir, DstDir, Fn) -> - file:copy(filename:join(SrcDir, Fn), - filename:join(DstDir, Fn)). - -%%% END SSH key management -%%%----------------------------------------------------------------- diff --git a/lib/common_test/test/ct_netconfc_SUITE_data/netconfc_remote_SUITE.erl b/lib/common_test/test/ct_netconfc_SUITE_data/netconfc_remote_SUITE.erl new file mode 100644 index 0000000000..7a44d148dd --- /dev/null +++ b/lib/common_test/test/ct_netconfc_SUITE_data/netconfc_remote_SUITE.erl @@ -0,0 +1,147 @@ +%%-------------------------------------------------------------------- +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2014. All Rights Reserved. +%% +%% The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved online at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% %CopyrightEnd% +%% +%%---------------------------------------------------------------------- +-module(netconfc_remote_SUITE). +-include_lib("common_test/include/ct.hrl"). +-include_lib("common_test/src/ct_netconfc.hrl"). +-include("netconfc_test_lib.hrl"). + +-compile(export_all). + +suite() -> + [{ct_hooks, [{cth_conn_log,[{ct_netconfc,[{log_type,html}]}]}]}]. + +all() -> + case os:find_executable("ssh") of + false -> + {skip, "SSH not installed on host"}; + _ -> + [remote_crash + ] + end. + +groups() -> + []. + +init_per_group(_GroupName, Config) -> + Config. + +end_per_group(_GroupName, Config) -> + Config. + +init_per_testcase(Case, Config) -> + stop_node(Case), + Dog = test_server:timetrap(?default_timeout), + [{watchdog, Dog}|Config]. + +end_per_testcase(Case, Config) -> + stop_node(Case), + Dog=?config(watchdog, Config), + test_server:timetrap_cancel(Dog), + ok. + +stop_node(Case) -> + {ok,Host} = inet:gethostname(), + Node = list_to_atom("nc_" ++ atom_to_list(Case)++ "@" ++ Host), + rpc:call(Node,erlang,halt,[]). + + +init_per_suite(Config) -> + case {crypto:start(),ssh:start()} of + {ok,ok} -> + {ok, _} = netconfc_test_lib:get_id_keys(Config), + netconfc_test_lib:make_dsa_files(Config), + Config; + _ -> + {skip, "Crypto and/or SSH could not be started locally!"} + end. + +end_per_suite(Config) -> + ssh:stop(), + crypto:stop(), + netconfc_test_lib:remove_id_keys(Config), + Config. + +%% This test case is related to seq12645 +%% Running the netconf server in a remote node, test that the client +%% process terminates if the remote node goes down. +remote_crash(Config) -> + {ok,Node} = ct_slave:start(nc_remote_crash), + Pa = filename:dirname(code:which(?NS)), + true = rpc:call(Node,code,add_patha,[Pa]), + + case {rpc:call(Node,crypto,start,[]),rpc:call(Node,ssh,start,[])} of + {ok,ok} -> + Server = rpc:call(Node,?NS,start,[?config(data_dir,Config)]), + remote_crash(Node,Config); + _ -> + {skip, "Crypto and/or SSH could not be started remote!"} + end. + +remote_crash(Node,Config) -> + DataDir = ?config(data_dir,Config), + {ok,Client} = open_success(Node,DataDir), + + ns(Node,expect_reply,[{'create-subscription',[stream]},ok]), + ?ok = ct_netconfc:create_subscription(Client), + + true = erlang:is_process_alive(Client), + Ref = erlang:monitor(process,Client), + rpc:call(Node,erlang,halt,[]), % take the node down as brutally as possible + receive {'DOWN',Ref,process,Client,_} -> + ok + after 10000 -> + ct:fail(client_still_alive) + end. + +%%%----------------------------------------------------------------- + +break(_Config) -> + test_server:break("break test case"). + +%%%----------------------------------------------------------------- +%% Open a netconf session which is not specified in a config file +open_success(Node,Dir) -> + open_success(Node,Dir,[]). + +%% Open a netconf session which is not specified in a config file, and +%% give som extra options in addition to the test defaults. +open_success(Node,Dir,ExtraOpts) when is_list(Dir), is_list(ExtraOpts) -> + ns(Node,hello,[1]), % tell server to send hello with session id 1 + ns(Node,expect,[hello]), % tell server to expect a hello message from client + open(Dir,ExtraOpts); + +%% Open a named netconf session which is not specified in a config file +open_success(Node,KeyOrName,Dir) when is_atom(KeyOrName), is_list(Dir) -> + ns(Node,hello,[1]), + ns(Node,expect,[hello]), + ct_netconfc:open(KeyOrName,?DEFAULT_SSH_OPTS(Dir)). + +open(Dir) -> + open(Dir,[]). +open(Dir,ExtraOpts) -> + Opts = lists:ukeymerge(1,lists:keysort(1,ExtraOpts), + lists:keysort(1,?DEFAULT_SSH_OPTS(Dir))), + ct_netconfc:open(Opts). + +%%%----------------------------------------------------------------- +%%% Call server on remote node +ns(Node,Func,Args) -> + rpc:call(Node,?NS,Func,Args). + diff --git a/lib/common_test/test/ct_netconfc_SUITE_data/netconfc_test_lib.erl b/lib/common_test/test/ct_netconfc_SUITE_data/netconfc_test_lib.erl new file mode 100644 index 0000000000..e058bc7600 --- /dev/null +++ b/lib/common_test/test/ct_netconfc_SUITE_data/netconfc_test_lib.erl @@ -0,0 +1,166 @@ +-module(netconfc_test_lib). + +-export([get_id_keys/1, remove_id_keys/1, make_dsa_files/1]). +-include_lib("common_test/include/ct.hrl"). +-include_lib("public_key/include/public_key.hrl"). + +%%%----------------------------------------------------------------- +%%% BEGIN SSH key management +%% copy private keys to given dir from ~/.ssh +get_id_keys(Config) -> + DstDir = ?config(priv_dir, Config), + SrcDir = filename:join(os:getenv("HOME"), ".ssh"), + RsaOk = copyfile(SrcDir, DstDir, "id_rsa"), + DsaOk = copyfile(SrcDir, DstDir, "id_dsa"), + case {RsaOk, DsaOk} of + {{ok, _}, {ok, _}} -> {ok, both}; + {{ok, _}, _} -> {ok, rsa}; + {_, {ok, _}} -> {ok, dsa}; + {Error, _} -> Error + end. + +%% Remove later on. Use make_dsa_files instead. +remove_id_keys(Config) -> + Dir = ?config(priv_dir, Config), + file:delete(filename:join(Dir, "id_rsa")), + file:delete(filename:join(Dir, "id_dsa")). + + +make_dsa_files(Config) -> + make_dsa_files(Config, rfc4716_public_key). +make_dsa_files(Config, Type) -> + {DSA, EncodedKey} = gen_dsa(128, 20), + PKey = DSA#'DSAPrivateKey'.y, + P = DSA#'DSAPrivateKey'.p, + Q = DSA#'DSAPrivateKey'.q, + G = DSA#'DSAPrivateKey'.g, + Dss = #'Dss-Parms'{p=P, q=Q, g=G}, + {ok, Hostname} = inet:gethostname(), + {ok, {A, B, C, D}} = inet:getaddr(Hostname, inet), + IP = lists:concat([A, ".", B, ".", C, ".", D]), + Attributes = [], % Could be [{comment,"user@" ++ Hostname}], + HostNames = [{hostnames,[IP, IP]}], + PublicKey = [{{PKey, Dss}, Attributes}], + KnownHosts = [{{PKey, Dss}, HostNames}], + + KnownHostsEnc = public_key:ssh_encode(KnownHosts, known_hosts), + KnownHosts = public_key:ssh_decode(KnownHostsEnc, known_hosts), + + PublicKeyEnc = public_key:ssh_encode(PublicKey, Type), + + SystemTmpDir = ?config(data_dir, Config), + filelib:ensure_dir(SystemTmpDir), + file:make_dir(SystemTmpDir), + + DSAFile = filename:join(SystemTmpDir, "ssh_host_dsa_key.pub"), + file:delete(DSAFile), + + DSAPrivateFile = filename:join(SystemTmpDir, "ssh_host_dsa_key"), + file:delete(DSAPrivateFile), + + KHFile = filename:join(SystemTmpDir, "known_hosts"), + file:delete(KHFile), + + PemBin = public_key:pem_encode([EncodedKey]), + + file:write_file(DSAFile, PublicKeyEnc), + file:write_file(KHFile, KnownHostsEnc), + file:write_file(DSAPrivateFile, PemBin), + ok. + + +%%-------------------------------------------------------------------- +%% @doc Creates a dsa key (OBS: for testing only) +%% the sizes are in bytes +%% @spec (::integer()) -> {::atom(), ::binary(), ::opaque()} +%% @end +%%-------------------------------------------------------------------- +gen_dsa(LSize,NSize) when is_integer(LSize), is_integer(NSize) -> + Key = gen_dsa2(LSize, NSize), + {Key, encode_key(Key)}. + +encode_key(Key = #'DSAPrivateKey'{}) -> + Der = public_key:der_encode('DSAPrivateKey', Key), + {'DSAPrivateKey', Der, not_encrypted}. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% DSA key generation (OBS: for testing only) +%% See http://en.wikipedia.org/wiki/Digital_Signature_Algorithm +%% and the fips_186-3.pdf +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +gen_dsa2(LSize, NSize) -> + Q = prime(NSize), %% Choose N-bit prime Q + X0 = prime(LSize), + P0 = prime((LSize div 2) +1), + + %% Choose L-bit prime modulus P such that p-1 is a multiple of q. + case dsa_search(X0 div (2*Q*P0), P0, Q, 1000) of + error -> + gen_dsa2(LSize, NSize); + P -> + G = crypto:mod_pow(2, (P-1) div Q, P), % Choose G a number whose multiplicative order modulo p is q. + %% such that This may be done by setting g = h^(p-1)/q mod p, commonly h=2 is used. + + X = prime(20), %% Choose x by some random method, where 0 < x < q. + Y = crypto:mod_pow(G, X, P), %% Calculate y = g^x mod p. + + #'DSAPrivateKey'{version=0, p = P, q = Q, + g = crypto:bytes_to_integer(G), y = crypto:bytes_to_integer(Y), x = X} + end. + +%% See fips_186-3.pdf +dsa_search(T, P0, Q, Iter) when Iter > 0 -> + P = 2*T*Q*P0 + 1, + case is_prime(P, 50) of + true -> P; + false -> dsa_search(T+1, P0, Q, Iter-1) + end; +dsa_search(_,_,_,_) -> + error. + + +%%%%%%% Crypto Math %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +prime(ByteSize) -> + Rand = odd_rand(ByteSize), + prime_odd(Rand, 0). + +prime_odd(Rand, N) -> + case is_prime(Rand, 50) of + true -> + Rand; + false -> + prime_odd(Rand+2, N+1) + end. + +%% see http://en.wikipedia.org/wiki/Fermat_primality_test +is_prime(_, 0) -> true; +is_prime(Candidate, Test) -> + CoPrime = odd_rand(10000, Candidate), + Result = crypto:mod_pow(CoPrime, Candidate, Candidate) , + is_prime(CoPrime, crypto:bytes_to_integer(Result), Candidate, Test). + +is_prime(CoPrime, CoPrime, Candidate, Test) -> + is_prime(Candidate, Test-1); +is_prime(_,_,_,_) -> + false. + +odd_rand(Size) -> + Min = 1 bsl (Size*8-1), + Max = (1 bsl (Size*8))-1, + odd_rand(Min, Max). + +odd_rand(Min,Max) -> + Rand = crypto:rand_uniform(Min,Max), + case Rand rem 2 of + 0 -> + Rand + 1; + _ -> + Rand + end. + +copyfile(SrcDir, DstDir, Fn) -> + file:copy(filename:join(SrcDir, Fn), + filename:join(DstDir, Fn)). + +%%% END SSH key management +%%%----------------------------------------------------------------- diff --git a/lib/common_test/test/ct_netconfc_SUITE_data/netconfc_test_lib.hrl b/lib/common_test/test/ct_netconfc_SUITE_data/netconfc_test_lib.hrl new file mode 100644 index 0000000000..dcaad5ba93 --- /dev/null +++ b/lib/common_test/test/ct_netconfc_SUITE_data/netconfc_test_lib.hrl @@ -0,0 +1,14 @@ +%% Default timetrap timeout (set in init_per_testcase). +-define(default_timeout, ?t:minutes(1)). + +-define(NS,ns). % netconf server module +-define(LOCALHOST, "127.0.0.1"). +-define(SSH_PORT, 2060). + +-define(DEFAULT_SSH_OPTS,[{ssh,?LOCALHOST}, + {port,?SSH_PORT}, + {user,"xxx"}, + {password,"xxx"}]). +-define(DEFAULT_SSH_OPTS(Dir), ?DEFAULT_SSH_OPTS++[{user_dir,Dir}]). + +-define(ok,ok). diff --git a/lib/common_test/test/ct_netconfc_SUITE_data/ns.erl b/lib/common_test/test/ct_netconfc_SUITE_data/ns.erl index fb0734d48e..f7c7b891bb 100644 --- a/lib/common_test/test/ct_netconfc_SUITE_data/ns.erl +++ b/lib/common_test/test/ct_netconfc_SUITE_data/ns.erl @@ -1,7 +1,7 @@ %%-------------------------------------------------------------------- %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2012-2013. All Rights Reserved. +%% Copyright Ericsson AB 2012-2014. 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 @@ -382,6 +382,7 @@ event({startElement,_,Name,_,Attrs},[ignore,{se,Name,As}|Match]) -> event({startPrefixMapping,_,Ns},[{ns,Ns}|Match]) -> Match; event({startPrefixMapping,_,Ns},[ignore,{ns,Ns}|Match]) -> Match; event({endPrefixMapping,_},Match) -> Match; +event({characters,Chs},[{characters,Chs}|Match]) -> Match; event({endElement,_,Name,_},[{ee,Name}|Match]) -> Match; event({endElement,_,Name,_},[ignore,{ee,Name}|Match]) -> Match; event(endDocument,Match) when Match==[]; Match==[ignore] -> ok; @@ -471,14 +472,17 @@ capabilities(no_caps) -> %%% expect_do_reply/3. %%% %%% match(term()) -> [Match]. -%%% Match = ignore | {se,Name} | {se,Name,Attrs} | {ee,Name} | {ns,Namespace} +%%% Match = ignore | {se,Name} | {se,Name,Attrs} | {ee,Name} | +%%% {ns,Namespace} | {characters,Chs} %%% Name = string() +%%% Chs = string() %%% Attrs = [{atom(),string()}] %%% Namespace = string() %%% %%% 'se' means start element, 'ee' means end element - i.e. to match %%% an XML element you need one 'se' entry and one 'ee' entry with the -%%% same name in the match list. +%%% same name in the match list. 'characters' can be used for matching +%%% character data (cdata) inside an element. match(hello) -> [ignore,{se,"hello"},ignore,{ee,"hello"},ignore]; match('close-session') -> @@ -487,6 +491,10 @@ match('close-session') -> match('edit-config') -> [ignore,{se,"rpc"},{se,"edit-config"},{se,"target"},ignore,{ee,"target"}, {se,"config"},ignore,{ee,"config"},{ee,"edit-config"},{ee,"rpc"},ignore]; +match({'edit-config',{'default-operation',DO}}) -> + [ignore,{se,"rpc"},{se,"edit-config"},{se,"target"},ignore,{ee,"target"}, + {se,"default-operation"},{characters,DO},{ee,"default-operation"}, + {se,"config"},ignore,{ee,"config"},{ee,"edit-config"},{ee,"rpc"},ignore]; match('get') -> match({get,subtree}); match({'get',FilterType}) -> diff --git a/lib/compiler/src/beam_block.erl b/lib/compiler/src/beam_block.erl index 7a30c68593..5626aa34ab 100644 --- a/lib/compiler/src/beam_block.erl +++ b/lib/compiler/src/beam_block.erl @@ -155,7 +155,8 @@ collect(remove_message) -> {set,[],[],remove_message}; collect({put_map,F,Op,S,D,R,{list,Puts}}) -> {set,[D],[S|Puts],{alloc,R,{put_map,Op,F}}}; collect({get_map_elements,F,S,{list,Gets}}) -> - {set,Gets,[S],{get_map_elements,F}}; + {Ss,Ds} = beam_utils:spliteven(Gets), + {set,Ds,[S|Ss],{get_map_elements,F}}; collect({'catch',R,L}) -> {set,[R],[],{'catch',L}}; collect(fclearerror) -> {set,[],[],fclearerror}; collect({fcheckerror,{f,0}}) -> {set,[],[],fcheckerror}; diff --git a/lib/compiler/src/beam_flatten.erl b/lib/compiler/src/beam_flatten.erl index 46835bece1..05d067dc48 100644 --- a/lib/compiler/src/beam_flatten.erl +++ b/lib/compiler/src/beam_flatten.erl @@ -63,7 +63,8 @@ norm({set,[],[S,D],{set_tuple_element,I}}) -> {set_tuple_element,S,D,I}; norm({set,[D1,D2],[S],get_list}) -> {get_list,S,D1,D2}; norm({set,[D],[S|Puts],{alloc,R,{put_map,Op,F}}}) -> {put_map,F,Op,S,D,R,{list,Puts}}; -norm({set,Gets,[S],{get_map_elements,F}}) -> +norm({set,Ds,[S|Ss],{get_map_elements,F}}) -> + Gets = beam_utils:joineven(Ss,Ds), {get_map_elements,F,S,{list,Gets}}; norm({set,[],[],remove_message}) -> remove_message; norm({set,[],[],fclearerror}) -> fclearerror; diff --git a/lib/compiler/src/beam_split.erl b/lib/compiler/src/beam_split.erl index 688bba9a94..f5dba314ae 100644 --- a/lib/compiler/src/beam_split.erl +++ b/lib/compiler/src/beam_split.erl @@ -53,8 +53,9 @@ split_block([{set,[D],[S|Puts],{alloc,R,{put_map,Op,{f,Lbl}=Fail}}}|Is], Bl, Acc) when Lbl =/= 0 -> split_block(Is, [], [{put_map,Fail,Op,S,D,R,{list,Puts}}| make_block(Bl, Acc)]); -split_block([{set,Gets,[S],{get_map_elements,{f,Lbl}=Fail}}|Is], Bl, Acc) +split_block([{set,Ds,[S|Ss],{get_map_elements,{f,Lbl}=Fail}}|Is], Bl, Acc) when Lbl =/= 0 -> + Gets = beam_utils:joineven(Ss,Ds), split_block(Is, [], [{get_map_elements,Fail,S,{list,Gets}}|make_block(Bl, Acc)]); split_block([{set,[R],[],{'catch',L}}|Is], Bl, Acc) -> split_block(Is, [], [{'catch',R,L}|make_block(Bl, Acc)]); diff --git a/lib/compiler/src/beam_type.erl b/lib/compiler/src/beam_type.erl index 58c0f765ae..cdddad4153 100644 --- a/lib/compiler/src/beam_type.erl +++ b/lib/compiler/src/beam_type.erl @@ -106,6 +106,20 @@ simplify_basic_1([{test,test_arity,_,[R,Arity]}=I|Is], Ts0, Acc) -> Ts = update(I, Ts0), simplify_basic_1(Is, Ts, [I|Acc]) end; +simplify_basic_1([{test,is_map,_,[R]}=I|Is], Ts0, Acc) -> + case tdb_find(R, Ts0) of + map -> simplify_basic_1(Is, Ts0, Acc); + _Other -> + Ts = update(I, Ts0), + simplify_basic_1(Is, Ts, [I|Acc]) + end; +simplify_basic_1([{test,is_nonempty_list,_,[R]}=I|Is], Ts0, Acc) -> + case tdb_find(R, Ts0) of + nonempty_list -> simplify_basic_1(Is, Ts0, Acc); + _Other -> + Ts = update(I, Ts0), + simplify_basic_1(Is, Ts, [I|Acc]) + end; simplify_basic_1([{test,is_eq_exact,Fail,[R,{atom,_}=Atom]}=I|Is0], Ts0, Acc0) -> Acc = case tdb_find(R, Ts0) of {atom,_}=Atom -> Acc0; @@ -402,6 +416,10 @@ update({test,is_float,_Fail,[Src]}, Ts0) -> tdb_update([{Src,float}], Ts0); update({test,test_arity,_Fail,[Src,Arity]}, Ts0) -> tdb_update([{Src,{tuple,Arity,[]}}], Ts0); +update({test,is_map,_Fail,[Src]}, Ts0) -> + tdb_update([{Src,map}], Ts0); +update({test,is_nonempty_list,_Fail,[Src]}, Ts0) -> + tdb_update([{Src,nonempty_list}], Ts0); update({test,is_eq_exact,_,[Reg,{atom,_}=Atom]}, Ts) -> case tdb_find(Reg, Ts) of error -> @@ -710,6 +728,8 @@ merge_type_info(NewType, _) -> verify_type(NewType), NewType. +verify_type(map) -> ok; +verify_type(nonempty_list) -> ok; verify_type({tuple,Sz,[]}) when is_integer(Sz) -> ok; verify_type({tuple,Sz,[_]}) when is_integer(Sz) -> ok; verify_type({tuple_element,_,_}) -> ok; diff --git a/lib/compiler/src/beam_utils.erl b/lib/compiler/src/beam_utils.erl index 8ca368c167..e82ba82d38 100644 --- a/lib/compiler/src/beam_utils.erl +++ b/lib/compiler/src/beam_utils.erl @@ -26,6 +26,8 @@ code_at/2,bif_to_test/3,is_pure_test/1, live_opt/1,delete_live_annos/1,combine_heap_needs/2]). +-export([joineven/2,spliteven/1]). + -import(lists, [member/2,sort/1,reverse/1,splitwith/2]). -record(live, @@ -832,3 +834,15 @@ x_live([_|Rs], Regs) -> x_live(Rs, Regs); x_live([], Regs) -> Regs. is_live(X, Regs) -> ((Regs bsr X) band 1) =:= 1. + +%% spliteven/1 +%% [1,2,3,4,5,6] -> {[1,3,5],[2,4,6]} +spliteven(Rs) -> spliteven(Rs,[],[]). +spliteven([],Ss,Ds) -> {reverse(Ss),reverse(Ds)}; +spliteven([S,D|Rs],Ss,Ds) -> + spliteven(Rs,[S|Ss],[D|Ds]). + +%% joineven/1 +%% {[1,3,5],[2,4,6]} -> [1,2,3,4,5,6] +joineven([],[]) -> []; +joineven([S|Ss],[D|Ds]) -> [S,D|joineven(Ss,Ds)]. diff --git a/lib/compiler/src/beam_validator.erl b/lib/compiler/src/beam_validator.erl index 9d5563d13b..0acc7a227f 100644 --- a/lib/compiler/src/beam_validator.erl +++ b/lib/compiler/src/beam_validator.erl @@ -1123,7 +1123,9 @@ assert_freg_set(Fr, _) -> error({bad_source,Fr}). %%% Maps %% ensure that a list of literals has a strict -%% ascending term order (also meaning unique literals) +%% ascending term order (also meaning unique literals). +%% Single item lists may have registers. +assert_strict_literal_termorder([_]) -> ok; assert_strict_literal_termorder(Ls) -> Vs = lists:map(fun (L) -> get_literal(L) end, Ls), case check_strict_value_termorder(Vs) of diff --git a/lib/compiler/src/cerl.erl b/lib/compiler/src/cerl.erl index 9d6768b157..7a2c3d70de 100644 --- a/lib/compiler/src/cerl.erl +++ b/lib/compiler/src/cerl.erl @@ -3063,10 +3063,12 @@ pat_vars(Node, Vs) -> map -> pat_list_vars(map_es(Node), Vs); map_pair -> - pat_list_vars([map_pair_op(Node),map_pair_key(Node),map_pair_val(Node)],Vs); + %% map_pair_key is not a pattern var, excluded + pat_list_vars([map_pair_op(Node),map_pair_val(Node)],Vs); binary -> pat_list_vars(binary_segments(Node), Vs); bitstr -> + %% bitstr_size is not a pattern var, excluded pat_vars(bitstr_val(Node), Vs); alias -> pat_vars(alias_pat(Node), [alias_var(Node) | Vs]) diff --git a/lib/compiler/src/cerl_inline.erl b/lib/compiler/src/cerl_inline.erl index 75740e8b9d..f8489a800b 100644 --- a/lib/compiler/src/cerl_inline.erl +++ b/lib/compiler/src/cerl_inline.erl @@ -1341,23 +1341,23 @@ i_bitstr(E, Ren, Env, S) -> S3 = count_size(weight(bitstr), S2), {update_c_bitstr(E, Val, Size, Unit, Type, Flags), S3}. -i_map(E, Ctx, Ren, Env, S) -> +i_map(E, Ctx, Ren, Env, S0) -> %% Visit the segments for value. - {M1, S1} = i(map_arg(E), value, Ren, Env, S), + {M1, S1} = i(map_arg(E), value, Ren, Env, S0), {Es, S2} = mapfoldl(fun (E, S) -> i_map_pair(E, Ctx, Ren, Env, S) end, S1, map_es(E)), S3 = count_size(weight(map), S2), {update_c_map(E, M1,Es), S3}. -i_map_pair(E, Ctx, Ren, Env, S) -> - %% It is not necessary to visit the Op and Key fields, - %% since these are always literals. - {Val, S1} = i(map_pair_val(E), Ctx, Ren, Env, S), +i_map_pair(E, Ctx, Ren, Env, S0) -> + %% It is not necessary to visit the Op field + %% since it is always a literal. + {Key, S1} = i(map_pair_key(E), value, Ren, Env, S0), + {Val, S2} = i(map_pair_val(E), Ctx, Ren, Env, S1), Op = map_pair_op(E), - Key = map_pair_key(E), - S2 = count_size(weight(map_pair), S1), - {update_c_map_pair(E, Op, Key, Val), S2}. + S3 = count_size(weight(map_pair), S2), + {update_c_map_pair(E, Op, Key, Val), S3}. %% This is a simplified version of `i_pattern', for lists of parameter @@ -1420,15 +1420,11 @@ i_pattern(E, Ren, Env, Ren0, Env0, S) -> S2 = count_size(weight(binary), S1), {update_c_binary(E, Es), S2}; map -> - %% map patterns should not have args - M = map_arg(E), - {Es, S1} = mapfoldl(fun (E, S) -> i_map_pair_pattern(E, Ren, Env, Ren0, Env0, S) - end, - S, map_es(E)), + end, S, map_es(E)), S2 = count_size(weight(map), S1), - {update_c_map(E, M, Es), S2}; + {update_c_map(E, map_arg(E), Es), S2}; _ -> case is_literal(E) of true -> @@ -1464,12 +1460,12 @@ i_bitstr_pattern(E, Ren, Env, Ren0, Env0, S) -> i_map_pair_pattern(E, Ren, Env, Ren0, Env0, S) -> %% It is not necessary to visit the Op it is always a literal. - %% Same goes for Key - {Val, S1} = i_pattern(map_pair_val(E), Ren, Env, Ren0, Env0, S), + %% Key is an expression + {Key, S1} = i(map_pair_key(E), value, Ren0, Env0, S), + {Val, S2} = i_pattern(map_pair_val(E), Ren, Env, Ren0, Env0, S1), Op = map_pair_op(E), %% should be 'exact' literal - Key = map_pair_key(E), - S2 = count_size(weight(map_pair), S1), - {update_c_map_pair(E, Op, Key, Val), S2}. + S3 = count_size(weight(map_pair), S2), + {update_c_map_pair(E, Op, Key, Val), S3}. %% --------------------------------------------------------------------- diff --git a/lib/compiler/src/cerl_trees.erl b/lib/compiler/src/cerl_trees.erl index e53bdd4efb..b93da8e97f 100644 --- a/lib/compiler/src/cerl_trees.erl +++ b/lib/compiler/src/cerl_trees.erl @@ -520,9 +520,9 @@ variables(T, S) -> tuple -> vars_in_list(tuple_es(T), S); map -> - vars_in_list(map_es(T), S); + vars_in_list([map_arg(T)|map_es(T)], S); map_pair -> - vars_in_list([map_pair_op(T),map_pair_key(T), map_pair_val(T)], S); + vars_in_list([map_pair_op(T),map_pair_key(T),map_pair_val(T)], S); 'let' -> Vs = variables(let_body(T), S), Vs1 = var_list_names(let_vars(T)), diff --git a/lib/compiler/src/compile.erl b/lib/compiler/src/compile.erl index c7d91070f6..f347438509 100644 --- a/lib/compiler/src/compile.erl +++ b/lib/compiler/src/compile.erl @@ -431,11 +431,6 @@ pass(from_core) -> {".core",[?pass(parse_core)|core_passes()]}; pass(from_asm) -> {".S",[?pass(beam_consult_asm)|asm_passes()]}; -pass(asm) -> - %% TODO: remove 'asm' in 18.0 - io:format("compile:file/2 option 'asm' has been deprecated and will be~n" - "removed in the 18.0 release. Use 'from_asm' instead.~n"), - pass(from_asm); pass(from_beam) -> {".beam",[?pass(read_beam_file)|binary_passes()]}; pass(_) -> none. diff --git a/lib/compiler/src/core_lint.erl b/lib/compiler/src/core_lint.erl index 25df33a287..c0e2bdaba0 100644 --- a/lib/compiler/src/core_lint.erl +++ b/lib/compiler/src/core_lint.erl @@ -33,9 +33,6 @@ %% Values only as multiple values/variables/patterns. %% Return same number of values as requested %% Correct number of arguments -%% -%% Checks to add: -%% %% Consistency of values/variables %% Consistency of function return values/calls. %% @@ -211,7 +208,7 @@ functions(Fs, Def, St0) -> function({#c_var{name={_,_}},B}, Def, St) -> %% Body must be a fun! case B of - #c_fun{} -> expr(B, Def, any, St); + #c_fun{} -> expr(B, Def, 1, St); _ -> add_error({illegal_expr,St#lint.func}, St) end. @@ -247,40 +244,42 @@ gbody(E, Def, Rt, St0) -> false -> St1 end. -gexpr(#c_var{name=N}, Def, _Rt, St) when is_atom(N); is_integer(N) -> - expr_var(N, Def, St); -gexpr(#c_literal{}, _Def, _Rt, St) -> St; -gexpr(#c_cons{hd=H,tl=T}, Def, _Rt, St) -> - gexpr_list([H,T], Def, St); -gexpr(#c_tuple{es=Es}, Def, _Rt, St) -> - gexpr_list(Es, Def, St); -gexpr(#c_map{es=Es}, Def, _Rt, St) -> - gexpr_list(Es, Def, St); -gexpr(#c_map_pair{key=K,val=V}, Def, _Rt, St) -> - gexpr_list([K,V], Def, St); -gexpr(#c_binary{segments=Ss}, Def, _Rt, St) -> - gbitstr_list(Ss, Def, St); +gexpr(#c_var{name=N}, Def, Rt, St) when is_atom(N); is_integer(N) -> + return_match(Rt, 1, expr_var(N, Def, St)); +gexpr(#c_literal{}, _Def, Rt, St) -> + return_match(Rt, 1, St); +gexpr(#c_cons{hd=H,tl=T}, Def, Rt, St) -> + return_match(Rt, 1, gexpr_list([H,T], Def, St)); +gexpr(#c_tuple{es=Es}, Def, Rt, St) -> + return_match(Rt, 1, gexpr_list(Es, Def, St)); +gexpr(#c_map{es=Es}, Def, Rt, St) -> + return_match(Rt, 1, gexpr_list(Es, Def, St)); +gexpr(#c_map_pair{key=K,val=V}, Def, Rt, St) -> + return_match(Rt, 1, gexpr_list([K,V], Def, St)); +gexpr(#c_binary{segments=Ss}, Def, Rt, St) -> + return_match(Rt, 1, gbitstr_list(Ss, Def, St)); gexpr(#c_seq{arg=Arg,body=B}, Def, Rt, St0) -> - St1 = gexpr(Arg, Def, any, St0), %Ignore values - gbody(B, Def, Rt, St1); + St1 = gexpr(Arg, Def, 1, St0), + return_match(Rt, 1, gbody(B, Def, Rt, St1)); gexpr(#c_let{vars=Vs,arg=Arg,body=B}, Def, Rt, St0) -> St1 = gbody(Arg, Def, let_varcount(Vs), St0), %This is a guard body {Lvs,St2} = variable_list(Vs, St1), gbody(B, union(Lvs, Def), Rt, St2); gexpr(#c_call{module=#c_literal{val=erlang},name=#c_literal{val=is_record}, args=[Arg,#c_literal{val=Tag},#c_literal{val=Size}]}, - Def, 1, St) when is_atom(Tag), is_integer(Size) -> - gexpr(Arg, Def, 1, St); + Def, Rt, St) when is_atom(Tag), is_integer(Size) -> + return_match(Rt, 1, gexpr(Arg, Def, 1, St)); gexpr(#c_call{module=#c_literal{val=erlang},name=#c_literal{val=is_record}}, - _Def, 1, St) -> - add_error({illegal_guard,St#lint.func}, St); + _Def, Rt, St) -> + return_match(Rt, 1, add_error({illegal_guard,St#lint.func}, St)); gexpr(#c_call{module=#c_literal{val=erlang},name=#c_literal{val=Name},args=As}, - Def, 1, St) when is_atom(Name) -> + Def, Rt, St0) when is_atom(Name) -> + St1 = return_match(Rt, 1, St0), case is_guard_bif(Name, length(As)) of true -> - gexpr_list(As, Def, St); + gexpr_list(As, Def, St1); false -> - add_error({illegal_guard,St#lint.func}, St) + add_error({illegal_guard,St1#lint.func}, St1) end; gexpr(#c_primop{name=#c_literal{val=A},args=As}, Def, _Rt, St0) when is_atom(A) -> gexpr_list(As, Def, St0); @@ -319,23 +318,25 @@ is_guard_bif(Name, Arity) -> %% expr(Expr, Defined, RetCount, State) -> State. -expr(#c_var{name={_,_}=FA}, Def, _Rt, St) -> - expr_fname(FA, Def, St); -expr(#c_var{name=N}, Def, _Rt, St) -> expr_var(N, Def, St); -expr(#c_literal{}, _Def, _Rt, St) -> St; -expr(#c_cons{hd=H,tl=T}, Def, _Rt, St) -> - expr_list([H,T], Def, St); -expr(#c_tuple{es=Es}, Def, _Rt, St) -> - expr_list(Es, Def, St); -expr(#c_map{es=Es}, Def, _Rt, St) -> - expr_list(Es, Def, St); -expr(#c_map_pair{key=K,val=V},Def,_Rt,St) -> - expr_list([K,V],Def,St); -expr(#c_binary{segments=Ss}, Def, _Rt, St) -> - bitstr_list(Ss, Def, St); +expr(#c_var{name={_,_}=FA}, Def, Rt, St) -> + return_match(Rt, 1, expr_fname(FA, Def, St)); +expr(#c_var{name=N}, Def, Rt, St) -> + return_match(Rt, 1, expr_var(N, Def, St)); +expr(#c_literal{}, _Def, Rt, St) -> + return_match(Rt, 1, St); +expr(#c_cons{hd=H,tl=T}, Def, Rt, St) -> + return_match(Rt, 1, expr_list([H,T], Def, St)); +expr(#c_tuple{es=Es}, Def, Rt, St) -> + return_match(Rt, 1, expr_list(Es, Def, St)); +expr(#c_map{es=Es}, Def, Rt, St) -> + return_match(Rt, 1, expr_list(Es, Def, St)); +expr(#c_map_pair{key=K,val=V}, Def, Rt, St) -> + return_match(Rt, 1, expr_list([K,V], Def, St)); +expr(#c_binary{segments=Ss}, Def, Rt, St) -> + return_match(Rt, 1, bitstr_list(Ss, Def, St)); expr(#c_fun{vars=Vs,body=B}, Def, Rt, St0) -> {Vvs,St1} = variable_list(Vs, St0), - return_match(Rt, 1, body(B, union(Vvs, Def), any, St1)); + return_match(Rt, 1, body(B, union(Vvs, Def), 1, St1)); expr(#c_seq{arg=Arg,body=B}, Def, Rt, St0) -> St1 = expr(Arg, Def, 1, St0), body(B, Def, Rt, St1); @@ -361,15 +362,26 @@ expr(#c_receive{clauses=Cs,timeout=T,action=A}, Def, Rt, St0) -> St1 = expr(T, Def, 1, St0), St2 = body(A, Def, Rt, St1), clauses(Cs, Def, 1, Rt, St2); -expr(#c_apply{op=Op,args=As}, Def, _Rt, St0) -> +expr(#c_apply{op=Op,args=As}, Def, Rt, St0) -> St1 = apply_op(Op, Def, length(As), St0), - expr_list(As, Def, St1); + return_match(Rt, 1, expr_list(As, Def, St1)); +expr(#c_call{module=#c_literal{val=erlang},name=#c_literal{val=Name},args=As}, + Def, Rt, St0) when is_atom(Name) -> + St1 = expr_list(As, Def, St0), + case erl_bifs:is_exit_bif(erlang, Name, length(As)) of + true -> St1; + false -> return_match(Rt, 1, St1) + end; expr(#c_call{module=M,name=N,args=As}, Def, _Rt, St0) -> St1 = expr(M, Def, 1, St0), St2 = expr(N, Def, 1, St1), expr_list(As, Def, St2); -expr(#c_primop{name=#c_literal{val=A},args=As}, Def, _Rt, St0) when is_atom(A) -> - expr_list(As, Def, St0); +expr(#c_primop{name=#c_literal{val=A},args=As}, Def, Rt, St0) when is_atom(A) -> + St1 = expr_list(As, Def, St0), + case A of + match_fail -> St1; + _ -> return_match(Rt, 1, St1) + end; expr(#c_catch{body=B}, Def, Rt, St) -> return_match(Rt, 1, body(B, Def, 1, St)); expr(#c_try{arg=A,vars=Vs,body=B,evars=Evs,handler=H}, Def, Rt, St0) -> diff --git a/lib/compiler/src/core_pp.erl b/lib/compiler/src/core_pp.erl index 83412ecdd7..03801a9b6d 100644 --- a/lib/compiler/src/core_pp.erl +++ b/lib/compiler/src/core_pp.erl @@ -125,8 +125,8 @@ format_1(#c_literal{anno=A,val=M},Ctxt) when is_map(M) -> _ -> assoc end, Cpairs = [#c_map_pair{op=#c_literal{val=Op}, - key=#c_literal{val=V}, - val=#c_literal{val=K}} || {K,V} <- Pairs], + key=#c_literal{val=K}, + val=#c_literal{val=V}} || {K,V} <- Pairs], format_1(#c_map{anno=A,arg=#c_literal{val=#{}},es=Cpairs},Ctxt); format_1(#c_var{name={I,A}}, _) -> [core_atom(I),$/,integer_to_list(A)]; diff --git a/lib/compiler/src/sys_pre_expand.erl b/lib/compiler/src/sys_pre_expand.erl index 761ae8409c..f99307c865 100644 --- a/lib/compiler/src/sys_pre_expand.erl +++ b/lib/compiler/src/sys_pre_expand.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2012. All Rights Reserved. +%% Copyright Ericsson AB 1996-2014. 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 @@ -33,12 +33,15 @@ -include("../include/erl_bits.hrl"). +-type fa() :: {atom(), arity()}. + -record(expand, {module=[], %Module name exports=[], %Exports imports=[], %Imports compile=[], %Compile flags attributes=[], %Attributes callbacks=[], %Callbacks + optional_callbacks=[] :: [fa()], %Optional callbacks defined, %Defined functions (gb_set) vcount=0, %Variable counter func=[], %Current function @@ -99,7 +102,21 @@ define_functions(Forms, #expand{defined=Predef}=St) -> module_attrs(#expand{attributes=Attributes}=St) -> Attrs = [{attribute,Line,Name,Val} || {Name,Line,Val} <- Attributes], Callbacks = [Callback || {_,_,callback,_}=Callback <- Attrs], - {Attrs,St#expand{callbacks=Callbacks}}. + OptionalCallbacks = get_optional_callbacks(Attrs), + {Attrs,St#expand{callbacks=Callbacks, + optional_callbacks=OptionalCallbacks}}. + +get_optional_callbacks(Attrs) -> + L = [O || + {attribute, _, optional_callbacks, O} <- Attrs, + is_fa_list(O)], + lists:append(L). + +is_fa_list([{FuncName, Arity}|L]) + when is_atom(FuncName), is_integer(Arity), Arity >= 0 -> + is_fa_list(L); +is_fa_list([]) -> true; +is_fa_list(_) -> false. module_predef_funcs(St) -> {Mpf1,St1}=module_predef_func_beh_info(St), @@ -108,19 +125,24 @@ module_predef_funcs(St) -> module_predef_func_beh_info(#expand{callbacks=[]}=St) -> {[], St}; -module_predef_func_beh_info(#expand{callbacks=Callbacks,defined=Defined, +module_predef_func_beh_info(#expand{callbacks=Callbacks, + optional_callbacks=OptionalCallbacks, + defined=Defined, exports=Exports}=St) -> PreDef=[{behaviour_info,1}], PreExp=PreDef, - {[gen_beh_info(Callbacks)], + {[gen_beh_info(Callbacks, OptionalCallbacks)], St#expand{defined=gb_sets:union(gb_sets:from_list(PreDef), Defined), exports=union(from_list(PreExp), Exports)}}. -gen_beh_info(Callbacks) -> +gen_beh_info(Callbacks, OptionalCallbacks) -> List = make_list(Callbacks), + OptionalList = make_optional_list(OptionalCallbacks), {function,0,behaviour_info,1, [{clause,0,[{atom,0,callbacks}],[], - [List]}]}. + [List]}, + {clause,0,[{atom,0,optional_callbacks}],[], + [OptionalList]}]}. make_list([]) -> {nil,0}; make_list([{_,_,_,[{{Name,Arity},_}]}|Rest]) -> @@ -130,6 +152,14 @@ make_list([{_,_,_,[{{Name,Arity},_}]}|Rest]) -> {integer,0,Arity}]}, make_list(Rest)}. +make_optional_list([]) -> {nil,0}; +make_optional_list([{Name,Arity}|Rest]) -> + {cons,0, + {tuple,0, + [{atom,0,Name}, + {integer,0,Arity}]}, + make_optional_list(Rest)}. + module_predef_funcs_mod_info(St) -> PreDef = [{module_info,0},{module_info,1}], PreExp = PreDef, @@ -232,9 +262,18 @@ pattern({map,Line,Ps}, St0) -> {TPs,St1} = pattern_list(Ps, St0), {{map,Line,TPs},St1}; pattern({map_field_exact,Line,K0,V0}, St0) -> - {K,St1} = expr(K0, St0), + %% Key should be treated as an expression + %% but since expressions are not allowed yet, + %% process it through pattern .. and handle assoc + %% (normalise unary op integer -> integer) + {K,St1} = pattern(K0, St0), {V,St2} = pattern(V0, St1), {{map_field_exact,Line,K,V},St2}; +pattern({map_field_assoc,Line,K0,V0}, St0) -> + %% when keys are Maps + {K,St1} = pattern(K0, St0), + {V,St2} = pattern(V0, St1), + {{map_field_assoc,Line,K,V},St2}; %%pattern({struct,Line,Tag,Ps}, St0) -> %% {TPs,TPsvs,St1} = pattern_list(Ps, St0), %% {{tuple,Line,[{atom,Line,Tag}|TPs]},TPsvs,St1}; diff --git a/lib/compiler/src/v3_codegen.erl b/lib/compiler/src/v3_codegen.erl index 47a357c23d..8c1a0c08ac 100644 --- a/lib/compiler/src/v3_codegen.erl +++ b/lib/compiler/src/v3_codegen.erl @@ -210,7 +210,7 @@ need_heap_0([], H, Acc) -> need_heap_1(#l{ke={set,_,{binary,_}},i=I}, H) -> {need_heap_need(I, H),0}; -need_heap_1(#l{ke={set,_,{map,_,_}},i=I}, H) -> +need_heap_1(#l{ke={set,_,{map,_,_,_}},i=I}, H) -> {need_heap_need(I, H),0}; need_heap_1(#l{ke={set,_,Val}}, H) -> %% Just pass through adding to needed heap. @@ -643,10 +643,6 @@ select_val_cg(tuple, R, [Arity,{f,Lbl}], Tf, Vf, [{label,Lbl}|Sis]) -> [{test,is_tuple,{f,Tf},[R]},{test,test_arity,{f,Vf},[R,Arity]}|Sis]; select_val_cg(tuple, R, Vls, Tf, Vf, Sis) -> [{test,is_tuple,{f,Tf},[R]},{select_tuple_arity,R,{f,Vf},{list,Vls}}|Sis]; -select_val_cg(map, R, [_Val,{f,Lbl}], Fail, Fail, [{label,Lbl}|Sis]) -> - [{test,is_map,{f,Fail},[R]}|Sis]; -select_val_cg(map, R, [_Val,{f,Lbl}|_], Tf, _Vf, [{label,Lbl}|Sis]) -> - [{test,is_map,{f,Tf},[R]}|Sis]; select_val_cg(Type, R, [Val, {f,Lbl}], Fail, Fail, [{label,Lbl}|Sis]) -> [{test,is_eq_exact,{f,Fail},[R,{Type,Val}]}|Sis]; select_val_cg(Type, R, [Val, {f,Lbl}], Tf, Vf, [{label,Lbl}|Sis]) -> @@ -947,27 +943,34 @@ select_extract_map(Src, Vs, Fail, I, Vdb, Bef, St) -> %% Assume keys are term-sorted Rsrc = fetch_var(Src, Bef), - {{HasKs,GetVs},Aft} = lists:foldr(fun - ({map_pair,Key,{var,V}},{{HasKsi,GetVsi},Int0}) -> + {{HasKs,GetVs,HasVarKs,GetVarVs},Aft} = lists:foldr(fun + ({map_pair,{var,K},{var,V}},{{HasKsi,GetVsi,HasVarVsi,GetVarVsi},Int0}) -> case vdb_find(V, Vdb) of {V,_,L} when L =< I -> - {{[Key|HasKsi],GetVsi},Int0}; + RK = fetch_var(K,Int0), + {{HasKsi,GetVsi,[RK|HasVarVsi],GetVarVsi},Int0}; _Other -> Reg1 = put_reg(V, Int0#sr.reg), Int1 = Int0#sr{reg=Reg1}, - {{HasKsi,[Key,fetch_reg(V, Reg1)|GetVsi]},Int1} + RK = fetch_var(K,Int0), + RV = fetch_reg(V,Reg1), + {{HasKsi,GetVsi,HasVarVsi,[[RK,RV]|GetVarVsi]},Int1} + end; + ({map_pair,Key,{var,V}},{{HasKsi,GetVsi,HasVarVsi,GetVarVsi},Int0}) -> + case vdb_find(V, Vdb) of + {V,_,L} when L =< I -> + {{[Key|HasKsi],GetVsi,HasVarVsi,GetVarVsi},Int0}; + _Other -> + Reg1 = put_reg(V, Int0#sr.reg), + Int1 = Int0#sr{reg=Reg1}, + {{HasKsi,[Key,fetch_reg(V, Reg1)|GetVsi],HasVarVsi,GetVarVsi},Int1} end - end, {{[],[]},Bef}, Vs), - - Code = case {HasKs,GetVs} of - {HasKs,[]} -> - [{test,has_map_fields,{f,Fail},Rsrc,{list,HasKs}}]; - {[],GetVs} -> - [{get_map_elements, {f,Fail},Rsrc,{list,GetVs}}]; - {HasKs,GetVs} -> - [{test,has_map_fields,{f,Fail},Rsrc,{list,HasKs}}, - {get_map_elements, {f,Fail},Rsrc,{list,GetVs}}] - end, + end, {{[],[],[],[]},Bef}, Vs), + + Code = [{test,has_map_fields,{f,Fail},Rsrc,{list,HasKs}} || HasKs =/= []] ++ + [{test,has_map_fields,{f,Fail},Rsrc,{list,[K]}} || K <- HasVarKs] ++ + [{get_map_elements, {f,Fail},Rsrc,{list,GetVs}} || GetVs =/= []] ++ + [{get_map_elements, {f,Fail},Rsrc,{list,[K,V]}} || [K,V] <- GetVarVs], {Code, Aft, St}. @@ -1504,9 +1507,39 @@ set_cg([{var,R}], {binary,Segs}, Le, Vdb, Bef, %% Now generate the complete code for constructing the binary. Code = cg_binary(PutCode, Target, Temp, Fail, MaxRegs, Le#l.a), {Sis++Code,Aft,St}; +% Map single variable key +set_cg([{var,R}], {map,Op,Map,[{map_pair,{var,_}=K,V}]}, Le, Vdb, Bef, + #cg{in_catch=InCatch,bfail=Bfail}=St) -> + + Fail = {f,Bfail}, + {Sis,Int0} = + case InCatch of + true -> adjust_stack(Bef, Le#l.i, Le#l.i+1, Vdb); + false -> {[],Bef} + end, + SrcReg = cg_reg_arg(Map,Int0), + Line = line(Le#l.a), + + List = [cg_reg_arg(K,Int0),cg_reg_arg(V,Int0)], + + Live = max_reg(Bef#sr.reg), + Int1 = Int0#sr{reg=put_reg(R, Int0#sr.reg)}, + Aft = clear_dead(Int1, Le#l.i, Vdb), + Target = fetch_reg(R, Int1#sr.reg), + + I = case Op of + assoc -> put_map_assoc; + exact -> put_map_exact + end, + {Sis++[Line]++[{I,Fail,SrcReg,Target,Live,{list,List}}],Aft,St}; + +% Map (possibly) multiple literal keys set_cg([{var,R}], {map,Op,Map,Es}, Le, Vdb, Bef, #cg{in_catch=InCatch,bfail=Bfail}=St) -> + %% assert key literals + [] = [Var||{map_pair,{var,_}=Var,_} <- Es], + Fail = {f,Bfail}, {Sis,Int0} = case InCatch of diff --git a/lib/compiler/src/v3_core.erl b/lib/compiler/src/v3_core.erl index caf5298d38..612660c2d6 100644 --- a/lib/compiler/src/v3_core.erl +++ b/lib/compiler/src/v3_core.erl @@ -78,7 +78,7 @@ -import(ordsets, [add_element/2,del_element/2,is_element/2, union/1,union/2,intersection/2,subtract/2]). -import(cerl, [ann_c_cons/3,ann_c_cons_skel/3,ann_c_tuple/2,c_tuple/1, - ann_c_map/2, ann_c_map/3]). + ann_c_map/3]). -include("core_parse.hrl"). @@ -169,60 +169,81 @@ form({attribute,_,_,_}=F, {Fs,As,Ws,File}, _Opts) -> attribute({attribute,Line,Name,Val}) -> {#c_literal{val=Name, anno=[Line]}, #c_literal{val=Val, anno=[Line]}}. +%% function_dump(module_info,_,_,_) -> ok; +%% function_dump(Name,Arity,Format,Terms) -> +%% io:format("~w/~w " ++ Format,[Name,Arity]++Terms), +%% ok. + function({function,_,Name,Arity,Cs0}, Ws0, File, Opts) -> - %%ok = io:fwrite("~p - ", [{Name,Arity}]), St0 = #core{vcount=0,opts=Opts,ws=Ws0,file=[{file,File}]}, {B0,St1} = body(Cs0, Name, Arity, St0), - %%ok = io:fwrite("1", []), - %%ok = io:fwrite("~w:~p~n", [?LINE,B0]), + %% ok = function_dump(Name,Arity,"body:~n~p~n",[B0]), {B1,St2} = ubody(B0, St1), - %%ok = io:fwrite("2", []), - %%ok = io:fwrite("~w:~p~n", [?LINE,B1]), + %% ok = function_dump(Name,Arity,"ubody:~n~p~n",[B1]), {B2,#core{ws=Ws}} = cbody(B1, St2), - %%ok = io:fwrite("3~n", []), - %%ok = io:fwrite("~w:~p~n", [?LINE,B2]), + %% ok = function_dump(Name,Arity,"cbody:~n~p~n",[B2]), {{#c_var{name={Name,Arity}},B2},Ws}. body(Cs0, Name, Arity, St0) -> Anno = lineno_anno(element(2, hd(Cs0)), St0), {Args,St1} = new_vars(Anno, Arity, St0), - {Cs1,St2} = clauses(Cs0, St1), - {Ps,St3} = new_vars(Arity, St2), %Need new variables here - Fc = function_clause(Ps, Anno, {Name,Arity}), - {#ifun{anno=#a{anno=Anno},id=[],vars=Args,clauses=Cs1,fc=Fc},St3}. + case clauses(Cs0, St1) of + {Cs1,[],St2} -> + {Ps,St3} = new_vars(Arity, St2), %Need new variables here + Fc = function_clause(Ps, Anno, {Name,Arity}), + {#ifun{anno=#a{anno=Anno},id=[],vars=Args,clauses=Cs1,fc=Fc},St3}; + {Cs1,Eps,St2} -> + %% We have pre-expressions from patterns and + %% these needs to be letified before matching + %% since only bound variables are allowed + AnnoGen = #a{anno=[compiler_generated]}, + {Ps1,St3} = new_vars(Arity, St2), %Need new variables here + Fc1 = function_clause(Ps1, Anno, {Name,Arity}), + {Ps2,St4} = new_vars(Arity, St3), %Need new variables here + Fc2 = function_clause(Ps2, Anno, {Name,Arity}), + Case = #icase{anno=AnnoGen,args=Args, + clauses=Cs1, + fc=Fc2}, + {#ifun{anno=#a{anno=Anno},id=[],vars=Args, + clauses=[#iclause{anno=AnnoGen,pats=Ps1, + guard=[#c_literal{val=true}], + body=Eps ++ [Case]}], + fc=Fc1},St4} + end. %% clause(Clause, State) -> {Cclause,State} | noclause. %% clauses([Clause], State) -> {[Cclause],State}. %% Convert clauses. Trap bad pattern aliases and remove clause from %% clause list. -clauses([C0|Cs0], St0) -> +clauses([C0|Cs0],St0) -> case clause(C0, St0) of - {noclause,St} -> clauses(Cs0, St); - {C,St1} -> - {Cs,St2} = clauses(Cs0, St1), - {[C|Cs],St2} + {noclause,_,St} -> clauses(Cs0,St); + {C,Eps1,St1} -> + {Cs,Eps2,St2} = clauses(Cs0, St1), + {[C|Cs],Eps1++Eps2,St2} end; -clauses([], St) -> {[],St}. +clauses([],St) -> {[],[],St}. clause({clause,Lc,H0,G0,B0}, St0) -> try head(H0, St0) of - H1 -> - {G1,St1} = guard(G0, St0), - {B1,St2} = exprs(B0, St1), - Anno = lineno_anno(Lc, St2), - {#iclause{anno=#a{anno=Anno},pats=H1,guard=G1,body=B1},St2} + {H1,Eps,St1} -> + {G1,St2} = guard(G0, St1), + {B1,St3} = exprs(B0, St2), + Anno = lineno_anno(Lc, St3), + {#iclause{anno=#a{anno=Anno},pats=H1,guard=G1,body=B1},Eps,St3} catch throw:nomatch -> St = add_warning(Lc, nomatch, St0), - {noclause,St} %Bad pattern + {noclause,[],St} %Bad pattern end. clause_arity({clause,_,H0,_,_}) -> length(H0). -%% head([P], State) -> [P]. +%% head([P], State) -> {[P],[Cexpr],State}. -head(Ps, St) -> pattern_list(Ps, St). +head(Ps, St) -> + pattern_list(Ps, St). %% guard([Expr], State) -> {[Cexpr],State}. %% Build an explict and/or tree of guard alternatives, then traverse @@ -514,22 +535,7 @@ expr({tuple,L,Es0}, St0) -> A = record_anno(L, St1), {annotate_tuple(A, Es1, St1),Eps,St1}; expr({map,L,Es0}, St0) -> - % erl_lint should make sure only #{ K => V } are allowed - % in map construction. - try map_pair_list(Es0, St0) of - {Es1,Eps,St1} -> - A = lineno_anno(L, St1), - {ann_c_map(A,Es1),Eps,St1} - catch - throw:{bad_map,Warning} -> - St = add_warning(L, Warning, St0), - LineAnno = lineno_anno(L, St), - As = [#c_literal{anno=LineAnno,val=badarg}], - {#icall{anno=#a{anno=LineAnno}, %Must have an #a{} - module=#c_literal{anno=LineAnno,val=erlang}, - name=#c_literal{anno=LineAnno,val=error}, - args=As},[],St} - end; + map_build_pair_chain(#c_literal{val=#{}},Es0,lineno_anno(L,St0),St0); expr({map,L,M0,Es0}, St0) -> try expr_map(M0,Es0,lineno_anno(L, St0),St0) of {_,_,_}=Res -> Res @@ -562,26 +568,26 @@ expr({block,_,Es0}, St0) -> {E1,Eps,St2} = expr(last(Es0), St1), {E1,Es1 ++ Eps,St2}; expr({'if',L,Cs0}, St0) -> - {Cs1,St1} = clauses(Cs0, St0), + {Cs1,Ceps,St1} = clauses(Cs0, St0), Lanno = lineno_anno(L, St1), Fc = fail_clause([], Lanno, #c_literal{val=if_clause}), - {#icase{anno=#a{anno=Lanno},args=[],clauses=Cs1,fc=Fc},[],St1}; + {#icase{anno=#a{anno=Lanno},args=[],clauses=Cs1,fc=Fc},Ceps,St1}; expr({'case',L,E0,Cs0}, St0) -> {E1,Eps,St1} = novars(E0, St0), - {Cs1,St2} = clauses(Cs0, St1), + {Cs1,Ceps,St2} = clauses(Cs0, St1), {Fpat,St3} = new_var(St2), Lanno = lineno_anno(L, St2), Fc = fail_clause([Fpat], Lanno, c_tuple([#c_literal{val=case_clause},Fpat])), - {#icase{anno=#a{anno=Lanno},args=[E1],clauses=Cs1,fc=Fc},Eps,St3}; + {#icase{anno=#a{anno=Lanno},args=[E1],clauses=Cs1,fc=Fc},Eps++Ceps,St3}; expr({'receive',L,Cs0}, St0) -> - {Cs1,St1} = clauses(Cs0, St0), - {#ireceive1{anno=#a{anno=lineno_anno(L, St1)},clauses=Cs1}, [], St1}; + {Cs1,Ceps,St1} = clauses(Cs0, St0), + {#ireceive1{anno=#a{anno=lineno_anno(L, St1)},clauses=Cs1},Ceps, St1}; expr({'receive',L,Cs0,Te0,Tes0}, St0) -> {Te1,Teps,St1} = novars(Te0, St0), {Tes1,St2} = exprs(Tes0, St1), - {Cs1,St3} = clauses(Cs0, St2), + {Cs1,Ceps,St3} = clauses(Cs0, St2), {#ireceive2{anno=#a{anno=lineno_anno(L, St3)}, - clauses=Cs1,timeout=Te1,action=Tes1},Teps,St3}; + clauses=Cs1,timeout=Te1,action=Tes1},Teps++Ceps,St3}; expr({'try',L,Es0,[],Ecs,[]}, St0) -> %% 'try ... catch ... end' {Es1,St1} = exprs(Es0, St0), @@ -595,7 +601,7 @@ expr({'try',L,Es0,Cs0,Ecs,[]}, St0) -> %% 'try ... of ... catch ... end' {Es1,St1} = exprs(Es0, St0), {V,St2} = new_var(St1), %This name should be arbitrary - {Cs1,St3} = clauses(Cs0, St2), + {Cs1,Ceps,St3} = clauses(Cs0, St2), {Fpat,St4} = new_var(St3), Lanno = lineno_anno(L, St4), Fc = fail_clause([Fpat], Lanno, @@ -604,7 +610,7 @@ expr({'try',L,Es0,Cs0,Ecs,[]}, St0) -> {#itry{anno=#a{anno=lineno_anno(L, St5)},args=Es1, vars=[V],body=[#icase{anno=#a{anno=Lanno},args=[V],clauses=Cs1,fc=Fc}], evars=Evs,handler=Hs}, - [],St5}; + Ceps,St5}; expr({'try',L,Es0,[],[],As0}, St0) -> %% 'try ... after ... end' {Es1,St1} = exprs(Es0, St0), @@ -673,24 +679,24 @@ expr({match,L,P0,E0}, St0) -> {var,_,'_'} -> St0#core{wanted=false}; _ -> St0 end, - {E2,Eps,St2} = novars(E1, St1), + {E2,Eps1,St2} = novars(E1, St1), St3 = St2#core{wanted=St0#core.wanted}, - P2 = try - pattern(P1, St3) + {P2,Eps2,St4} = try + pattern(P1, St3) catch throw:Thrown -> - Thrown + {Thrown,[],St3} end, - {Fpat,St4} = new_var(St3), - Lanno = lineno_anno(L, St4), + {Fpat,St5} = new_var(St4), + Lanno = lineno_anno(L, St5), Fc = fail_clause([Fpat], Lanno, c_tuple([#c_literal{val=badmatch},Fpat])), case P2 of nomatch -> - St = add_warning(L, nomatch, St4), + St = add_warning(L, nomatch, St5), {#icase{anno=#a{anno=Lanno}, - args=[E2],clauses=[],fc=Fc},Eps,St}; + args=[E2],clauses=[],fc=Fc},Eps1++Eps2,St}; Other when not is_atom(Other) -> - {#imatch{anno=#a{anno=Lanno},pat=P2,arg=E2,fc=Fc},Eps,St4} + {#imatch{anno=#a{anno=Lanno},pat=P2,arg=E2,fc=Fc},Eps1++Eps2,St5} end; expr({op,_,'++',{lc,Llc,E,Qs0},More}, St0) -> %% Optimise '++' here because of the list comprehension algorithm. @@ -772,44 +778,77 @@ expr_map(M0,Es0,A,St0) -> Fc = fail_clause([Fpat], A, #c_literal{val=badarg}), {#icase{anno=#a{anno=A},args=[M1],clauses=Cs,fc=Fc},Mps,St3}; {_,_} -> - {Es1,Eps,St2} = map_pair_list(Es0, St1), - {ann_c_map(A,M1,Es1),Mps++Eps,St2} + {M2,Eps,St2} = map_build_pair_chain(M1,Es0,A,St1), + {M2,Mps++Eps,St2} end; false -> throw({bad_map,bad_map}) end. +%% Group continuous literal blocks and single variables, i.e. +%% M0#{ a := 1, b := V1, K1 := V2, K2 := 42} +%% becomes equivalent to +%% M1 = M0#{ a := 1, b := V1 }, +%% M2 = M1#{ K1 := V1 }, +%% M3 = M2#{ K2 := 42 } + +map_build_pair_chain(M,Es,A,St) -> + %% hack, remove iset if only literal + case map_build_pair_chain(M,Es,A,St,[]) of + {_,[#iset{arg=#c_literal{}=Val}],St1} -> {Val,[],St1}; + Normal -> Normal + end. + +map_build_pair_chain(M0,[],_,St,Mps) -> + {M0,Mps,St}; +map_build_pair_chain(M0,Es0,A,St0,Mps) -> + % group continuous literal blocks + % Anno = #a{anno=[compiler_generated]}, + % order is important, we need to reverse the literals + case map_pair_block(Es0,[],[],St0) of + {{CesL,EspL},{[],[]},Es1,St1} -> + {MVar,St2} = new_var(St1), + Pre = [#iset{var=MVar, arg=ann_c_map(A,M0,reverse(CesL))}], + map_build_pair_chain(MVar,Es1,A,St2,Mps++EspL++Pre); + {{[],[]},{CesV,EspV},Es1,St1} -> + {MVar,St2} = new_var(St1), + Pre = [#iset{var=MVar, arg=#c_map{arg=M0,es=CesV, anno=A}}], + map_build_pair_chain(MVar,Es1,A,St2,Mps ++ EspV++Pre); + {{CesL,EspL},{CesV,EspV},Es1,St1} -> + {MVarL,St2} = new_var(St1), + {MVarV,St3} = new_var(St2), + Pre = [#iset{var=MVarL, arg=ann_c_map(A,M0,reverse(CesL))}, + #iset{var=MVarV, arg=#c_map{arg=MVarL,es=CesV,anno=A}}], + map_build_pair_chain(MVarV,Es1,A,St3,Mps++EspL++EspV++Pre) + end. + +map_pair_block([{Op,L,K0,V0}|Es],Ces,Esp,St0) -> + {K,Ep0,St1} = safe(K0, St0), + {V,Ep1,St2} = safe(V0, St1), + A = lineno_anno(L, St2), + Pair0 = map_op_to_c_map_pair(Op), + Pair1 = Pair0#c_map_pair{anno=A,key=K,val=V}, + case cerl:is_literal(K) of + true -> + map_pair_block(Es,[Pair1|Ces],Ep0 ++ Ep1 ++ Esp,St2); + false -> + {{Ces,Esp},{[Pair1],Ep0++Ep1},Es,St2} + end; +map_pair_block([],Ces,Esp,St) -> + {{Ces,Esp},{[],[]},[],St}. + +map_op_to_c_map_pair(map_field_assoc) -> #c_map_pair{op=#c_literal{val=assoc}}; +map_op_to_c_map_pair(map_field_exact) -> #c_map_pair{op=#c_literal{val=exact}}. + is_valid_map_src(#c_literal{val = M}) when is_map(M) -> true; -is_valid_map_src(#c_map{}) -> true; is_valid_map_src(#c_var{}) -> true; is_valid_map_src(_) -> false. -map_pair_list(Es, St) -> - foldr(fun - ({map_field_assoc,L,K0,V0}, {Ces,Esp,St0}) -> - {K,Ep0,St1} = safe(K0, St0), - ok = ensure_valid_map_key(K), - {V,Ep1,St2} = safe(V0, St1), - A = lineno_anno(L, St2), - Pair = #c_map_pair{op=#c_literal{val=assoc},anno=A,key=K,val=V}, - {[Pair|Ces],Ep0 ++ Ep1 ++ Esp,St2}; - ({map_field_exact,L,K0,V0}, {Ces,Esp,St0}) -> - {K,Ep0,St1} = safe(K0, St0), - ok = ensure_valid_map_key(K), - {V,Ep1,St2} = safe(V0, St1), - A = lineno_anno(L, St2), - Pair = #c_map_pair{op=#c_literal{val=exact},anno=A,key=K,val=V}, - {[Pair|Ces],Ep0 ++ Ep1 ++ Esp,St2} - end, {[],[],St}, Es). - -ensure_valid_map_key(#c_literal{}) -> ok; -ensure_valid_map_key(_) -> throw({bad_map,bad_map_key}). - %% try_exception([ExcpClause], St) -> {[ExcpVar],Handler,St}. try_exception(Ecs0, St0) -> %% Note that Tag is not needed for rethrow - it is already in Info. {Evs,St1} = new_vars(3, St0), % Tag, Value, Info - {Ecs1,St2} = clauses(Ecs0, St1), + {Ecs1,Ceps,St2} = clauses(Ecs0, St1), [_,Value,Info] = Evs, Ec = #iclause{anno=#a{anno=[compiler_generated]}, pats=[c_tuple(Evs)],guard=[#c_literal{val=true}], @@ -817,15 +856,15 @@ try_exception(Ecs0, St0) -> name=#c_literal{val=raise}, args=[Info,Value]}]}, Hs = [#icase{anno=#a{},args=[c_tuple(Evs)],clauses=Ecs1,fc=Ec}], - {Evs,Hs,St2}. + {Evs,Ceps++Hs,St2}. try_after(As, St0) -> %% See above. - {Evs,St1} = new_vars(3, St0), % Tag, Value, Info + {Evs,St1} = new_vars(3, St0), % Tag, Value, Info [_,Value,Info] = Evs, - B = As ++ [#iprimop{anno=#a{}, %Must have an #a{} - name=#c_literal{val=raise}, - args=[Info,Value]}], + B = As ++ [#iprimop{anno=#a{}, % Must have an #a{} + name=#c_literal{val=raise}, + args=[Info,Value]}], Ec = #iclause{anno=#a{anno=[compiler_generated]}, pats=[c_tuple(Evs)],guard=[#c_literal{val=true}], body=B}, @@ -959,7 +998,7 @@ bitstr({bin_element,_,E0,Size0,[Type,{unit,Unit}|Flags]}, St0) -> fun_tq({_,_,Name}=Id, Cs0, L, St0, NameInfo) -> Arity = clause_arity(hd(Cs0)), - {Cs1,St1} = clauses(Cs0, St0), + {Cs1,Ceps,St1} = clauses(Cs0, St0), {Args,St2} = new_vars(Arity, St1), {Ps,St3} = new_vars(Arity, St2), %Need new variables here Anno = lineno_anno(L, St3), @@ -967,7 +1006,7 @@ fun_tq({_,_,Name}=Id, Cs0, L, St0, NameInfo) -> Fun = #ifun{anno=#a{anno=Anno}, id=[{id,Id}], %We KNOW! vars=Args,clauses=Cs1,fc=Fc,name=NameInfo}, - {Fun,[],St3}. + {Fun,Ceps,St3}. %% lc_tq(Line, Exp, [Qualifier], Mc, State) -> {LetRec,[PreExp],State}. %% This TQ from Simon PJ pp 127-138. @@ -1134,7 +1173,7 @@ preprocess_quals(Line, [Q|Qs0], St0, Acc) -> {Gen,St} = generator(Line, Q, Gs, St0), preprocess_quals(Line, Qs, St, [Gen|Acc]); false -> - LAnno = #a{anno=lineno_anno(get_anno(Q), St0)}, + LAnno = #a{anno=lineno_anno(get_qual_anno(Q), St0)}, case is_guard_test(Q) of true -> %% When a filter is a guard test, its argument in the @@ -1159,6 +1198,11 @@ is_generator({generate,_,_,_}) -> true; is_generator({b_generate,_,_,_}) -> true; is_generator(_) -> false. +%% Retrieve the annotation from an Erlang AST form. +%% (Use get_anno/1 to retrieve the annotation from Core Erlang forms). + +get_qual_anno(Abstract) -> element(2, Abstract). + %% %% Generators are abstracted as sextuplets: %% - acc_pat is the accumulator pattern, e.g. [Pat|Tail] for Pat <- Expr. @@ -1181,7 +1225,7 @@ is_generator(_) -> false. generator(Line, {generate,Lg,P0,E}, Gs, St0) -> LA = lineno_anno(Line, St0), GA = lineno_anno(Lg, St0), - {Head,St1} = list_gen_pattern(P0, Line, St0), + {Head,Ceps,St1} = list_gen_pattern(P0, Line, St0), {[Tail,Skip],St2} = new_vars(2, St1), {Cg,St3} = lc_guard_tests(Gs, St2), {AccPat,SkipPat} = case Head of @@ -1202,24 +1246,25 @@ generator(Line, {generate,Lg,P0,E}, Gs, St0) -> end, {Ce,Pre,St4} = safe(E, St3), Gen = #igen{anno=#a{anno=GA},acc_pat=AccPat,acc_guard=Cg,skip_pat=SkipPat, - tail=Tail,tail_pat=#c_literal{anno=LA,val=[]},arg={Pre,Ce}}, + tail=Tail,tail_pat=#c_literal{anno=LA,val=[]},arg={Ceps++Pre,Ce}}, {Gen,St4}; generator(Line, {b_generate,Lg,P,E}, Gs, St0) -> LA = lineno_anno(Line, St0), GA = lineno_anno(Lg, St0), - Cp = #c_binary{segments=Segs} = pattern(P, St0), + {Cp = #c_binary{segments=Segs},[],St1} = pattern(P, St0), + %% The function append_tail_segment/2 keeps variable patterns as-is, making %% it possible to have the same skip clause removal as with list generators. - {AccSegs,Tail,TailSeg,St1} = append_tail_segment(Segs, St0), + {AccSegs,Tail,TailSeg,St2} = append_tail_segment(Segs, St1), AccPat = Cp#c_binary{segments=AccSegs}, - {Cg,St2} = lc_guard_tests(Gs, St1), - {SkipSegs,St3} = emasculate_segments(AccSegs, St2), + {Cg,St3} = lc_guard_tests(Gs, St2), + {SkipSegs,St4} = emasculate_segments(AccSegs, St3), SkipPat = Cp#c_binary{segments=SkipSegs}, - {Ce,Pre,St4} = safe(E, St3), + {Ce,Pre,St5} = safe(E, St4), Gen = #igen{anno=#a{anno=GA},acc_pat=AccPat,acc_guard=Cg,skip_pat=SkipPat, tail=Tail,tail_pat=#c_binary{anno=LA,segments=[TailSeg]}, arg={Pre,Ce}}, - {Gen,St4}. + {Gen,St5}. append_tail_segment(Segs, St0) -> {Var,St} = new_var(St0), @@ -1248,9 +1293,9 @@ lc_guard_tests(Gs0, St0) -> list_gen_pattern(P0, Line, St) -> try - {pattern(P0, St),St} + pattern(P0,St) catch - nomatch -> {nomatch,add_warning(Line, nomatch, St)} + nomatch -> {nomatch,[],add_warning(Line, nomatch, St)} end. %%% @@ -1473,6 +1518,18 @@ force_novars(#ibinary{}=Bin, St) -> {Bin,[],St}; force_novars(Ce, St) -> force_safe(Ce, St). + +%% safe_pattern_expr(Expr, State) -> {Cexpr,[PreExpr],State}. +%% only literals and variables are safe expressions in patterns +safe_pattern_expr(E,St0) -> + case safe(E,St0) of + {#c_var{},_,_}=Safe -> Safe; + {#c_literal{},_,_}=Safe -> Safe; + {Ce,Eps,St1} -> + {V,St2} = new_var(St1), + {V,Eps++[#iset{var=V,arg=Ce}],St2} + end. + %% safe(Expr, State) -> {Safe,[PreExpr],State}. %% Generate an internal safe expression. These are simples without %% binaries which can fail. At this level we do not need to do a @@ -1547,84 +1604,109 @@ fold_match({match,L,P0,E0}, P) -> {{match,L,P0,P1},E1}; fold_match(E, P) -> {P,E}. -%% pattern(Pattern, State) -> CorePat. +%% pattern(Pattern, State) -> {CorePat,[PreExp],State}. %% Transform a pattern by removing line numbers. We also normalise %% aliases in patterns to standard form, {alias,Pat,[Var]}. - -pattern({var,L,V}, St) -> #c_var{anno=lineno_anno(L, St),name=V}; -pattern({char,L,C}, St) -> #c_literal{anno=lineno_anno(L, St),val=C}; -pattern({integer,L,I}, St) -> #c_literal{anno=lineno_anno(L, St),val=I}; -pattern({float,L,F}, St) -> #c_literal{anno=lineno_anno(L, St),val=F}; -pattern({atom,L,A}, St) -> #c_literal{anno=lineno_anno(L, St),val=A}; -pattern({string,L,S}, St) -> #c_literal{anno=lineno_anno(L, St),val=S}; -pattern({nil,L}, St) -> #c_literal{anno=lineno_anno(L, St),val=[]}; +%% +%% In patterns we may have expressions +%% 1) Binaries -> #c_bitstr{size=Expr} +%% 2) Maps -> #c_map_pair{key=Expr} +%% +%% Both of these may generate pre-expressions since only bound variables +%% or literals are allowed for these in core patterns. +%% +%% Therefor, we need to drag both the state and the collection of pre-expression +%% around in the whole pattern transformation tree. + +pattern({var,L,V}, St) -> {#c_var{anno=lineno_anno(L, St),name=V},[],St}; +pattern({char,L,C}, St) -> {#c_literal{anno=lineno_anno(L, St),val=C},[],St}; +pattern({integer,L,I}, St) -> {#c_literal{anno=lineno_anno(L, St),val=I},[],St}; +pattern({float,L,F}, St) -> {#c_literal{anno=lineno_anno(L, St),val=F},[],St}; +pattern({atom,L,A}, St) -> {#c_literal{anno=lineno_anno(L, St),val=A},[],St}; +pattern({string,L,S}, St) -> {#c_literal{anno=lineno_anno(L, St),val=S},[],St}; +pattern({nil,L}, St) -> {#c_literal{anno=lineno_anno(L, St),val=[]},[],St}; pattern({cons,L,H,T}, St) -> - annotate_cons(lineno_anno(L, St), pattern(H, St), pattern(T, St), St); + {Ph,Eps1,St1} = pattern(H, St), + {Pt,Eps2,St2} = pattern(T, St1), + {annotate_cons(lineno_anno(L, St), Ph, Pt, St2),Eps1++Eps2,St2}; pattern({tuple,L,Ps}, St) -> - annotate_tuple(record_anno(L, St), pattern_list(Ps, St), St); -pattern({map,L,Ps}, St) -> - #c_map{anno=lineno_anno(L, St), es=pattern_map_pairs(Ps, St)}; + {Ps1,Eps,St1} = pattern_list(Ps,St), + {annotate_tuple(record_anno(L, St), Ps1, St),Eps,St1}; +pattern({map,L,Pairs}, St0) -> + {Ps,Eps,St1} = pattern_map_pairs(Pairs, St0), + {#c_map{anno=lineno_anno(L, St1), es=Ps},Eps,St1}; pattern({bin,L,Ps}, St) -> %% We don't create a #ibinary record here, since there is %% no need to hold any used/new annotations in a pattern. - #c_binary{anno=lineno_anno(L, St),segments=pat_bin(Ps, St)}; + {#c_binary{anno=lineno_anno(L, St),segments=pat_bin(Ps, St)},[],St}; pattern({match,_,P1,P2}, St) -> - pat_alias(pattern(P1, St), pattern(P2, St)). + {Cp1,Eps1,St1} = pattern(P1,St), + {Cp2,Eps2,St2} = pattern(P2,St1), + {pat_alias(Cp1,Cp2),Eps1++Eps2,St2}. %% pattern_map_pairs([MapFieldExact],State) -> [#c_map_pairs{}] pattern_map_pairs(Ps, St) -> - %% check literal key uniqueness (dict is needed) - %% pattern all pairs - {CMapPairs, Kdb} = lists:mapfoldl(fun - (P,Kdbi) -> - #c_map_pair{key=Ck,val=Cv} = CMapPair = pattern_map_pair(P,St), - K = core_lib:literal_value(Ck), - case dict:find(K,Kdbi) of - {ok, Vs} -> - {CMapPair, dict:store(K,[Cv|Vs],Kdbi)}; - _ -> - {CMapPair, dict:store(K,[Cv],Kdbi)} + %% check literal key uniqueness + %% - guaranteed via aliasing map pairs + %% pattern all pairs in two steps + %% 1) Construct Core Pattern + %% 2) Alias Keys in Core Pattern + {CMapPairs, {Eps,St1}} = lists:mapfoldl(fun + (P,{EpsM,Sti0}) -> + {CMapPair,EpsP,Sti1} = pattern_map_pair(P,Sti0), + {CMapPair, {EpsM++EpsP,Sti1}} + end, {[],St}, Ps), + {pat_alias_map_pairs(CMapPairs,[]),Eps,St1}. + +%% remove cluddering annotations +pattern_map_clean_key(#c_literal{val=V}) -> {literal,V}; +pattern_map_clean_key(#c_var{name=V}) -> {var,V}. + +pat_alias_map_pairs(Ps1,Ps2) -> + Ps = Ps1 ++ Ps2, + F = fun(#c_map_pair{key=Ck,val=Cv},Dbi) -> + K = pattern_map_clean_key(Ck), + case dict:find(K,Dbi) of + {ok,Cvs} -> dict:store(K,[Cv|Cvs],Dbi); + _ -> dict:store(K,[Cv],Dbi) end - end, dict:new(), Ps), - pattern_alias_map_pairs(CMapPairs,Kdb,dict:new(),St). - -pattern_alias_map_pairs([],_,_,_) -> []; -pattern_alias_map_pairs([#c_map_pair{key=Ck}=Pair|Pairs],Kdb,Kset,St) -> - %% alias same keys if needed - K = core_lib:literal_value(Ck), - case dict:find(K,Kset) of - {ok,processed} -> - pattern_alias_map_pairs(Pairs,Kdb,Kset,St); - _ -> + end, + Kdb = lists:foldl(F,dict:new(),Ps), + pat_alias_map_pairs(Ps,Kdb,sets:new()). + +pat_alias_map_pairs([],_,_) -> []; +pat_alias_map_pairs([#c_map_pair{key=Ck}=Pair|Pairs],Kdb,Set) -> + K = pattern_map_clean_key(Ck), + case sets:is_element(K,Set) of + true -> + pat_alias_map_pairs(Pairs,Kdb,Set); + false -> Cvs = dict:fetch(K,Kdb), - Cv = pattern_alias_map_pair_patterns(Cvs), - Kset1 = dict:store(K, processed, Kset), - [Pair#c_map_pair{val=Cv}|pattern_alias_map_pairs(Pairs,Kdb,Kset1,St)] + Cv = pat_alias_map_pair_values(Cvs), + Set1 = sets:add_element(K,Set), + [Pair#c_map_pair{val=Cv}|pat_alias_map_pairs(Pairs,Kdb,Set1)] end. -pattern_alias_map_pair_patterns([Cv]) -> Cv; -pattern_alias_map_pair_patterns([Cv1,Cv2|Cvs]) -> - pattern_alias_map_pair_patterns([pat_alias(Cv1,Cv2)|Cvs]). - -pattern_map_pair({map_field_exact,L,K,V}, St) -> - case expr(K,St) of - {#c_literal{}=Key,_,_} -> - #c_map_pair{anno=lineno_anno(L, St), - op=#c_literal{val=exact}, - key=Key, - val=pattern(V, St)}; - _ -> - %% this will throw a cryptic error message - %% but it is better than nothing - throw(nomatch) - end. +pat_alias_map_pair_values([Cv]) -> Cv; +pat_alias_map_pair_values([Cv1,Cv2|Cvs]) -> + pat_alias_map_pair_values([pat_alias(Cv1,Cv2)|Cvs]). + +pattern_map_pair({map_field_exact,L,K,V}, St0) -> + {Ck,EpsK,St1} = safe_pattern_expr(K,St0), + {Cv,EpsV,St2} = pattern(V, St1), + {#c_map_pair{anno=lineno_anno(L,St2), + op=#c_literal{val=exact}, + key=Ck, + val=Cv},EpsK++EpsV,St2}. %% pat_bin([BinElement], State) -> [BinSeg]. pat_bin(Ps, St) -> [pat_segment(P, St) || P <- Ps]. -pat_segment({bin_element,_,Term,Size,[Type,{unit,Unit}|Flags]}, St) -> - #c_bitstr{val=pattern(Term, St),size=pattern(Size, St), +pat_segment({bin_element,_,Val,Size,[Type,{unit,Unit}|Flags]}, St) -> + {Pval,[],St1} = pattern(Val,St), + {Psize,[],_St2} = pattern(Size,St1), + #c_bitstr{val=Pval,size=Psize, unit=#c_literal{val=Unit}, type=#c_literal{val=Type}, flags=#c_literal{val=Flags}}. @@ -1634,6 +1716,8 @@ pat_segment({bin_element,_,Term,Size,[Type,{unit,Unit}|Flags]}, St) -> pat_alias(#c_var{name=V1}, P2) -> #c_alias{var=#c_var{name=V1},pat=P2}; pat_alias(P1, #c_var{name=V2}) -> #c_alias{var=#c_var{name=V2},pat=P1}; + +%% alias cons pat_alias(#c_cons{}=Cons, #c_literal{anno=A,val=[H|T]}=S) -> pat_alias(Cons, ann_c_cons_skel(A, #c_literal{anno=A,val=H}, S#c_literal{val=T})); @@ -1642,6 +1726,8 @@ pat_alias(#c_literal{anno=A,val=[H|T]}=S, #c_cons{}=Cons) -> S#c_literal{val=T}), Cons); pat_alias(#c_cons{anno=Anno,hd=H1,tl=T1}, #c_cons{hd=H2,tl=T2}) -> ann_c_cons(Anno, pat_alias(H1, H2), pat_alias(T1, T2)); + +%% alias tuples pat_alias(#c_tuple{anno=Anno,es=Es1}, #c_literal{val=T}) when is_tuple(T) -> Es2 = [#c_literal{val=E} || E <- tuple_to_list(T)], ann_c_tuple(Anno, pat_alias_list(Es1, Es2)); @@ -1650,6 +1736,12 @@ pat_alias(#c_literal{anno=Anno,val=T}, #c_tuple{es=Es2}) when is_tuple(T) -> ann_c_tuple(Anno, pat_alias_list(Es1, Es2)); pat_alias(#c_tuple{anno=Anno,es=Es1}, #c_tuple{es=Es2}) -> ann_c_tuple(Anno, pat_alias_list(Es1, Es2)); + +%% alias maps +%% There are no literals in maps patterns (patterns are always abstract) +pat_alias(#c_map{es=Es1}=M,#c_map{es=Es2}) -> + M#c_map{es=pat_alias_map_pairs(Es1,Es2)}; + pat_alias(#c_alias{var=V1,pat=P1}, #c_alias{var=V2,pat=P2}) -> if V1 =:= V2 -> #c_alias{var=V1,pat=pat_alias(P1, P2)}; @@ -1672,9 +1764,15 @@ pat_alias_list([A1|A1s], [A2|A2s]) -> pat_alias_list([], []) -> []; pat_alias_list(_, _) -> throw(nomatch). -%% pattern_list([P], State) -> [P]. +%% pattern_list([P], State) -> {[P],Exprs,St} + +pattern_list([P0|Ps0], St0) -> + {P1,Eps,St1} = pattern(P0, St0), + {Ps1,Epsl,St2} = pattern_list(Ps0, St1), + {[P1|Ps1], Eps ++ Epsl, St2}; +pattern_list([], St) -> + {[],[],St}. -pattern_list(Ps, St) -> [pattern(P, St) || P <- Ps]. %% make_vars([Name]) -> [{Var,Name}]. @@ -1974,9 +2072,14 @@ upattern(#c_tuple{es=Es0}=Tuple, Ks, St0) -> upattern(#c_map{es=Es0}=Map, Ks, St0) -> {Es1,Esg,Esv,Eus,St1} = upattern_list(Es0, Ks, St0), {Map#c_map{es=Es1},Esg,Esv,Eus,St1}; -upattern(#c_map_pair{op=#c_literal{val=exact},val=V0}=MapPair, Ks, St0) -> - {V,Vg,Vv,Vu,St1} = upattern(V0, Ks, St0), - {MapPair#c_map_pair{val=V},Vg,Vv,Vu,St1}; +upattern(#c_map_pair{op=#c_literal{val=exact},key=K0,val=V0}=Pair,Ks,St0) -> + {V,Vg,Vn,Vu,St1} = upattern(V0, Ks, St0), + % A variable key must be considered used here + Ku = case K0 of + #c_var{name=Name} -> [Name]; + _ -> [] + end, + {Pair#c_map_pair{val=V},Vg,Vn,union(Ku,Vu),St1}; upattern(#c_binary{segments=Es0}=Bin, Ks, St0) -> {Es1,Esg,Esv,Eus,St1} = upat_bin(Es0, Ks, St0), {Bin#c_binary{segments=Es1},Esg,Esv,Eus,St1}; @@ -2347,8 +2450,6 @@ format_error(nomatch) -> "pattern cannot possibly match"; format_error(bad_binary) -> "binary construction will fail because of a type mismatch"; -format_error(bad_map_key) -> - "map construction will fail because of none literal key (large binaries are not literals)"; format_error(bad_map) -> "map construction will fail because of a type mismatch". diff --git a/lib/compiler/src/v3_kernel.erl b/lib/compiler/src/v3_kernel.erl index 40d2f72b4c..6504351c02 100644 --- a/lib/compiler/src/v3_kernel.erl +++ b/lib/compiler/src/v3_kernel.erl @@ -527,9 +527,9 @@ map_split_pairs(A, Var, Ces, Sub, St0) -> Pairs0 = [{Op,K,V} || #c_map_pair{op=#c_literal{val=Op},key=K,val=V} <- Ces], {Pairs,Esp,St1} = foldr(fun ({Op,K0,V0}, {Ops,Espi,Sti0}) when Op =:= assoc; Op =:= exact -> - {K,[],Sti1} = expr(K0, Sub, Sti0), - {V,Ep,Sti2} = atomic(V0, Sub, Sti1), - {[{Op,K,V}|Ops],Ep ++ Espi,Sti2} + {K,Eps1,Sti1} = atomic(K0, Sub, Sti0), + {V,Eps2,Sti2} = atomic(V0, Sub, Sti1), + {[{Op,K,V}|Ops],Eps1 ++ Eps2 ++ Espi,Sti2} end, {[],[],St0}, Pairs0), case map_group_pairs(Pairs) of @@ -577,11 +577,12 @@ map_key_is_used(K,Used) -> dict:find(map_key_clean(K),Used). %% Be explicit instead of using set_kanno(K,[]) -map_key_clean(#k_literal{val=V}) -> {k_literal,V}; -map_key_clean(#k_int{val=V}) -> {k_int,V}; -map_key_clean(#k_float{val=V}) -> {k_float,V}; -map_key_clean(#k_atom{val=V}) -> {k_atom,V}; -map_key_clean(#k_nil{}) -> k_nil. +map_key_clean(#k_var{name=V}) -> {var,V}; +map_key_clean(#k_literal{val=V}) -> {lit,V}; +map_key_clean(#k_int{val=V}) -> {lit,V}; +map_key_clean(#k_float{val=V}) -> {lit,V}; +map_key_clean(#k_atom{val=V}) -> {lit,V}; +map_key_clean(#k_nil{}) -> {lit,[]}. %% call_type(Module, Function, Arity) -> call | bif | apply | error. @@ -757,23 +758,22 @@ flatten_alias(#c_alias{var=V,pat=P}) -> flatten_alias(Pat) -> {[],Pat}. pattern_map_pairs(Ces0, Isub, Osub0, St0) -> - %% It is assumed that all core keys are literals - %% It is later assumed that these keys are term sorted - %% so we need to sort them here - Ces1 = lists:sort(fun - (#c_map_pair{key=CkA},#c_map_pair{key=CkB}) -> - A = core_lib:literal_value(CkA), - B = core_lib:literal_value(CkB), - erts_internal:cmp_term(A,B) < 0 - end, Ces0), %% pattern the pair keys and values as normal {Kes,{Osub1,St1}} = lists:mapfoldl(fun (#c_map_pair{anno=A,key=Ck,val=Cv},{Osubi0,Sti0}) -> - {Kk,Osubi1,Sti1} = pattern(Ck, Isub, Osubi0, Sti0), - {Kv,Osubi2,Sti2} = pattern(Cv, Isub, Osubi1, Sti1), + {Kk,[],Sti1} = expr(Ck, Isub, Sti0), + {Kv,Osubi2,Sti2} = pattern(Cv, Isub, Osubi0, Sti1), {#k_map_pair{anno=A,key=Kk,val=Kv},{Osubi2,Sti2}} - end, {Osub0, St0}, Ces1), - {Kes,Osub1,St1}. + end, {Osub0, St0}, Ces0), + %% It is later assumed that these keys are term sorted + %% so we need to sort them here + Kes1 = lists:sort(fun + (#k_map_pair{key=KkA},#k_map_pair{key=KkB}) -> + A = map_key_clean(KkA), + B = map_key_clean(KkB), + erts_internal:cmp_term(A,B) < 0 + end, Kes), + {Kes1,Osub1,St1}. pattern_bin(Es, Isub, Osub0, St0) -> {Kbin,{_,Osub},St} = pattern_bin_1(Es, Isub, Osub0, St0), @@ -1550,13 +1550,11 @@ arg_val(Arg, C) -> {set_kanno(S, []),U,T,Fs} end; #k_map{op=exact,es=Es} -> - Keys = [begin - #k_map_pair{key=#k_literal{val=Key}} = Pair, - Key - end || Pair <- Es], - %% multiple keys may have the same name - %% do not use ordsets - lists:sort(fun(A,B) -> erts_internal:cmp_term(A,B) < 0 end, Keys) + lists:sort(fun(A,B) -> + %% on the form K :: {'lit' | 'var', term()} + %% lit < var as intended + erts_internal:cmp_term(A,B) < 0 + end, [map_key_clean(Key) || #k_map_pair{key=Key} <- Es]) end. %% ubody_used_vars(Expr, State) -> [UsedVar] @@ -1943,6 +1941,7 @@ lit_list_vars(Ps) -> %% pat_vars(Pattern) -> {[UsedVarName],[NewVarName]}. %% Return variables in a pattern. All variables are new variables %% except those in the size field of binary segments. +%% and map_pair keys pat_vars(#k_var{name=N}) -> {[],[N]}; %%pat_vars(#k_char{}) -> {[],[]}; @@ -1967,8 +1966,10 @@ pat_vars(#k_tuple{es=Es}) -> pat_list_vars(Es); pat_vars(#k_map{es=Es}) -> pat_list_vars(Es); -pat_vars(#k_map_pair{val=V}) -> - pat_vars(V). +pat_vars(#k_map_pair{key=K,val=V}) -> + {U1,New} = pat_vars(V), + {[], U2} = pat_vars(K), + {union(U1,U2),New}. pat_list_vars(Ps) -> foldl(fun (P, {Used0,New0}) -> diff --git a/lib/compiler/src/v3_kernel.hrl b/lib/compiler/src/v3_kernel.hrl index ab66445f73..b008285d9f 100644 --- a/lib/compiler/src/v3_kernel.hrl +++ b/lib/compiler/src/v3_kernel.hrl @@ -38,7 +38,7 @@ -record(k_nil, {anno=[]}). -record(k_tuple, {anno=[],es}). --record(k_map, {anno=[],var,op,es}). +-record(k_map, {anno=[],var=#k_literal{val=#{}},op,es}). -record(k_map_pair, {anno=[],key,val}). -record(k_cons, {anno=[],hd,tl}). -record(k_binary, {anno=[],segs}). diff --git a/lib/compiler/test/Makefile b/lib/compiler/test/Makefile index 0b56a49cd6..892a401c75 100644 --- a/lib/compiler/test/Makefile +++ b/lib/compiler/test/Makefile @@ -108,7 +108,7 @@ RELSYSDIR = $(RELEASE_PATH)/compiler_test # ---------------------------------------------------- ERL_MAKE_FLAGS += -ERL_COMPILE_FLAGS += -I$(ERL_TOP)/lib/test_server/include +clint +ERL_COMPILE_FLAGS += -I$(ERL_TOP)/lib/test_server/include +clint +clint0 EBIN = . diff --git a/lib/compiler/test/compilation_SUITE.erl b/lib/compiler/test/compilation_SUITE.erl index f7b1dbdddf..8711f35e8e 100644 --- a/lib/compiler/test/compilation_SUITE.erl +++ b/lib/compiler/test/compilation_SUITE.erl @@ -436,7 +436,7 @@ self_compile_1(Config, Prefix, Opts) -> %% Compile the compiler. (In this node to get better coverage.) ?line CompA = make_compiler_dir(Priv, Prefix++"compiler_a"), ?line VsnA = Version ++ ".0", - ?line compile_compiler(compiler_src(), CompA, VsnA, [clint|Opts]), + compile_compiler(compiler_src(), CompA, VsnA, [clint0,clint|Opts]), %% Compile the compiler again using the newly compiled compiler. %% (In another node because reloading the compiler would disturb cover.) diff --git a/lib/compiler/test/compile_SUITE.erl b/lib/compiler/test/compile_SUITE.erl index 8cb7d1b55b..128291dc67 100644 --- a/lib/compiler/test/compile_SUITE.erl +++ b/lib/compiler/test/compile_SUITE.erl @@ -365,7 +365,7 @@ listings_big(Config) when is_list(Config) -> ?line do_listing(Big, TargetDir, dkern, ".kernel"), ?line Target = filename:join(TargetDir, big), - ?line {ok,big} = compile:file(Target, [asm,{outdir,TargetDir}]), + {ok,big} = compile:file(Target, [from_asm,{outdir,TargetDir}]), %% Cleanup. ?line ok = file:delete(Target ++ ".beam"), diff --git a/lib/compiler/test/error_SUITE.erl b/lib/compiler/test/error_SUITE.erl index bd877bb528..0d23f12fb5 100644 --- a/lib/compiler/test/error_SUITE.erl +++ b/lib/compiler/test/error_SUITE.erl @@ -23,7 +23,7 @@ -export([all/0, suite/0,groups/0,init_per_suite/1, end_per_suite/1, init_per_group/2,end_per_group/2, head_mismatch_line/1,warnings_as_errors/1, bif_clashes/1, - transforms/1,forbidden_maps/1,bad_utf8/1]). + transforms/1,maps_warnings/1,bad_utf8/1]). %% Used by transforms/1 test case. -export([parse_transform/2]). @@ -37,7 +37,7 @@ all() -> groups() -> [{p,test_lib:parallel(), [head_mismatch_line,warnings_as_errors,bif_clashes, - transforms,forbidden_maps,bad_utf8]}]. + transforms,maps_warnings,bad_utf8]}]. init_per_suite(Config) -> Config. @@ -241,17 +241,30 @@ parse_transform(_, _) -> error(too_bad). -forbidden_maps(Config) when is_list(Config) -> - Ts1 = [{map_illegal_use_of_pattern, +maps_warnings(Config) when is_list(Config) -> + Ts1 = [{map_ok_use_of_pattern, <<" - -export([t/0]). + -export([t/1]). + t(K) -> + #{K := 1 = V} = id(#{<<\"hi all\">> => 1}), + V. + id(I) -> I. + ">>, + [return], + []}, + {map_illegal_use_of_pattern, + <<" + -export([t/0,t/2]). + t(K,#{ K := V }) -> V. t() -> V = 32, #{<<\"hi\",V,\"all\">> := 1} = id(#{<<\"hi all\">> => 1}). id(I) -> I. ">>, [return], - {error,[{5,erl_lint,{illegal_map_key_variable,'V'}}], []}}], + {error,[{3,erl_lint,{unbound_var,'K'}}, + {6,erl_lint,illegal_map_key}],[]}} + ], [] = run2(Config, Ts1), ok. diff --git a/lib/compiler/test/map_SUITE.erl b/lib/compiler/test/map_SUITE.erl index 403b7e8405..75efce9d7b 100644 --- a/lib/compiler/test/map_SUITE.erl +++ b/lib/compiler/test/map_SUITE.erl @@ -21,6 +21,7 @@ ]). -export([ + %% literals t_build_and_match_literals/1, t_update_literals/1,t_match_and_update_literals/1, t_update_map_expressions/1, @@ -32,6 +33,15 @@ t_map_size/1, t_build_and_match_aliasing/1, + %% variables + t_build_and_match_variables/1, + t_update_assoc_variables/1,t_update_exact_variables/1, + t_nested_pattern_expressions/1, + t_guard_update_variables/1, + t_guard_sequence_variables/1, + t_guard_sequence_mixed/1, + t_frequency_table/1, + %% warnings t_warn_useless_build/1, t_warn_pair_key_overloaded/1, @@ -52,6 +62,7 @@ suite() -> []. all() -> [ + %% literals t_build_and_match_literals, t_update_literals, t_match_and_update_literals, t_update_map_expressions, @@ -62,6 +73,15 @@ all() -> [ t_map_size, t_build_and_match_aliasing, + %% variables + t_build_and_match_variables, + t_update_assoc_variables,t_update_exact_variables, + t_nested_pattern_expressions, + t_guard_update_variables, + t_guard_sequence_variables, + t_guard_sequence_mixed, + t_frequency_table, + %% warnings t_warn_useless_build, t_warn_pair_key_overloaded, @@ -73,6 +93,7 @@ all() -> [ t_build_and_match_nil, t_build_and_match_structure, + %% errors in 17.0-rc1 t_update_values, t_expand_map_update, @@ -119,6 +140,11 @@ t_build_and_match_literals(Config) when is_list(Config) -> %% nil key #{[]:=ok,1:=2} = id(#{[]=>ok,1=>2}), + #{1:=2,[]:=ok,1:=2} = id(#{[]=>ok,1=>2}), + + %% pseudo literals + #{ -3 := yep } = id(#{ -3 => yep }), + #{ <<0:358>> := "three" } = id(#{<<0:358>> =>"three"}), %% error case {'EXIT',{{badmatch,_},_}} = (catch (#{x:=3,x:=2} = id(#{x=>3}))), @@ -126,10 +152,10 @@ t_build_and_match_literals(Config) when is_list(Config) -> {'EXIT',{{badmatch,_},_}} = (catch (#{x:=3} = id({a,b,c}))), {'EXIT',{{badmatch,_},_}} = (catch (#{x:=3} = id(#{y=>3}))), {'EXIT',{{badmatch,_},_}} = (catch (#{x:=3} = id(#{x=>"three"}))), - {'EXIT',{badarg,_}} = (catch id(#{<<0:258>> =>"three"})), {'EXIT',{{badmatch,_},_}} = (catch (#{#{"a"=>42} := 3}=id(#{#{"a"=>3}=>42}))), ok. + t_build_and_match_aliasing(Config) when is_list(Config) -> M1 = id(#{a=>1,b=>2,c=>3,d=>4}), #{c:=C1=_=_=C2} = M1, @@ -143,6 +169,19 @@ t_build_and_match_aliasing(Config) when is_list(Config) -> M2 = id(#{"a"=>1,"b"=>2,"c"=>3,"d"=>4}), #{"a":=A2,"a":=A2,"a":=A2,"b":=B2,"b":=B2,"b":=2} = M2, #{"a":=_,"a":=_,"a":=_,"b":=_,"b":=_,"b":=2} = M2, + + #{a:=A1,a:=A1,a:=A1,b:=B1,b:=B1} = #{a:=A1,a:=A1,a:=A1,b:=B1,b:=B1,b:=2} = M1, + #{"a":=A3,"b":=B3} = #{"a":=A3,"a":=A3} = #{"b":=B3,"b":=2} = M2, + + #{"a":=1,"b":=2,"c":=3,"d":=4} = #{"a":=A4,"b":=B4} = #{"a":=A4,"a":=A4} = #{"b":=B4,"d":=4} = M2, + #{"a":=A5,"b":=B5} = #{"a":=A5,"a":=A5} = #{"b":=B5,"d":=4} = #{"a":=1,"b":=2,"c":=3,"d":=4} = M2, + #{"a":=_,"b":=_} = #{"a":=_,"a":=_} = #{"b":=_,"d":=4} = #{"a":=1,"b":=2,"c":=3,"d":=4} = M2, + + M3 = id(#{<<12:300>>=>1,<<13:300>>=>2}), + #{<<12:300>> := V1, <<13:300>> := V2} = #{<<13:300>> := V2, <<12:300>> := V1} = M3, + #{<<12:300>> := 1, <<13:300>> := 2} = #{<<13:300>> := _, <<12:300>> := _} = M3, + #{<<13:300>> := _, <<12:300>> := _} = #{<<12:300>> := 1, <<13:300>> := 2} = M3, + ok. t_map_size(Config) when is_list(Config) -> @@ -241,11 +280,14 @@ t_update_assoc(Config) when is_list(Config) -> #{1:=a,2:=b,3.0:=new,4:=d,5:=e} = M2, M2 = M0#{3.0:=wrong,3.0=>new}, + % Can't handle directly yet + Bin = <<0:257>>, + #{ Bin := val } = id(M0#{<<0:257>> => val}), %% binary limitation + %% Errors cases. BadMap = id(badmap), {'EXIT',{badarg,_}} = (catch BadMap#{nonexisting=>val}), {'EXIT',{badarg,_}} = (catch <<>>#{nonexisting=>val}), - {'EXIT',{badarg,_}} = (catch M0#{<<0:257>> => val}), %% limitation ok. t_update_exact(Config) when is_list(Config) -> @@ -281,8 +323,10 @@ t_update_values(Config) when is_list(Config) -> V0 = id(1337), M0 = #{ a => 1, val => V0}, V1 = get_val(M0), - M1 = M0#{ val := [V0,V1], "wazzup" => 42 }, + M1 = id(M0#{ val := [V0,V1], "wazzup" => 42 }), [1337, {some_val, 1337}] = get_val(M1), + M2 = id(M1#{ <<42:333>> => 1337 }), + {bin_key,1337} = get_val(M2), N = 110, List = [{[I,1,2,3,I],{1,2,3,"wat",I}}|| I <- lists:seq(1,N)], @@ -308,6 +352,7 @@ t_export(Config) when is_list(Config) -> check_val(#{val1:=V1, val2:=V2},V1,V2) -> ok. +get_val(#{ <<42:333>> := V }) -> {bin_key, V}; get_val(#{ "wazzup" := _, val := V}) -> V; get_val(#{ val := V }) -> {some_val, V}. @@ -437,7 +482,10 @@ guard_receive_loop() -> t_list_comprehension(Config) when is_list(Config) -> - [#{k:=1},#{k:=2},#{k:=3}] = [#{k=>I} || I <- [1,2,3]], + [#{k:=1},#{k:=2},#{k:=3}] = id([#{k=>I} || I <- [1,2,3]]), + Ls = id([#{<<2:301>> => I, "wat" => I + 1} || I <- [1,2,3]]), + [#{<<2:301>>:=1,"wat":=2},#{<<2:301>>:=2,"wat":=3},#{<<2:301>>:=3,"wat":=4}] = Ls, + [{1,2},{2,3},{3,4}] = id([{I2,I1} || #{"wat" := I1, <<2:301>> := I2} <- Ls]), ok. t_guard_fun(Config) when is_list(Config) -> @@ -601,5 +649,325 @@ t_build_and_match_structure(Config) when is_list(Config) -> end, ok. +%% simple build and match variables +t_build_and_match_variables(Config) when is_list(Config) -> + K0 = id(#{}), + K1 = id(1), V1 = id(a), + K2 = id(2), V2 = id(b), + K3 = id(3), V3 = id("c"), + K4 = id("4"), V4 = id("d"), + K5 = id(<<"5">>), V5 = id(<<"e">>), + K6 = id({"6",7}), V6 = id("f"), + K7 = id(#{ "a" => 3 }), + #{K1:=V1} = id(#{K1=>V1}), + #{K1:=V1,K2:=V2} = id(#{K1=>V1,K2=>V2}), + #{K1:=V1,K2:=V2,K3:=V3} = id(#{K1=>V1,K2=>V2,K3=>V3}), + #{K1:=V1,K2:=V2,K3:=V3,K4:=V4} = id(#{K1=>V1,K2=>V2,K3=>V3,K4=>V4}), + #{K1:=V1,K2:=V2,K3:=V3,K4:=V4,K5:=V5} = id(#{K1=>V1,K2=>V2,K3=>V3,K4=>V4,K5=>V5}), + #{K1:=V1,K2:=V2,K3:=V3,K4:=V4,K5:=V5,K6:=V6} = id(#{K1=>V1,K2=>V2,K3=>V3,K4=>V4,K5=>V5,K6=>V6}), + + #{K5:=X,K5:=X=3,K4:=4} = id(#{K5=>3,K4=>4}), + #{K5:=X,<<"5">>:=X=3,K4:=4} = id(#{K5=>3,K4=>4}), + #{K5:=X,<<"5">>:=X=3,K4:=4} = id(#{<<"5">>=>3,K4=>4}), + + #{ K4:=#{ K3:=#{K1:=V1, K2:=V2}}, K5:=V5} = + id(#{ K5=>V5, K4=>#{ K3=>#{K2 => V2, K1 => V1}}}), + #{ K4 := #{ K5 := Res }, K6 := Res} = id(#{K4=>#{K5 => 99}, K6 => 99}), + + %% has keys + #{a :=_,b :=_,K1:=_,K2:=_,K3:=V3,K4:=ResKey,K4:=ResKey,"4":=ResKey,"4":="ok"} = + id(#{ a=>1, b=>1, K1=>V1, K2=>V2, K3=>V3, K4=>"nope", "4"=>"ok" }), + + %% function + ok = match_function_map_neg_keys(#{ -1 => a, -2 => b, -3 => c }), + + %% map key + #{ K0 := 42 } = id(#{ K0 => 42 }), + #{ K7 := 42 } = id(#{ K7 => 42 }), + + %% nil key + KNIL = id([]), + #{KNIL:=ok,1:=2} = id(#{KNIL=>ok,1=>2}), + + Bin = <<0:258>>, + #{ Bin := "three" } = id(#{<<0:258>> =>"three"}), + + %% error case + {'EXIT',{{badmatch,_},_}} = (catch (#{K5:=3,x:=2} = id(#{K5=>3}))), + {'EXIT',{{badmatch,_},_}} = (catch (#{K5:=2} = id(#{K5=>3}))), + {'EXIT',{{badmatch,_},_}} = (catch (#{K5:=3} = id({a,b,c}))), + {'EXIT',{{badmatch,_},_}} = (catch (#{K5:=3} = id(#{K6=>3}))), + {'EXIT',{{badmatch,_},_}} = (catch (#{K5:=3} = id(K7))), + {'EXIT',{{badmatch,_},_}} = (catch (#{K7:=3} = id(#{K7=>42}))), + ok. + + +match_function_map_neg_keys(#{ -1 := a, -2 := b, -3 := c }) -> ok. + +t_update_assoc_variables(Config) when is_list(Config) -> + K1 = id(1), + K2 = id(2), + K3 = id(3.0), + K4 = id(4), + K5 = id(5), + K6 = id(2.0), + + M0 = #{K1=>a,K2=>b,K3=>c,K4=>d,K5=>e}, + + M1 = M0#{K1=>42,K2=>100,K4=>[a,b,c]}, + #{1:=42,2:=100,3.0:=c,4:=[a,b,c],5:=e} = M1, + #{1:=42,2:=b,4:=d,5:=e,2.0:=100,K3:=c,4.0:=[a,b,c]} = M0#{1.0=>float,1:=42,2.0=>wrong,K6=>100,4.0=>[a,b,c]}, + + M2 = M0#{K3=>new}, + #{1:=a,2:=b,K3:=new,4:=d,5:=e} = M2, + M2 = M0#{3.0:=wrong,K3=>new}, + + #{ <<0:258>> := val } = id(M0#{<<0:258>> => val}), %% binary limitation + + %% Errors cases. + BadMap = id(badmap), + {'EXIT',{badarg,_}} = (catch BadMap#{nonexisting=>val}), + {'EXIT',{badarg,_}} = (catch <<>>#{nonexisting=>val}), + ok. + +t_update_exact_variables(Config) when is_list(Config) -> + K1 = id(1), + K2 = id(2), + K3 = id(3.0), + K4 = id(4), + + M0 = id(#{1=>a,2=>b,3.0=>c,4=>d,5=>e}), + + M1 = M0#{K1:=42,K2:=100,K4:=[a,b,c]}, + #{1:=42,2:=100,3.0:=c,K4:=[a,b,c],5:=e} = M1, + M1 = M0#{K1:=wrong,1:=also_wrong,K1=>42,2=>wrong,K2:=100,4:=[a,b,c]}, + + M2 = M0#{K3:=new}, + #{1:=a,K2:=b,3.0:=new,K4:=d,5:=e} = M2, + M2 = M0#{3.0=>wrong,K3:=new}, + true = M2 =/= M0#{3=>right,3.0:=new}, + #{ 3 := right, 3.0 := new } = M0#{3=>right,K3:=new}, + + M3 = id(#{ 1 => val}), + #{1 := update2,1.0 := new_val4} = M3#{ + 1.0 => new_val1, K1 := update, K1=> update3, + K1 := update2, 1.0 := new_val2, 1.0 => new_val3, + 1.0 => new_val4 }, + + #{ "wat" := 3, 2 := a } = id(#{ "wat" => 1, K2 => 2 }#{ K2 := a, "wat" := 3 }), + + %% Errors cases. + {'EXIT',{badarg,_}} = (catch ((id(nil))#{ a := b })), + {'EXIT',{badarg,_}} = (catch M0#{nonexisting:=val}), + {'EXIT',{badarg,_}} = (catch M0#{1.0:=v,1.0=>v2}), + {'EXIT',{badarg,_}} = (catch M0#{42.0:=v,42:=v2}), + {'EXIT',{badarg,_}} = (catch M0#{42=>v1,42.0:=v2,42:=v3}), + {'EXIT',{badarg,_}} = (catch <<>>#{nonexisting:=val}), + {'EXIT',{badarg,_}} = (catch M0#{<<0:257>> := val}), %% limitation + ok. + +t_nested_pattern_expressions(Config) when is_list(Config) -> + K1 = id("hello"), + %K2 = id({ok}), + [_,_,#{ <<"hi">> := wat, K1 := 42 }|_] = id([k,k,#{<<"hi">> => wat, K1 => 42}]), + [_,_,#{ -1 := wat, K1 := 42 }|_] = id([k,k,#{-1 => wat, K1 => 42}]), + [_,_,{#{ -1 := #{ {-3,<<0:300>>} := V1 }, K1 := 42 },3}|_] = id([k,k,{#{-1 => #{{-3,<<0:300>>}=>"hi"}, K1 => 42},3}]), + "hi" = V1, + %[k,#{ {-1,K1,[]} := {wat,K1}, K2 := 42 }|_] = id([k,#{{-1,K1,[]} => {wat,K1}, K2 => 42}]), + %[k,#{ [-1,K2,[]] := {wat,K1}, K1 := 42 }|_] = id([k,#{[-1,K2,[]] => {wat,K1}, K1 => 42}]), + + M0 = id(#{ <<33:333>> => 1, <<332:333>> => ok, a => ok, wat => yep, watzor => ok }), + F0 = map_nested_pattern_funs(M0), + F1 = F0(wat), + F2 = F1(watzor), + {yep,ok} = F2(M0), + ok. + +map_nested_pattern_funs(M) -> + K0 = id(a), + fun(K1) -> + case M of + #{ K0 := ok, K1 := yep, <<33:333>> := 1 } -> + fun(K2) -> + case M of + #{ K2 := ok, K1 := yep, <<33:333>> := 1 } -> + fun + (#{ <<332:333>> := ok, K1 := V1, K2 := V2 }) -> + {V1,V2} + end + end + end + end + end. + +t_guard_update_variables(Config) when is_list(Config) -> + error = map_guard_update_variables(n,#{},#{}), + first = map_guard_update_variables(x,#{}, #{x=>first}), + second = map_guard_update_variables(x,#{y=>old}, #{x=>second,y=>old}), + third = map_guard_update_variables(x,#{x=>old,y=>old}, #{x=>third,y=>old}), + fourth = map_guard_update_variables(x,#{x=>old,y=>old}, #{x=>4,y=>new}), + ok. + +map_guard_update_variables(K,M1,M2) when M1#{K=>first} =:= M2 -> first; +map_guard_update_variables(K,M1,M2) when M1#{K=>second} =:= M2 -> second; +map_guard_update_variables(K,M1,M2) when M1#{K:=third} =:= M2 -> third; +map_guard_update_variables(K,M1,M2) when M1#{K:=4,y=>new} =:= M2 -> fourth; +map_guard_update_variables(_,_,_) -> error. + +t_guard_sequence_variables(Config) when is_list(Config) -> + {1,"a"} = map_guard_sequence_var_1(a,#{seq=>1,a=>id("a"),b=>no}), + {2,"b"} = map_guard_sequence_var_1(b,#{seq=>2,b=>id("b"),a=>no}), + {3,"c"} = map_guard_sequence_var_1(a,#{seq=>3,a=>id("c"),b=>no}), + {4,"d"} = map_guard_sequence_var_1(b,#{seq=>4,b=>id("d"),a=>no}), + {4,4} = map_guard_sequence_var_1(seq,#{seq=>4}), + {4,4,y} = map_guard_sequence_var_1(seq,#{seq=>4,b=>id("d"),a=>y}), + {5,"d"} = map_guard_sequence_var_1(b,#{seq=>5,b=>id("d"),a=>y}), + + %% error case + {'EXIT',{{case_clause,_},_}} = (catch map_guard_sequence_var_1("a",#{seq=>4,val=>id("e")})), + ok. + + +map_guard_sequence_var_1(K,M) -> + case M of + #{seq:=1=Seq, K:=Val} -> {Seq,Val}; + #{seq:=2=Seq, K:=Val} -> {Seq,Val}; + #{seq:=3=Seq, K:=Val} -> {Seq,Val}; + #{K:=4=Seq, K:=Val1,a:=Val2} -> {Seq,Val1,Val2}; + #{seq:=4=Seq, K:=Val} -> {Seq,Val}; + #{K:=4=Seq, K:=Val} -> {Seq,Val}; + #{seq:=5=Seq, K:=Val} -> {Seq,Val} + end. + + +t_guard_sequence_mixed(Config) when is_list(Config) -> + M0 = id(#{ a=>1, b=>1, c=>1, d=>1, e=>1, f=>1, g=>1, h=>1 }), + M1 = id(M0#{ d := 3 }), + 1 = map_guard_sequence_mixed(a,d,M1), + M2 = id(M1#{ b := 2, d := 4, h := 2 }), + 2 = map_guard_sequence_mixed(a,d,M2), + M3 = id(M2#{ b := 3, e := 5, g := 3 }), + 3 = map_guard_sequence_mixed(a,e,M3), + M4 = id(M3#{ c := 4, e := 6, h := 1 }), + 4 = map_guard_sequence_mixed(a,e,M4), + M5 = id(M4#{ c := 5, f := 7, g := 2 }), + 5 = map_guard_sequence_mixed(a,f,M5), + M6 = id(M5#{ c := 6, f := 8, h := 3 }), + 6 = map_guard_sequence_mixed(a,f,M6), + + %% error case + {'EXIT',{{case_clause,_},_}} = (catch map_guard_sequence_mixed(a,b,M0)), + ok. + +map_guard_sequence_mixed(K1,K2,M) -> + case M of + #{ K1 := 1, b := 1, K2 := 3, g := 1} -> 1; + #{ K1 := 1, b := 2, K2 := 4, h := 2} -> 2; + #{ K1 := 1, b := 3, K2 := 5, g := 3} -> 3; + #{ K1 := 1, c := 4, K2 := 6, h := 1} -> 4; + #{ K1 := 1, c := 5, K2 := 7, g := 2} -> 5; + #{ K1 := 1, c := 6, K2 := 8, h := 3} -> 6 + end. + + + +t_frequency_table(Config) when is_list(Config) -> + random:seed({13,1337,54}), % pseudo random + N = 100000, + Ts = rand_terms(N), + #{ n:=N, tf := Tf } = frequency_table(Ts,#{ n=>0, tf => #{}}), + ok = check_frequency(Ts,Tf), + ok. + + +frequency_table([T|Ts], M) -> + case M of + #{ n := N, tf := #{ T := C } = F } -> + frequency_table(Ts,M#{ n := N + 1, tf := F#{ T := C + 1 }}); + #{ n := N, tf := F } -> + frequency_table(Ts,M#{ n := N + 1, tf := F#{ T => 1 }}) + end; +frequency_table([], M) -> M. + + +check_frequency(Ts,Tf) -> + check_frequency(Ts,Tf,dict:new()). + +check_frequency([T|Ts],Tf,D) -> + case dict:find(T,D) of + error -> check_frequency(Ts,Tf,dict:store(T,1,D)); + {ok,C} -> check_frequency(Ts,Tf,dict:store(T,C+1,D)) + end; +check_frequency([],Tf,D) -> + validate_frequency(dict:to_list(D),Tf). + +validate_frequency([{T,C}|Fs],Tf) -> + case Tf of + #{ T := C } -> validate_frequency(Fs,Tf); + _ -> error + end; +validate_frequency([], _) -> ok. + + +%% aux + +rand_terms(0) -> []; +rand_terms(N) -> [rand_term()|rand_terms(N-1)]. + +rand_term() -> + case random:uniform(6) of + 1 -> rand_binary(); + 2 -> rand_number(); + 3 -> rand_atom(); + 4 -> rand_tuple(); + 5 -> rand_list(); + 6 -> rand_map() + end. + +rand_binary() -> + case random:uniform(3) of + 1 -> <<>>; + 2 -> <<"hi">>; + 3 -> <<"message text larger than 64 bytes. yep, message text larger than 64 bytes.">> + end. + +rand_number() -> + case random:uniform(3) of + 1 -> random:uniform(5); + 2 -> float(random:uniform(5)); + 3 -> 1 bsl (63 + random:uniform(3)) + end. + +rand_atom() -> + case random:uniform(3) of + 1 -> hi; + 2 -> some_atom; + 3 -> some_other_atom + end. + + +rand_tuple() -> + case random:uniform(3) of + 1 -> {ok, rand_term()}; % careful + 2 -> {1, 2, 3}; + 3 -> {<<"yep">>, 1337} + end. + +rand_list() -> + case random:uniform(3) of + 1 -> "hi"; + 2 -> [1,rand_term()]; % careful + 3 -> [improper|list] + end. + +rand_map() -> + case random:uniform(3) of + 1 -> #{ hi => 3 }; + 2 -> #{ wat => rand_term(), other => 3 }; % careful + 3 -> #{ hi => 42, other => 42, yet_anoter => 1337 } + end. + + + %% Use this function to avoid compile-time evaluation of an expression. id(I) -> I. diff --git a/lib/compiler/test/warnings_SUITE.erl b/lib/compiler/test/warnings_SUITE.erl index 0637041873..be0348a92d 100644 --- a/lib/compiler/test/warnings_SUITE.erl +++ b/lib/compiler/test/warnings_SUITE.erl @@ -601,7 +601,7 @@ maps(Config) when is_list(Config) -> ">>, [], {warnings,[{3,v3_core,bad_map}]}}, - {bad_map_literal_key, + {ok_map_literal_key, <<" t() -> V = id(1), @@ -614,7 +614,7 @@ maps(Config) when is_list(Config) -> id(I) -> I. ">>, [], - {warnings,[{6,v3_core,nomatch}]}}], + []}], run(Config, Ts), ok. diff --git a/lib/crypto/c_src/crypto.c b/lib/crypto/c_src/crypto.c index e7215eeb64..a42de9adb1 100644 --- a/lib/crypto/c_src/crypto.c +++ b/lib/crypto/c_src/crypto.c @@ -54,6 +54,10 @@ #include <openssl/evp.h> #include <openssl/hmac.h> +#if OPENSSL_VERSION_NUMBER >= 0x1000000fL +#include <openssl/modes.h> +#endif + #include "crypto_callback.h" #if OPENSSL_VERSION_NUMBER >= 0x00908000L && !defined(OPENSSL_NO_SHA224) && defined(NID_sha224)\ @@ -85,13 +89,32 @@ # define HAVE_AES_IGE #endif +#if OPENSSL_VERSION_NUMBER >= 0x1000100fL +# define HAVE_GCM +#endif + +#if defined(NID_chacha20) && !defined(OPENSSL_NO_CHACHA) && !defined(OPENSSL_NO_POLY1305) +# define HAVE_CHACHA20_POLY1305 +#endif + #if defined(HAVE_EC) #include <openssl/ec.h> #include <openssl/ecdh.h> #include <openssl/ecdsa.h> #endif +#if defined(HAVE_CHACHA20_POLY1305) +#include <openssl/chacha.h> +#include <openssl/poly1305.h> +#if !defined(CHACHA20_NONCE_LEN) +# define CHACHA20_NONCE_LEN 8 +#endif +#if !defined(POLY1305_TAG_LEN) +# define POLY1305_TAG_LEN 16 +#endif + +#endif #ifdef VALGRIND # include <valgrind/memcheck.h> @@ -257,6 +280,11 @@ static ERL_NIF_TERM ecdh_compute_key_nif(ErlNifEnv* env, int argc, const ERL_NIF static ERL_NIF_TERM rand_seed_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); +static ERL_NIF_TERM aes_gcm_encrypt(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); +static ERL_NIF_TERM aes_gcm_decrypt(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); + +static ERL_NIF_TERM chacha20_poly1305_encrypt(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); +static ERL_NIF_TERM chacha20_poly1305_decrypt(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); /* helpers */ static void init_algorithms_types(ErlNifEnv*); @@ -387,7 +415,15 @@ static ErlNifFunc nif_funcs[] = { {"ecdsa_verify_nif", 5, ecdsa_verify_nif}, {"ecdh_compute_key_nif", 3, ecdh_compute_key_nif}, - {"rand_seed_nif", 1, rand_seed_nif} + {"rand_seed_nif", 1, rand_seed_nif}, + + {"aes_gcm_encrypt", 4, aes_gcm_encrypt}, + {"aes_gcm_decrypt", 5, aes_gcm_decrypt}, + + {"chacha20_poly1305_encrypt", 4, chacha20_poly1305_encrypt}, + {"chacha20_poly1305_decrypt", 5, chacha20_poly1305_decrypt} + + }; ERL_NIF_INIT(crypto,nif_funcs,load,NULL,upgrade,unload) @@ -725,7 +761,7 @@ static ERL_NIF_TERM algo_hash[8]; /* increase when extending the list */ static int algo_pubkey_cnt; static ERL_NIF_TERM algo_pubkey[3]; /* increase when extending the list */ static int algo_cipher_cnt; -static ERL_NIF_TERM algo_cipher[2]; /* increase when extending the list */ +static ERL_NIF_TERM algo_cipher[4]; /* increase when extending the list */ static void init_algorithms_types(ErlNifEnv* env) { @@ -763,6 +799,12 @@ static void init_algorithms_types(ErlNifEnv* env) #ifdef HAVE_AES_IGE algo_cipher[algo_cipher_cnt++] = enif_make_atom(env,"aes_ige256"); #endif +#if defined(HAVE_GCM) + algo_cipher[algo_cipher_cnt++] = enif_make_atom(env,"aes_gcm"); +#endif +#if defined(HAVE_CHACHA20_POLY1305) + algo_cipher[algo_cipher_cnt++] = enif_make_atom(env,"chacha20_poly1305"); +#endif ASSERT(algo_hash_cnt <= sizeof(algo_hash)/sizeof(ERL_NIF_TERM)); ASSERT(algo_pubkey_cnt <= sizeof(algo_pubkey)/sizeof(ERL_NIF_TERM)); @@ -1760,6 +1802,236 @@ static ERL_NIF_TERM aes_ctr_stream_encrypt(ErlNifEnv* env, int argc, const ERL_N return ret; } +static ERL_NIF_TERM aes_gcm_encrypt(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]) +{/* (Key,Iv,AAD,In) */ +#if defined(HAVE_GCM) + GCM128_CONTEXT *ctx = NULL; + ErlNifBinary key, iv, aad, in; + AES_KEY aes_key; + unsigned char *outp; + ERL_NIF_TERM out, out_tag; + + CHECK_OSE_CRYPTO(); + + if (!enif_inspect_iolist_as_binary(env, argv[0], &key) + || AES_set_encrypt_key(key.data, key.size*8, &aes_key) != 0 + || !enif_inspect_binary(env, argv[1], &iv) || iv.size == 0 + || !enif_inspect_iolist_as_binary(env, argv[2], &aad) + || !enif_inspect_iolist_as_binary(env, argv[3], &in)) { + return enif_make_badarg(env); + } + + if (!(ctx = CRYPTO_gcm128_new(&aes_key, (block128_f)AES_encrypt))) + return atom_error; + + CRYPTO_gcm128_setiv(ctx, iv.data, iv.size); + + if (CRYPTO_gcm128_aad(ctx, aad.data, aad.size)) + goto out_err; + + outp = enif_make_new_binary(env, in.size, &out); + + /* encrypt */ + if (CRYPTO_gcm128_encrypt(ctx, in.data, outp, in.size)) + goto out_err; + + /* calculate the tag */ + CRYPTO_gcm128_tag(ctx, enif_make_new_binary(env, EVP_GCM_TLS_TAG_LEN, &out_tag), EVP_GCM_TLS_TAG_LEN); + CRYPTO_gcm128_release(ctx); + + CONSUME_REDS(env, in); + + return enif_make_tuple2(env, out, out_tag); + +out_err: + CRYPTO_gcm128_release(ctx); + return atom_error; + +#else + return atom_notsup; +#endif +} + +static ERL_NIF_TERM aes_gcm_decrypt(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]) +{/* (Key,Iv,AAD,In,Tag) */ +#if defined(HAVE_GCM) + GCM128_CONTEXT *ctx; + ErlNifBinary key, iv, aad, in, tag; + AES_KEY aes_key; + unsigned char *outp; + ERL_NIF_TERM out; + + CHECK_OSE_CRYPTO(); + + if (!enif_inspect_iolist_as_binary(env, argv[0], &key) + || AES_set_encrypt_key(key.data, key.size*8, &aes_key) != 0 + || !enif_inspect_binary(env, argv[1], &iv) || iv.size == 0 + || !enif_inspect_iolist_as_binary(env, argv[2], &aad) + || !enif_inspect_iolist_as_binary(env, argv[3], &in) + || !enif_inspect_iolist_as_binary(env, argv[4], &tag) || tag.size != EVP_GCM_TLS_TAG_LEN) { + return enif_make_badarg(env); + } + + if (!(ctx = CRYPTO_gcm128_new(&aes_key, (block128_f)AES_encrypt))) + return atom_error; + + CRYPTO_gcm128_setiv(ctx, iv.data, iv.size); + + if (CRYPTO_gcm128_aad(ctx, aad.data, aad.size)) + goto out_err; + + outp = enif_make_new_binary(env, in.size, &out); + + /* decrypt */ + if (CRYPTO_gcm128_decrypt(ctx, in.data, outp, in.size)) + goto out_err; + + /* calculate and check the tag */ + if (CRYPTO_gcm128_finish(ctx, tag.data, EVP_GCM_TLS_TAG_LEN)) + goto out_err; + + CRYPTO_gcm128_release(ctx); + CONSUME_REDS(env, in); + + return out; + +out_err: + CRYPTO_gcm128_release(ctx); + return atom_error; +#else + return atom_notsup; +#endif +} + +#if defined(HAVE_CHACHA20_POLY1305) +static void +poly1305_update_with_length(poly1305_state *poly1305, + const unsigned char *data, size_t data_len) +{ + size_t j = data_len; + unsigned char length_bytes[8]; + unsigned i; + + for (i = 0; i < sizeof(length_bytes); i++) { + length_bytes[i] = j; + j >>= 8; + } + + CRYPTO_poly1305_update(poly1305, data, data_len); + CRYPTO_poly1305_update(poly1305, length_bytes, sizeof(length_bytes)); +} +#endif + +static ERL_NIF_TERM chacha20_poly1305_encrypt(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]) +{/* (Key,Iv,AAD,In) */ +#if defined(HAVE_CHACHA20_POLY1305) + ErlNifBinary key, iv, aad, in; + unsigned char *outp; + ERL_NIF_TERM out, out_tag; + ErlNifUInt64 in_len_64; + unsigned char poly1305_key[32]; + poly1305_state poly1305; + + CHECK_OSE_CRYPTO(); + + if (!enif_inspect_iolist_as_binary(env, argv[0], &key) || key.size != 32 + || !enif_inspect_binary(env, argv[1], &iv) || iv.size != CHACHA20_NONCE_LEN + || !enif_inspect_iolist_as_binary(env, argv[2], &aad) + || !enif_inspect_iolist_as_binary(env, argv[3], &in)) { + return enif_make_badarg(env); + } + + /* Take from OpenSSL patch set/LibreSSL: + * + * The underlying ChaCha implementation may not overflow the block + * counter into the second counter word. Therefore we disallow + * individual operations that work on more than 2TB at a time. + * in_len_64 is needed because, on 32-bit platforms, size_t is only + * 32-bits and this produces a warning because it's always false. + * Casting to uint64_t inside the conditional is not sufficient to stop + * the warning. */ + in_len_64 = in.size; + if (in_len_64 >= (1ULL << 32) * 64 - 64) + return enif_make_badarg(env); + + memset(poly1305_key, 0, sizeof(poly1305_key)); + CRYPTO_chacha_20(poly1305_key, poly1305_key, sizeof(poly1305_key), key.data, iv.data, 0); + + outp = enif_make_new_binary(env, in.size, &out); + + CRYPTO_poly1305_init(&poly1305, poly1305_key); + poly1305_update_with_length(&poly1305, aad.data, aad.size); + CRYPTO_chacha_20(outp, in.data, in.size, key.data, iv.data, 1); + poly1305_update_with_length(&poly1305, outp, in.size); + + CRYPTO_poly1305_finish(&poly1305, enif_make_new_binary(env, POLY1305_TAG_LEN, &out_tag)); + + CONSUME_REDS(env, in); + + return enif_make_tuple2(env, out, out_tag); + +#else + return atom_notsup; +#endif +} + +static ERL_NIF_TERM chacha20_poly1305_decrypt(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]) +{/* (Key,Iv,AAD,In,Tag) */ +#if defined(HAVE_CHACHA20_POLY1305) + ErlNifBinary key, iv, aad, in, tag; + unsigned char *outp; + ERL_NIF_TERM out; + ErlNifUInt64 in_len_64; + unsigned char poly1305_key[32]; + unsigned char mac[POLY1305_TAG_LEN]; + poly1305_state poly1305; + + CHECK_OSE_CRYPTO(); + + if (!enif_inspect_iolist_as_binary(env, argv[0], &key) || key.size != 32 + || !enif_inspect_binary(env, argv[1], &iv) || iv.size != CHACHA20_NONCE_LEN + || !enif_inspect_iolist_as_binary(env, argv[2], &aad) + || !enif_inspect_iolist_as_binary(env, argv[3], &in) + || !enif_inspect_iolist_as_binary(env, argv[4], &tag) || tag.size != POLY1305_TAG_LEN) { + return enif_make_badarg(env); + } + + /* Take from OpenSSL patch set/LibreSSL: + * + * The underlying ChaCha implementation may not overflow the block + * counter into the second counter word. Therefore we disallow + * individual operations that work on more than 2TB at a time. + * in_len_64 is needed because, on 32-bit platforms, size_t is only + * 32-bits and this produces a warning because it's always false. + * Casting to uint64_t inside the conditional is not sufficient to stop + * the warning. */ + in_len_64 = in.size; + if (in_len_64 >= (1ULL << 32) * 64 - 64) + return enif_make_badarg(env); + + memset(poly1305_key, 0, sizeof(poly1305_key)); + CRYPTO_chacha_20(poly1305_key, poly1305_key, sizeof(poly1305_key), key.data, iv.data, 0); + + CRYPTO_poly1305_init(&poly1305, poly1305_key); + poly1305_update_with_length(&poly1305, aad.data, aad.size); + poly1305_update_with_length(&poly1305, in.data, in.size); + CRYPTO_poly1305_finish(&poly1305, mac); + + if (memcmp(mac, tag.data, POLY1305_TAG_LEN) != 0) + return atom_error; + + outp = enif_make_new_binary(env, in.size, &out); + + CRYPTO_chacha_20(outp, in.data, in.size, key.data, iv.data, 1); + + CONSUME_REDS(env, in); + + return out; +#else + return atom_notsup; +#endif +} + static ERL_NIF_TERM rand_bytes_1(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]) {/* (Bytes) */ unsigned bytes; diff --git a/lib/crypto/doc/src/crypto.xml b/lib/crypto/doc/src/crypto.xml index 98384978a5..271130a9e6 100644 --- a/lib/crypto/doc/src/crypto.xml +++ b/lib/crypto/doc/src/crypto.xml @@ -41,7 +41,7 @@ </item> <item> <p>Block ciphers - <url href="http://csrc.nist.gov/groups/ST/toolkit/block_ciphers.html"> </url> DES and AES in - Block Cipher Modes - <url href="http://csrc.nist.gov/groups/ST/toolkit/BCM/index.html"> ECB, CBC, CFB, OFB and CTR </url></p> + Block Cipher Modes - <url href="http://csrc.nist.gov/groups/ST/toolkit/BCM/index.html"> ECB, CBC, CFB, OFB, CTR and GCM </url></p> </item> <item> <p><url href="http://www.ietf.org/rfc/rfc1321.txt"> RSA encryption RFC 1321 </url> </p> @@ -53,6 +53,12 @@ <item> <p><url href="http://www.ietf.org/rfc/rfc2945.txt"> Secure Remote Password Protocol (SRP - RFC 2945) </url></p> </item> + <item> + <p>gcm: Dworkin, M., "Recommendation for Block Cipher Modes of + Operation: Galois/Counter Mode (GCM) and GMAC", + National Institute of Standards and Technology SP 800- + 38D, November 2007.</p> + </item> </list> </description> @@ -132,6 +138,8 @@ blowfish_cfb64 | des_cbc | des_cfb | des3_cbc | des3_cbf | des_ede3 | rc2_cbc </code></p> + <p><code>aead_cipher() = aes_gcm | chacha20_poly1305 </code></p> + <p><code>stream_key() = aes_key() | rc4_key() </code></p> <p><code>block_key() = aes_key() | blowfish_key() | des_key()| des3_key() </code></p> @@ -152,7 +160,7 @@ Note that both md4 and md5 are recommended only for compatibility with existing applications. </p> <p><code> cipher_algorithms() = des_cbc | des_cfb | des3_cbc | des3_cbf | des_ede3 | - blowfish_cbc | blowfish_cfb64 | aes_cbc128 | aes_cfb8 | aes_cfb128| aes_cbc256 | aes_ige256 | rc2_cbc | aes_ctr| rc4 </code> </p> + blowfish_cbc | blowfish_cfb64 | aes_cbc128 | aes_cfb8 | aes_cfb128| aes_cbc256 | aes_ige256 | aes_gcm | chacha20_poly1305 | rc2_cbc | aes_ctr| rc4 </code> </p> <p><code> public_key_algorithms() = rsa |dss | ecdsa | dh | ecdh | ec_gf2m</code> Note that ec_gf2m is not strictly a public key algorithm, but a restriction on what curves are supported with ecdsa and ecdh. @@ -161,18 +169,23 @@ </section> <funcs> - <func> + <func> <name>block_encrypt(Type, Key, Ivec, PlainText) -> CipherText</name> - <fsummary>Encrypt <c>PlainText</c>according to <c>Type</c> block cipher</fsummary> + <name>block_encrypt(AeadType, Key, Ivec, {AAD, PlainText}) -> {CipherText, CipherTag}</name> + <fsummary>Encrypt <c>PlainText</c> according to <c>Type</c> block cipher</fsummary> <type> <v>Type = block_cipher() </v> + <v>AeadType = aead_cipher() </v> <v>Key = block_key() </v> <v>PlainText = iodata() </v> - <v>IVec = CipherText = binary()</v> + <v>AAD = IVec = CipherText = CipherTag = binary()</v> </type> <desc> <p>Encrypt <c>PlainText</c>according to <c>Type</c> block cipher. <c>IVec</c> is an arbitrary initializing vector.</p> + <p>In AEAD (Authenticated Encryption with Associated Data) mode, encrypt + <c>PlainText</c>according to <c>Type</c> block cipher and calculate + <c>CipherTag</c> that also authenticates the <c>AAD</c> (Associated Authenticated Data).</p> <p>May throw exception <c>notsup</c> in case the chosen <c>Type</c> is not supported by the underlying OpenSSL implementation.</p> </desc> @@ -180,16 +193,22 @@ <func> <name>block_decrypt(Type, Key, Ivec, CipherText) -> PlainText</name> - <fsummary>Decrypt <c>CipherText</c>according to <c>Type</c> block cipher</fsummary> + <name>block_decrypt(AeadType, Key, Ivec, {AAD, CipherText, CipherTag}) -> PlainText | error</name> + <fsummary>Decrypt <c>CipherText</c> according to <c>Type</c> block cipher</fsummary> <type> <v>Type = block_cipher() </v> + <v>AeadType = aead_cipher() </v> <v>Key = block_key() </v> <v>PlainText = iodata() </v> - <v>IVec = CipherText = binary()</v> + <v>AAD = IVec = CipherText = CipherTag = binary()</v> </type> <desc> <p>Decrypt <c>CipherText</c>according to <c>Type</c> block cipher. <c>IVec</c> is an arbitrary initializing vector.</p> + <p>In AEAD (Authenticated Encryption with Associated Data) mode, decrypt + <c>CipherText</c>according to <c>Type</c> block cipher and check the authenticity + the <c>PlainText</c> and <c>AAD</c> (Associated Authenticated Data) using the + <c>CipherTag</c>. May return <c>error</c> if the decryption or validation fail's</p> <p>May throw exception <c>notsup</c> in case the chosen <c>Type</c> is not supported by the underlying OpenSSL implementation.</p> </desc> diff --git a/lib/crypto/src/crypto.erl b/lib/crypto/src/crypto.erl index e1fbbf9ab8..7f82fa83fd 100644 --- a/lib/crypto/src/crypto.erl +++ b/lib/crypto/src/crypto.erl @@ -282,7 +282,8 @@ hmac_final_n(_Context, _HashLen) -> ? nif_stub. -spec block_encrypt(des_cbc | des_cfb | des3_cbc | des3_cbf | des_ede3 | blowfish_cbc | blowfish_cfb64 | aes_cbc128 | aes_cfb8 | aes_cfb128 | aes_cbc256 | rc2_cbc, - Key::iodata(), Ivec::binary(), Data::iodata()) -> binary(). + Key::iodata(), Ivec::binary(), Data::iodata()) -> binary(); + (aes_gcm | chacha20_poly1305, Key::iodata(), Ivec::binary(), {AAD::binary(), Data::iodata()}) -> {binary(), binary()}. block_encrypt(des_cbc, Key, Ivec, Data) -> des_cbc_encrypt(Key, Ivec, Data); @@ -310,14 +311,25 @@ block_encrypt(aes_cfb8, Key, Ivec, Data) -> aes_cfb_8_encrypt(Key, Ivec, Data); block_encrypt(aes_cfb128, Key, Ivec, Data) -> aes_cfb_128_encrypt(Key, Ivec, Data); +block_encrypt(aes_gcm, Key, Ivec, {AAD, Data}) -> + case aes_gcm_encrypt(Key, Ivec, AAD, Data) of + notsup -> erlang:error(notsup); + Return -> Return + end; +block_encrypt(chacha20_poly1305, Key, Ivec, {AAD, Data}) -> + case chacha20_poly1305_encrypt(Key, Ivec, AAD, Data) of + notsup -> erlang:error(notsup); + Return -> Return + end; block_encrypt(rc2_cbc, Key, Ivec, Data) -> rc2_cbc_encrypt(Key, Ivec, Data). -spec block_decrypt(des_cbc | des_cfb | des3_cbc | des3_cbf | des_ede3 | blowfish_cbc | - blowfish_cfb64 | blowfish_ofb64 | aes_cbc128 | aes_cbc256 | aes_ige256 | - aes_cfb8 | aes_cfb128 | rc2_cbc, - Key::iodata(), Ivec::binary(), Data::iodata()) -> binary(). - + blowfish_cfb64 | blowfish_ofb64 | aes_cbc128 | aes_cbc256 | aes_ige256 | + aes_cfb8 | aes_cfb128 | rc2_cbc, + Key::iodata(), Ivec::binary(), Data::iodata()) -> binary(); + (aes_gcm | chacha20_poly1305, Key::iodata(), Ivec::binary(), + {AAD::binary(), Data::iodata(), Tag::binary()}) -> binary() | error. block_decrypt(des_cbc, Key, Ivec, Data) -> des_cbc_decrypt(Key, Ivec, Data); block_decrypt(des_cfb, Key, Ivec, Data) -> @@ -344,9 +356,18 @@ block_decrypt(aes_cfb8, Key, Ivec, Data) -> aes_cfb_8_decrypt(Key, Ivec, Data); block_decrypt(aes_cfb128, Key, Ivec, Data) -> aes_cfb_128_decrypt(Key, Ivec, Data); +block_decrypt(aes_gcm, Key, Ivec, {AAD, Data, Tag}) -> + case aes_gcm_decrypt(Key, Ivec, AAD, Data, Tag) of + notsup -> erlang:error(notsup); + Return -> Return + end; +block_decrypt(chacha20_poly1305, Key, Ivec, {AAD, Data, Tag}) -> + case chacha20_poly1305_decrypt(Key, Ivec, AAD, Data, Tag) of + notsup -> erlang:error(notsup); + Return -> Return + end; block_decrypt(rc2_cbc, Key, Ivec, Data) -> rc2_cbc_decrypt(Key, Ivec, Data). - -spec block_encrypt(des_ecb | blowfish_ecb, Key::iodata(), Data::iodata()) -> binary(). block_encrypt(des_ecb, Key, Data) -> @@ -1190,6 +1211,17 @@ aes_cfb_128_decrypt(Key, IVec, Data) -> aes_cfb_128_crypt(_Key, _IVec, _Data, _IsEncrypt) -> ?nif_stub. +%% +%% AES - in Galois/Counter Mode (GCM) +%% +aes_gcm_encrypt(_Key, _Ivec, _AAD, _In) -> ?nif_stub. +aes_gcm_decrypt(_Key, _Ivec, _AAD, _In, _Tag) -> ?nif_stub. + +%% +%% Chacha20/Ppoly1305 +%% +chacha20_poly1305_encrypt(_Key, _Ivec, _AAD, _In) -> ?nif_stub. +chacha20_poly1305_decrypt(_Key, _Ivec, _AAD, _In, _Tag) -> ?nif_stub. %% %% DES - in cipher block chaining mode (CBC) diff --git a/lib/crypto/test/crypto_SUITE.erl b/lib/crypto/test/crypto_SUITE.erl index 03aa3964a5..1031e6403f 100644 --- a/lib/crypto/test/crypto_SUITE.erl +++ b/lib/crypto/test/crypto_SUITE.erl @@ -62,6 +62,8 @@ all() -> {group, rc2_cbc}, {group, rc4}, {group, aes_ctr}, + {group, aes_gcm}, + {group, chacha20_poly1305}, mod_pow, exor, rand_uniform @@ -100,7 +102,9 @@ groups() -> {blowfish_cfb64, [], [block]}, {blowfish_ofb64,[], [block]}, {rc4, [], [stream]}, - {aes_ctr, [], [stream]} + {aes_ctr, [], [stream]}, + {aes_gcm, [], [aead]}, + {chacha20_poly1305, [], [aead]} ]. %%------------------------------------------------------------------- @@ -203,6 +207,14 @@ stream(Config) when is_list(Config) -> lists:foreach(fun stream_cipher/1, stream_iolistify(Streams)), lists:foreach(fun stream_cipher_incment/1, stream_iolistify(Streams)). +%%-------------------------------------------------------------------- +aead() -> + [{doc, "Test AEAD ciphers"}]. +aead(Config) when is_list(Config) -> + AEADs = lazy_eval(proplists:get_value(aead, Config)), + + lists:foreach(fun aead_cipher/1, AEADs). + %%-------------------------------------------------------------------- sign_verify() -> [{doc, "Sign/verify digital signatures"}]. @@ -406,7 +418,22 @@ stream_cipher_incment(_State, OrigState, [], Acc, Plain) -> stream_cipher_incment(State0, OrigState, [PlainText | PlainTexts], Acc, Plain) -> {State, CipherText} = crypto:stream_encrypt(State0, PlainText), stream_cipher_incment(State, OrigState, PlainTexts, [CipherText | Acc], Plain). - + +aead_cipher({Type, Key, PlainText, IV, AAD, CipherText, CipherTag}) -> + Plain = iolist_to_binary(PlainText), + case crypto:block_encrypt(Type, Key, IV, {AAD, Plain}) of + {CipherText, CipherTag} -> + ok; + Other0 -> + ct:fail({{crypto, block_encrypt, [Plain, PlainText]}, {expected, {CipherText, CipherTag}}, {got, Other0}}) + end, + case crypto:block_decrypt(Type, Key, IV, {AAD, CipherText, CipherTag}) of + Plain -> + ok; + Other1 -> + ct:fail({{crypto, block_decrypt, [CipherText]}, {expected, Plain}, {got, Other1}}) + end. + do_sign_verify({Type, Hash, Public, Private, Msg}) -> Signature = crypto:sign(Type, Hash, Msg, Private), case crypto:verify(Type, Hash, Msg, Signature, Public) of @@ -749,6 +776,12 @@ group_config(rc4, Config) -> group_config(aes_ctr, Config) -> Stream = aes_ctr(), [{stream, Stream} | Config]; +group_config(aes_gcm, Config) -> + AEAD = aes_gcm(), + [{aead, AEAD} | Config]; +group_config(chacha20_poly1305, Config) -> + AEAD = chacha20_poly1305(), + [{aead, AEAD} | Config]; group_config(_, Config) -> Config. @@ -1378,6 +1411,269 @@ aes_ctr() -> long_msg()} ]. + +%% AES GCM test vectors from http://csrc.nist.gov/groups/ST/toolkit/BCM/documents/proposedmodes/gcm/gcm-spec.pdf +aes_gcm() -> + [ + %% Test Case 1 + {aes_gcm, hexstr2bin("00000000000000000000000000000000"), %% Key + hexstr2bin(""), %% PlainText + hexstr2bin("000000000000000000000000"), %% IV + hexstr2bin(""), %% AAD + hexstr2bin(""), %% CipherText + hexstr2bin("58e2fccefa7e3061367f1d57a4e7455a")}, %% CipherTag + + %% Test Case 2 + {aes_gcm, hexstr2bin("00000000000000000000000000000000"), %% Key + hexstr2bin("00000000000000000000000000000000"), %% PlainText + hexstr2bin("000000000000000000000000"), %% IV + hexstr2bin(""), %% AAD + hexstr2bin("0388dace60b6a392f328c2b971b2fe78"), %% CipherText + hexstr2bin("ab6e47d42cec13bdf53a67b21257bddf")}, %% CipherTag + + %% Test Case 3 + {aes_gcm, hexstr2bin("feffe9928665731c6d6a8f9467308308"), %% Key + hexstr2bin("d9313225f88406e5a55909c5aff5269a" %% PlainText + "86a7a9531534f7da2e4c303d8a318a72" + "1c3c0c95956809532fcf0e2449a6b525" + "b16aedf5aa0de657ba637b391aafd255"), + hexstr2bin("cafebabefacedbaddecaf888"), %% IV + hexstr2bin(""), %% AAD + hexstr2bin("42831ec2217774244b7221b784d0d49c" %% CipherText + "e3aa212f2c02a4e035c17e2329aca12e" + "21d514b25466931c7d8f6a5aac84aa05" + "1ba30b396a0aac973d58e091473f5985"), + hexstr2bin("4d5c2af327cd64a62cf35abd2ba6fab4")}, %% CipherTag + + %% Test Case 4 + {aes_gcm, hexstr2bin("feffe9928665731c6d6a8f9467308308"), %% Key + hexstr2bin("d9313225f88406e5a55909c5aff5269a" %% PlainText + "86a7a9531534f7da2e4c303d8a318a72" + "1c3c0c95956809532fcf0e2449a6b525" + "b16aedf5aa0de657ba637b39"), + hexstr2bin("cafebabefacedbaddecaf888"), %% IV + hexstr2bin("feedfacedeadbeeffeedfacedeadbeef" %% AAD + "abaddad2"), + hexstr2bin("42831ec2217774244b7221b784d0d49c" %% CipherText + "e3aa212f2c02a4e035c17e2329aca12e" + "21d514b25466931c7d8f6a5aac84aa05" + "1ba30b396a0aac973d58e091"), + hexstr2bin("5bc94fbc3221a5db94fae95ae7121a47")}, %% CipherTag + + %% Test Case 5 + {aes_gcm, hexstr2bin("feffe9928665731c6d6a8f9467308308"), %% Key + hexstr2bin("d9313225f88406e5a55909c5aff5269a" %% PlainText + "86a7a9531534f7da2e4c303d8a318a72" + "1c3c0c95956809532fcf0e2449a6b525" + "b16aedf5aa0de657ba637b39"), + hexstr2bin("cafebabefacedbad"), %% IV + hexstr2bin("feedfacedeadbeeffeedfacedeadbeef" %% AAD + "abaddad2"), + hexstr2bin("61353b4c2806934a777ff51fa22a4755" %% CipherText + "699b2a714fcdc6f83766e5f97b6c7423" + "73806900e49f24b22b097544d4896b42" + "4989b5e1ebac0f07c23f4598"), + hexstr2bin("3612d2e79e3b0785561be14aaca2fccb")}, %% CipherTag + + %% Test Case 6" + {aes_gcm, hexstr2bin("feffe9928665731c6d6a8f9467308308"), %% Key + hexstr2bin("d9313225f88406e5a55909c5aff5269a" %% PlainText + "86a7a9531534f7da2e4c303d8a318a72" + "1c3c0c95956809532fcf0e2449a6b525" + "b16aedf5aa0de657ba637b39"), + hexstr2bin("9313225df88406e555909c5aff5269aa" %% IV + "6a7a9538534f7da1e4c303d2a318a728" + "c3c0c95156809539fcf0e2429a6b5254" + "16aedbf5a0de6a57a637b39b"), + hexstr2bin("feedfacedeadbeeffeedfacedeadbeef" %% AAD + "abaddad2"), + hexstr2bin("8ce24998625615b603a033aca13fb894" %% CipherText + "be9112a5c3a211a8ba262a3cca7e2ca7" + "01e4a9a4fba43c90ccdcb281d48c7c6f" + "d62875d2aca417034c34aee5"), + hexstr2bin("619cc5aefffe0bfa462af43c1699d050")}, %% CipherTag + + %% Test Case 7 + {aes_gcm, hexstr2bin("00000000000000000000000000000000" %% Key + "0000000000000000"), + hexstr2bin(""), %% PlainText + hexstr2bin("000000000000000000000000"), %% IV + hexstr2bin(""), %% AAD + hexstr2bin(""), %% CipherText + hexstr2bin("cd33b28ac773f74ba00ed1f312572435")}, %% CipherTag + + %% Test Case 8 + {aes_gcm, hexstr2bin("00000000000000000000000000000000" %% Key + "0000000000000000"), + hexstr2bin("00000000000000000000000000000000"), %% PlainText + hexstr2bin("000000000000000000000000"), %% IV + hexstr2bin(""), %% AAD + hexstr2bin("98e7247c07f0fe411c267e4384b0f600"), %% CipherText + hexstr2bin("2ff58d80033927ab8ef4d4587514f0fb")}, %% CipherTag + + %% Test Case 9 + {aes_gcm, hexstr2bin("feffe9928665731c6d6a8f9467308308" %% Key + "feffe9928665731c"), + hexstr2bin("d9313225f88406e5a55909c5aff5269a" %% PlainText + "86a7a9531534f7da2e4c303d8a318a72" + "1c3c0c95956809532fcf0e2449a6b525" + "b16aedf5aa0de657ba637b391aafd255"), + hexstr2bin("cafebabefacedbaddecaf888"), %% IV + hexstr2bin(""), %% ADD + hexstr2bin("3980ca0b3c00e841eb06fac4872a2757" %% CipherText + "859e1ceaa6efd984628593b40ca1e19c" + "7d773d00c144c525ac619d18c84a3f47" + "18e2448b2fe324d9ccda2710acade256"), + hexstr2bin("9924a7c8587336bfb118024db8674a14")}, %% CipherTag + + %% Test Case 10 + {aes_gcm, hexstr2bin("feffe9928665731c6d6a8f9467308308" %% Key + "feffe9928665731c"), + hexstr2bin("d9313225f88406e5a55909c5aff5269a" %% PlainText + "86a7a9531534f7da2e4c303d8a318a72" + "1c3c0c95956809532fcf0e2449a6b525" + "b16aedf5aa0de657ba637b39"), + hexstr2bin("cafebabefacedbaddecaf888"), %% IV + hexstr2bin("feedfacedeadbeeffeedfacedeadbeef" %% AAD + "abaddad2"), + hexstr2bin("3980ca0b3c00e841eb06fac4872a2757" %% CipherText + "859e1ceaa6efd984628593b40ca1e19c" + "7d773d00c144c525ac619d18c84a3f47" + "18e2448b2fe324d9ccda2710"), + hexstr2bin("2519498e80f1478f37ba55bd6d27618c")}, %% CipherTag + + %% Test Case 11 + {aes_gcm, hexstr2bin("feffe9928665731c6d6a8f9467308308" %% Key + "feffe9928665731c"), + hexstr2bin("d9313225f88406e5a55909c5aff5269a" %% PlainText + "86a7a9531534f7da2e4c303d8a318a72" + "1c3c0c95956809532fcf0e2449a6b525" + "b16aedf5aa0de657ba637b39"), + hexstr2bin("cafebabefacedbad"), %% IV + hexstr2bin("feedfacedeadbeeffeedfacedeadbeef" %% AAD + "abaddad2"), + hexstr2bin("0f10f599ae14a154ed24b36e25324db8" %% CipherText + "c566632ef2bbb34f8347280fc4507057" + "fddc29df9a471f75c66541d4d4dad1c9" + "e93a19a58e8b473fa0f062f7"), + hexstr2bin("65dcc57fcf623a24094fcca40d3533f8")}, %% CipherTag + + %% Test Case 12 + {aes_gcm, hexstr2bin("feffe9928665731c6d6a8f9467308308" %% Key + "feffe9928665731c"), + hexstr2bin("d9313225f88406e5a55909c5aff5269a" %% PlainText + "86a7a9531534f7da2e4c303d8a318a72" + "1c3c0c95956809532fcf0e2449a6b525" + "b16aedf5aa0de657ba637b39"), + hexstr2bin("9313225df88406e555909c5aff5269aa" %% IV + "6a7a9538534f7da1e4c303d2a318a728" + "c3c0c95156809539fcf0e2429a6b5254" + "16aedbf5a0de6a57a637b39b"), + hexstr2bin("feedfacedeadbeeffeedfacedeadbeef" %% AAD + "abaddad2"), + hexstr2bin("d27e88681ce3243c4830165a8fdcf9ff" %% CipherText + "1de9a1d8e6b447ef6ef7b79828666e45" + "81e79012af34ddd9e2f037589b292db3" + "e67c036745fa22e7e9b7373b"), + hexstr2bin("dcf566ff291c25bbb8568fc3d376a6d9")}, %% CipherTag + + %% Test Case 13 + {aes_gcm, hexstr2bin("00000000000000000000000000000000" %% Key + "00000000000000000000000000000000"), + hexstr2bin(""), %% PlainText + hexstr2bin("000000000000000000000000"), %% IV + hexstr2bin(""), %% AAD + hexstr2bin(""), %% CipherText + hexstr2bin("530f8afbc74536b9a963b4f1c4cb738b")}, %% CipherTag + + %% Test Case 14 + {aes_gcm, hexstr2bin("00000000000000000000000000000000" %% Key + "00000000000000000000000000000000"), + hexstr2bin("00000000000000000000000000000000"), %% PlainText + hexstr2bin("000000000000000000000000"), %% IV + hexstr2bin(""), %% AAD + hexstr2bin("cea7403d4d606b6e074ec5d3baf39d18"), %% CipherText + hexstr2bin("d0d1c8a799996bf0265b98b5d48ab919")}, %% CipherTag + + %% Test Case 15 + {aes_gcm, hexstr2bin("feffe9928665731c6d6a8f9467308308" %% Key + "feffe9928665731c6d6a8f9467308308"), + hexstr2bin("d9313225f88406e5a55909c5aff5269a" %% PlainText + "86a7a9531534f7da2e4c303d8a318a72" + "1c3c0c95956809532fcf0e2449a6b525" + "b16aedf5aa0de657ba637b391aafd255"), + hexstr2bin("cafebabefacedbaddecaf888"), %% IV + hexstr2bin(""), %% AAD + hexstr2bin("522dc1f099567d07f47f37a32a84427d" %% CipherText + "643a8cdcbfe5c0c97598a2bd2555d1aa" + "8cb08e48590dbb3da7b08b1056828838" + "c5f61e6393ba7a0abcc9f662898015ad"), + hexstr2bin("b094dac5d93471bdec1a502270e3cc6c")}, %% CipherTag + + %% Test Case 16 + {aes_gcm, hexstr2bin("feffe9928665731c6d6a8f9467308308" %% Key + "feffe9928665731c6d6a8f9467308308"), + hexstr2bin("d9313225f88406e5a55909c5aff5269a" %% PlainText + "86a7a9531534f7da2e4c303d8a318a72" + "1c3c0c95956809532fcf0e2449a6b525" + "b16aedf5aa0de657ba637b39"), + hexstr2bin("cafebabefacedbaddecaf888"), %% IV + hexstr2bin("feedfacedeadbeeffeedfacedeadbeef" %% AAD + "abaddad2"), + hexstr2bin("522dc1f099567d07f47f37a32a84427d" %% CipherText + "643a8cdcbfe5c0c97598a2bd2555d1aa" + "8cb08e48590dbb3da7b08b1056828838" + "c5f61e6393ba7a0abcc9f662"), + hexstr2bin("76fc6ece0f4e1768cddf8853bb2d551b")}, %% CipherTag + + %% Test Case 17 + {aes_gcm, hexstr2bin("feffe9928665731c6d6a8f9467308308" %% Key + "feffe9928665731c6d6a8f9467308308"), + hexstr2bin("d9313225f88406e5a55909c5aff5269a" %% PlainText + "86a7a9531534f7da2e4c303d8a318a72" + "1c3c0c95956809532fcf0e2449a6b525" + "b16aedf5aa0de657ba637b39"), + hexstr2bin("cafebabefacedbad"), %% IV + hexstr2bin("feedfacedeadbeeffeedfacedeadbeef" %% AAD + "abaddad2"), + hexstr2bin("c3762df1ca787d32ae47c13bf19844cb" %% CipherText + "af1ae14d0b976afac52ff7d79bba9de0" + "feb582d33934a4f0954cc2363bc73f78" + "62ac430e64abe499f47c9b1f"), + hexstr2bin("3a337dbf46a792c45e454913fe2ea8f2")}, %% CipherTag + + %% Test Case 18 + {aes_gcm, hexstr2bin("feffe9928665731c6d6a8f9467308308" %% Key + "feffe9928665731c6d6a8f9467308308"), + hexstr2bin("d9313225f88406e5a55909c5aff5269a" %% PlainText + "86a7a9531534f7da2e4c303d8a318a72" + "1c3c0c95956809532fcf0e2449a6b525" + "b16aedf5aa0de657ba637b39"), + hexstr2bin("9313225df88406e555909c5aff5269aa" %% IV + "6a7a9538534f7da1e4c303d2a318a728" + "c3c0c95156809539fcf0e2429a6b5254" + "16aedbf5a0de6a57a637b39b"), + hexstr2bin("feedfacedeadbeeffeedfacedeadbeef" %% AAD + "abaddad2"), + hexstr2bin("5a8def2f0c9e53f1f75d7853659e2a20" %% CipherText + "eeb2b22aafde6419a058ab4f6f746bf4" + "0fc0c3b780f244452da3ebf1c5d82cde" + "a2418997200ef82e44ae7e3f"), + hexstr2bin("a44a8266ee1c8eb0c8b5d4cf5ae9f19a")} %% CipherTag + ]. + +%% http://tools.ietf.org/html/draft-agl-tls-chacha20poly1305-04 +chacha20_poly1305() -> + [ + {chacha20_poly1305, hexstr2bin("4290bcb154173531f314af57f3be3b500" %% Key + "6da371ece272afa1b5dbdd1100a1007"), + hexstr2bin("86d09974840bded2a5ca"), %% PlainText + hexstr2bin("cd7cf67be39c794a"), %% Nonce + hexstr2bin("87e229d4500845a079c0"), %% AAD + hexstr2bin("e3e446f7ede9a19b62a4"), %% CipherText + hexstr2bin("677dabf4e3d24b876bb284753896e1d6")} %% CipherTag + ]. + rsa_plain() -> <<"7896345786348756234 Hejsan Svejsan, erlang crypto debugger" "09812312908312378623487263487623412039812 huagasd">>. diff --git a/lib/debugger/test/map_SUITE.erl b/lib/debugger/test/map_SUITE.erl index 0076193725..e525484a8e 100644 --- a/lib/debugger/test/map_SUITE.erl +++ b/lib/debugger/test/map_SUITE.erl @@ -32,9 +32,30 @@ t_guard_receive/1, t_guard_fun/1, t_list_comprehension/1, t_map_sort_literals/1, - %t_size/1, t_map_size/1, - + t_build_and_match_aliasing/1, + + %% variables + t_build_and_match_variables/1, + t_update_assoc_variables/1,t_update_exact_variables/1, + t_nested_pattern_expressions/1, + t_guard_update_variables/1, + t_guard_sequence_variables/1, + t_guard_sequence_mixed/1, + t_frequency_table/1, + + %% not covered in 17.0-rc1 + t_build_and_match_over_alloc/1, + t_build_and_match_empty_val/1, + t_build_and_match_val/1, + t_build_and_match_nil/1, + t_build_and_match_structure/1, + + %% errors in 17.0-rc1 + t_update_values/1, + t_expand_map_update/1, + t_export/1, + %% Specific Map BIFs t_bif_map_get/1, t_bif_map_find/1, @@ -61,8 +82,7 @@ %% misc t_pdict/1, - t_ets/1, - t_dets/1 + t_ets/1 ]). -include_lib("stdlib/include/ms_transform.hrl"). @@ -77,7 +97,30 @@ all() -> [ t_guard_bifs, t_guard_sequence, t_guard_update, t_guard_receive,t_guard_fun, t_list_comprehension, t_map_sort_literals, - + t_build_and_match_aliasing, + + %% variables + t_build_and_match_variables, + t_update_assoc_variables,t_update_exact_variables, + t_nested_pattern_expressions, + t_guard_update_variables, + t_guard_sequence_variables, + t_guard_sequence_mixed, + t_frequency_table, + + %% not covered in 17.0-rc1 + t_build_and_match_over_alloc, + t_build_and_match_empty_val, + t_build_and_match_val, + t_build_and_match_nil, + t_build_and_match_structure, + + + %% errors in 17.0-rc1 + t_update_values, + t_expand_map_update, + t_export, + %% Specific Map BIFs t_bif_map_get,t_bif_map_find,t_bif_map_is_key, t_bif_map_keys, t_bif_map_merge, t_bif_map_new, @@ -94,7 +137,6 @@ all() -> [ t_maps_fold, t_maps_map, t_maps_size, t_maps_without, - %% Other functions t_pdict, t_ets @@ -147,18 +189,6 @@ t_build_and_match_literals(Config) when is_list(Config) -> {'EXIT',{{badmatch,_},_}} = (catch (#{x:=3} = id(#{x=>"three"}))), ok. - -%% Tests size(Map). -%% not implemented, perhaps it shouldn't be either - -%t_size(Config) when is_list(Config) -> -% 0 = size(#{}), -% 1 = size(#{a=>1}), -% 1 = size(#{a=>#{a=>1}}), -% 2 = size(#{a=>1, b=>2}), -% 3 = size(#{a=>1, b=>2, b=>"3"}), -% ok. - t_map_size(Config) when is_list(Config) -> 0 = map_size(id(#{})), 1 = map_size(id(#{a=>1})), @@ -268,6 +298,44 @@ t_update_exact(Config) when is_list(Config) -> ok. +t_update_values(Config) when is_list(Config) -> + V0 = id(1337), + M0 = #{ a => 1, val => V0}, + V1 = get_val(M0), + M1 = id(M0#{ val := [V0,V1], "wazzup" => 42 }), + [1337, {some_val, 1337}] = get_val(M1), + M2 = id(M1#{ <<42:333>> => 1337 }), + {bin_key,1337} = get_val(M2), + + N = 110, + List = [{[I,1,2,3,I],{1,2,3,"wat",I}}|| I <- lists:seq(1,N)], + + {_,_,#{val2 := {1,2,3,"wat",N}, val1 := [N,1,2,3,N]}} = lists:foldl(fun + ({V2,V3},{Old2,Old3,Mi}) -> + ok = check_val(Mi,Old2,Old3), + #{ val1 := Old2, val2 := Old3 } = Mi, + {V2,V3, Mi#{ val1 := id(V2), val2 := V1, val2 => id(V3)}} + end, {none, none, #{val1=>none,val2=>none}},List), + ok. + +t_expand_map_update(Config) when is_list(Config) -> + M = #{<<"hello">> => <<"world">>}#{<<"hello">> := <<"les gens">>}, + #{<<"hello">> := <<"les gens">>} = M, + ok. + +t_export(Config) when is_list(Config) -> + Raclette = id(#{}), + case brie of brie -> Fromage = Raclette end, + Raclette = Fromage#{}, + ok. + +check_val(#{val1:=V1, val2:=V2},V1,V2) -> ok. + +get_val(#{ <<42:333>> := V }) -> {bin_key, V}; +get_val(#{ "wazzup" := _, val := V}) -> V; +get_val(#{ val := V }) -> {some_val, V}. + + t_guard_bifs(Config) when is_list(Config) -> true = map_guard_head(#{a=>1}), false = map_guard_head([]), @@ -988,16 +1056,385 @@ t_ets(_Config) -> ets:delete(Tid), ok. -t_dets(_Config) -> +t_build_and_match_aliasing(Config) when is_list(Config) -> + M1 = id(#{a=>1,b=>2,c=>3,d=>4}), + #{c:=C1=_=_=C2} = M1, + true = C1 =:= C2, + #{a:=A,a:=A,a:=A,b:=B,b:=B} = M1, + #{a:=A,a:=A,a:=A,b:=B,b:=B,b:=2} = M1, + #{a:=A=1,a:=A,a:=A,b:=B=2,b:=B,b:=2} = M1, + #{c:=C1, c:=_, c:=3, c:=_, c:=C2} = M1, + #{c:=C=_=3=_=C} = M1, + + M2 = id(#{"a"=>1,"b"=>2,"c"=>3,"d"=>4}), + #{"a":=A2,"a":=A2,"a":=A2,"b":=B2,"b":=B2,"b":=2} = M2, + #{"a":=_,"a":=_,"a":=_,"b":=_,"b":=_,"b":=2} = M2, + ok. + +%% simple build and match variables +t_build_and_match_variables(Config) when is_list(Config) -> + K0 = id(#{}), + K1 = id(1), V1 = id(a), + K2 = id(2), V2 = id(b), + K3 = id(3), V3 = id("c"), + K4 = id("4"), V4 = id("d"), + K5 = id(<<"5">>), V5 = id(<<"e">>), + K6 = id({"6",7}), V6 = id("f"), + K7 = id(#{ "a" => 3 }), + #{K1:=V1} = id(#{K1=>V1}), + #{K1:=V1,K2:=V2} = id(#{K1=>V1,K2=>V2}), + #{K1:=V1,K2:=V2,K3:=V3} = id(#{K1=>V1,K2=>V2,K3=>V3}), + #{K1:=V1,K2:=V2,K3:=V3,K4:=V4} = id(#{K1=>V1,K2=>V2,K3=>V3,K4=>V4}), + #{K1:=V1,K2:=V2,K3:=V3,K4:=V4,K5:=V5} = id(#{K1=>V1,K2=>V2,K3=>V3,K4=>V4,K5=>V5}), + #{K1:=V1,K2:=V2,K3:=V3,K4:=V4,K5:=V5,K6:=V6} = id(#{K1=>V1,K2=>V2,K3=>V3,K4=>V4,K5=>V5,K6=>V6}), + + #{K5:=X,K5:=X=3,K4:=4} = id(#{K5=>3,K4=>4}), + #{K5:=X,<<"5">>:=X=3,K4:=4} = id(#{K5=>3,K4=>4}), + #{K5:=X,<<"5">>:=X=3,K4:=4} = id(#{<<"5">>=>3,K4=>4}), + + #{ K4:=#{ K3:=#{K1:=V1, K2:=V2}}, K5:=V5} = + id(#{ K5=>V5, K4=>#{ K3=>#{K2 => V2, K1 => V1}}}), + #{ K4 := #{ K5 := Res }, K6 := Res} = id(#{K4=>#{K5 => 99}, K6 => 99}), + + %% has keys + #{a :=_,b :=_,K1:=_,K2:=_,K3:=V3,K4:=ResKey,K4:=ResKey,"4":=ResKey,"4":="ok"} = + id(#{ a=>1, b=>1, K1=>V1, K2=>V2, K3=>V3, K4=>"nope", "4"=>"ok" }), + + %% function + ok = match_function_map_neg_keys(#{ -1 => a, -2 => b, -3 => c }), + + %% map key + #{ K0 := 42 } = id(#{ K0 => 42 }), + #{ K7 := 42 } = id(#{ K7 => 42 }), + + %% nil key + KNIL = id([]), + #{KNIL:=ok,1:=2} = id(#{KNIL=>ok,1=>2}), + + Bin = <<0:258>>, + #{ Bin := "three" } = id(#{<<0:258>> =>"three"}), + + %% error case + {'EXIT',{{badmatch,_},_}} = (catch (#{K5:=3,x:=2} = id(#{K5=>3}))), + {'EXIT',{{badmatch,_},_}} = (catch (#{K5:=2} = id(#{K5=>3}))), + {'EXIT',{{badmatch,_},_}} = (catch (#{K5:=3} = id({a,b,c}))), + {'EXIT',{{badmatch,_},_}} = (catch (#{K5:=3} = id(#{K6=>3}))), + {'EXIT',{{badmatch,_},_}} = (catch (#{K5:=3} = id(K7))), + {'EXIT',{{badmatch,_},_}} = (catch (#{K7:=3} = id(#{K7=>42}))), + ok. + + +match_function_map_neg_keys(#{ -1 := a, -2 := b, -3 := c }) -> ok. + +t_update_assoc_variables(Config) when is_list(Config) -> + K1 = id(1), + K2 = id(2), + K3 = id(3.0), + K4 = id(4), + K5 = id(5), + K6 = id(2.0), + + M0 = #{K1=>a,K2=>b,K3=>c,K4=>d,K5=>e}, + + M1 = M0#{K1=>42,K2=>100,K4=>[a,b,c]}, + #{1:=42,2:=100,3.0:=c,4:=[a,b,c],5:=e} = M1, + #{1:=42,2:=b,4:=d,5:=e,2.0:=100,K3:=c,4.0:=[a,b,c]} = M0#{1.0=>float,1:=42,2.0=>wrong,K6=>100,4.0=>[a,b,c]}, + + M2 = M0#{K3=>new}, + #{1:=a,2:=b,K3:=new,4:=d,5:=e} = M2, + M2 = M0#{3.0:=wrong,K3=>new}, + + #{ <<0:258>> := val } = id(M0#{<<0:258>> => val}), %% binary limitation + + %% Errors cases. + BadMap = id(badmap), + {'EXIT',{{badarg,_},_}} = (catch BadMap#{nonexisting=>val}), + {'EXIT',{{badarg,_},_}} = (catch <<>>#{nonexisting=>val}), + ok. + +t_update_exact_variables(Config) when is_list(Config) -> + K1 = id(1), + K2 = id(2), + K3 = id(3.0), + K4 = id(4), + + M0 = id(#{1=>a,2=>b,3.0=>c,4=>d,5=>e}), + + M1 = M0#{K1:=42,K2:=100,K4:=[a,b,c]}, + #{1:=42,2:=100,3.0:=c,K4:=[a,b,c],5:=e} = M1, + M1 = M0#{K1:=wrong,1:=also_wrong,K1=>42,2=>wrong,K2:=100,4:=[a,b,c]}, + + M2 = M0#{K3:=new}, + #{1:=a,K2:=b,3.0:=new,K4:=d,5:=e} = M2, + M2 = M0#{3.0=>wrong,K3:=new}, + true = M2 =/= M0#{3=>right,3.0:=new}, + #{ 3 := right, 3.0 := new } = M0#{3=>right,K3:=new}, + + M3 = id(#{ 1 => val}), + #{1 := update2,1.0 := new_val4} = M3#{ + 1.0 => new_val1, K1 := update, K1=> update3, + K1 := update2, 1.0 := new_val2, 1.0 => new_val3, + 1.0 => new_val4 }, + + %% Errors cases. + {'EXIT',{{badarg,_},_}} = (catch ((id(nil))#{ a := b })), + {'EXIT',{{badarg,_},_}} = (catch <<>>#{nonexisting:=val}), + + {'EXIT',{badarg,_}} = (catch M0#{nonexisting:=val}), + {'EXIT',{badarg,_}} = (catch M0#{1.0:=v,1.0=>v2}), + {'EXIT',{badarg,_}} = (catch M0#{42.0:=v,42:=v2}), + {'EXIT',{badarg,_}} = (catch M0#{42=>v1,42.0:=v2,42:=v3}), + {'EXIT',{badarg,_}} = (catch M0#{<<0:257>> := val}), %% limitation + ok. + +t_nested_pattern_expressions(Config) when is_list(Config) -> + K1 = id("hello"), + %K2 = id({ok}), + [_,_,#{ <<"hi">> := wat, K1 := 42 }|_] = id([k,k,#{<<"hi">> => wat, K1 => 42}]), + [_,_,#{ -1 := wat, K1 := 42 }|_] = id([k,k,#{-1 => wat, K1 => 42}]), + [_,_,{#{ -1 := #{ {-3,<<0:300>>} := V1 }, K1 := 42 },3}|_] = id([k,k,{#{-1 => #{{-3,<<0:300>>}=>"hi"}, K1 => 42},3}]), + "hi" = V1, + %[k,#{ {-1,K1,[]} := {wat,K1}, K2 := 42 }|_] = id([k,#{{-1,K1,[]} => {wat,K1}, K2 => 42}]), + %[k,#{ [-1,K2,[]] := {wat,K1}, K1 := 42 }|_] = id([k,#{[-1,K2,[]] => {wat,K1}, K1 => 42}]), + ok. + +t_guard_update_variables(Config) when is_list(Config) -> + error = map_guard_update_variables(n,#{},#{}), + first = map_guard_update_variables(x,#{}, #{x=>first}), + second = map_guard_update_variables(x,#{y=>old}, #{x=>second,y=>old}), + third = map_guard_update_variables(x,#{x=>old,y=>old}, #{x=>third,y=>old}), + fourth = map_guard_update_variables(x,#{x=>old,y=>old}, #{x=>4,y=>new}), + ok. + +map_guard_update_variables(K,M1,M2) when M1#{K=>first} =:= M2 -> first; +map_guard_update_variables(K,M1,M2) when M1#{K=>second} =:= M2 -> second; +map_guard_update_variables(K,M1,M2) when M1#{K:=third} =:= M2 -> third; +map_guard_update_variables(K,M1,M2) when M1#{K:=4,y=>new} =:= M2 -> fourth; +map_guard_update_variables(_,_,_) -> error. + +t_guard_sequence_variables(Config) when is_list(Config) -> + {1,"a"} = map_guard_sequence_var_1(a,#{seq=>1,a=>id("a"),b=>no}), + {2,"b"} = map_guard_sequence_var_1(b,#{seq=>2,b=>id("b"),a=>no}), + {3,"c"} = map_guard_sequence_var_1(a,#{seq=>3,a=>id("c"),b=>no}), + {4,"d"} = map_guard_sequence_var_1(b,#{seq=>4,b=>id("d"),a=>no}), + {4,4} = map_guard_sequence_var_1(seq,#{seq=>4}), + {4,4,y} = map_guard_sequence_var_1(seq,#{seq=>4,b=>id("d"),a=>y}), + {5,"d"} = map_guard_sequence_var_1(b,#{seq=>5,b=>id("d"),a=>y}), + + %% error case + {'EXIT',{{case_clause,_},_}} = (catch map_guard_sequence_var_1("a",#{seq=>4,val=>id("e")})), + ok. + + +map_guard_sequence_var_1(K,M) -> + case M of + #{seq:=1=Seq, K:=Val} -> {Seq,Val}; + #{seq:=2=Seq, K:=Val} -> {Seq,Val}; + #{seq:=3=Seq, K:=Val} -> {Seq,Val}; + #{K:=4=Seq, K:=Val1,a:=Val2} -> {Seq,Val1,Val2}; + #{seq:=4=Seq, K:=Val} -> {Seq,Val}; + #{K:=4=Seq, K:=Val} -> {Seq,Val}; + #{seq:=5=Seq, K:=Val} -> {Seq,Val} + end. + + +t_guard_sequence_mixed(Config) when is_list(Config) -> + M0 = id(#{ a=>1, b=>1, c=>1, d=>1, e=>1, f=>1, g=>1, h=>1 }), + M1 = id(M0#{ d := 3 }), + 1 = map_guard_sequence_mixed(a,d,M1), + M2 = id(M1#{ b := 2, d := 4, h := 2 }), + 2 = map_guard_sequence_mixed(a,d,M2), + M3 = id(M2#{ b := 3, e := 5, g := 3 }), + 3 = map_guard_sequence_mixed(a,e,M3), + M4 = id(M3#{ c := 4, e := 6, h := 1 }), + 4 = map_guard_sequence_mixed(a,e,M4), + M5 = id(M4#{ c := 5, f := 7, g := 2 }), + 5 = map_guard_sequence_mixed(a,f,M5), + M6 = id(M5#{ c := 6, f := 8, h := 3 }), + 6 = map_guard_sequence_mixed(a,f,M6), + + %% error case + {'EXIT',{{case_clause,_},_}} = (catch map_guard_sequence_mixed(a,b,M0)), + ok. + +map_guard_sequence_mixed(K1,K2,M) -> + case M of + #{ K1 := 1, b := 1, K2 := 3, g := 1} -> 1; + #{ K1 := 1, b := 2, K2 := 4, h := 2} -> 2; + #{ K1 := 1, b := 3, K2 := 5, g := 3} -> 3; + #{ K1 := 1, c := 4, K2 := 6, h := 1} -> 4; + #{ K1 := 1, c := 5, K2 := 7, g := 2} -> 5; + #{ K1 := 1, c := 6, K2 := 8, h := 3} -> 6 + end. + + + +t_frequency_table(Config) when is_list(Config) -> + random:seed({13,1337,54}), % pseudo random + N = 100000, + Ts = rand_terms(N), + #{ n:=N, tf := Tf } = frequency_table(Ts,#{ n=>0, tf => #{}}), + ok = check_frequency(Ts,Tf), + ok. + + +frequency_table([T|Ts], M) -> + case M of + #{ n := N, tf := #{ T := C } = F } -> + frequency_table(Ts,M#{ n := N + 1, tf := F#{ T := C + 1 }}); + #{ n := N, tf := F } -> + frequency_table(Ts,M#{ n := N + 1, tf := F#{ T => 1 }}) + end; +frequency_table([], M) -> M. + + +check_frequency(Ts,Tf) -> + check_frequency(Ts,Tf,dict:new()). + +check_frequency([T|Ts],Tf,D) -> + case dict:find(T,D) of + error -> check_frequency(Ts,Tf,dict:store(T,1,D)); + {ok,C} -> check_frequency(Ts,Tf,dict:store(T,C+1,D)) + end; +check_frequency([],Tf,D) -> + validate_frequency(dict:to_list(D),Tf). + +validate_frequency([{T,C}|Fs],Tf) -> + case Tf of + #{ T := C } -> validate_frequency(Fs,Tf); + _ -> error + end; +validate_frequency([], _) -> ok. + + +%% aux + +rand_terms(0) -> []; +rand_terms(N) -> [rand_term()|rand_terms(N-1)]. + +rand_term() -> + case random:uniform(6) of + 1 -> rand_binary(); + 2 -> rand_number(); + 3 -> rand_atom(); + 4 -> rand_tuple(); + 5 -> rand_list(); + 6 -> rand_map() + end. + +rand_binary() -> + case random:uniform(3) of + 1 -> <<>>; + 2 -> <<"hi">>; + 3 -> <<"message text larger than 64 bytes. yep, message text larger than 64 bytes.">> + end. + +rand_number() -> + case random:uniform(3) of + 1 -> random:uniform(5); + 2 -> float(random:uniform(5)); + 3 -> 1 bsl (63 + random:uniform(3)) + end. + +rand_atom() -> + case random:uniform(3) of + 1 -> hi; + 2 -> some_atom; + 3 -> some_other_atom + end. + + +rand_tuple() -> + case random:uniform(3) of + 1 -> {ok, rand_term()}; % careful + 2 -> {1, 2, 3}; + 3 -> {<<"yep">>, 1337} + end. + +rand_list() -> + case random:uniform(3) of + 1 -> "hi"; + 2 -> [1,rand_term()]; % careful + 3 -> [improper|list] + end. + +rand_map() -> + case random:uniform(3) of + 1 -> #{ hi => 3 }; + 2 -> #{ wat => rand_term(), other => 3 }; % careful + 3 -> #{ hi => 42, other => 42, yet_anoter => 1337 } + end. + + +t_build_and_match_over_alloc(Config) when is_list(Config) -> + Ls = id([1,2,3]), + V0 = [a|Ls], + M0 = id(#{ "a" => V0 }), + #{ "a" := V1 } = M0, + V2 = id([c|Ls]), + M2 = id(#{ "a" => V2 }), + #{ "a" := V3 } = M2, + {[a,1,2,3],[c,1,2,3]} = id({V1,V3}), + ok. + +t_build_and_match_empty_val(Config) when is_list(Config) -> + F = fun(#{ "hi":=_,{1,2}:=_,1337:=_}) -> ok end, + ok = F(id(#{"hi"=>ok,{1,2}=>ok,1337=>ok})), + + %% error case + case (catch (F(id(#{"hi"=>ok})))) of + {'EXIT',{function_clause,_}} -> ok; + {'EXIT', {{case_clause,_},_}} -> {comment,inlined}; + Other -> + test_server:fail({no_match, Other}) + end. + +t_build_and_match_val(Config) when is_list(Config) -> + F = fun + (#{ "hi" := first, v := V}) -> {1,V}; + (#{ "hi" := second, v := V}) -> {2,V} + end, + + + {1,"hello"} = F(id(#{"hi"=>first,v=>"hello"})), + {2,"second"} = F(id(#{"hi"=>second,v=>"second"})), + + %% error case + case (catch (F(id(#{"hi"=>ok})))) of + {'EXIT',{function_clause,_}} -> ok; + {'EXIT', {{case_clause,_},_}} -> {comment,inlined}; + Other -> + test_server:fail({no_match, Other}) + end. + +t_build_and_match_nil(Config) when is_list(Config) -> + %% literals removed the coverage + V1 = id(cookie), + V2 = id(cake), + V3 = id(crisps), + + #{ [] := V1, "treat" := V2, {your,treat} := V3 } = id(#{ + {your,treat} => V3, + "treat" => V2, + [] => V1 }), + #{ [] := V3, [] := V3 } = id(#{ [] => V1, [] => V3 }), + ok. + +t_build_and_match_structure(Config) when is_list(Config) -> + V2 = id("it"), + S = id([42,{"hi", "=)", #{ "a" => 42, any => any, val => "get_" ++ V2}}]), + + %% match deep map values + V2 = case S of + [42,{"hi",_, #{ "a" := 42, val := "get_" ++ V1, any := _ }}] -> V1 + end, + %% match deep map + ok = case S of + [42,{"hi",_, #{ }}] -> ok + end, ok. -getmsg(_Tracer) -> - receive V -> V after 100 -> timeout end. -trace_collector(Msg,Parent) -> - io:format("~p~n",[Msg]), - Parent ! Msg, - Parent. %% Use this function to avoid compile-time evaluation of an expression. id(I) -> I. diff --git a/lib/dialyzer/src/dialyzer_behaviours.erl b/lib/dialyzer/src/dialyzer_behaviours.erl index 1d458b49fc..bbedd3201e 100644 --- a/lib/dialyzer/src/dialyzer_behaviours.erl +++ b/lib/dialyzer/src/dialyzer_behaviours.erl @@ -102,14 +102,18 @@ check_all_callbacks(Module, Behaviour, [Cb|Rest], #state{plt = Plt, codeserver = Codeserver, records = Records} = State, Acc) -> {{Behaviour, Function, Arity}, - {{_BehFile, _BehLine}, Callback}} = Cb, + {{_BehFile, _BehLine}, Callback, Xtra}} = Cb, CbMFA = {Module, Function, Arity}, CbReturnType = dialyzer_contracts:get_contract_return(Callback), CbArgTypes = dialyzer_contracts:get_contract_args(Callback), Acc0 = Acc, Acc1 = case dialyzer_plt:lookup(Plt, CbMFA) of - 'none' -> [{callback_missing, [Behaviour, Function, Arity]}|Acc0]; + 'none' -> + case lists:member(optional_callback, Xtra) of + true -> Acc0; + false -> [{callback_missing, [Behaviour, Function, Arity]}|Acc0] + end; {'value', RetArgTypes} -> Acc00 = Acc0, {ReturnType, ArgTypes} = RetArgTypes, @@ -137,7 +141,7 @@ check_all_callbacks(Module, Behaviour, [Cb|Rest], Acc2 = case dialyzer_codeserver:lookup_mfa_contract(CbMFA, Codeserver) of 'error' -> Acc1; - {ok, {{File, Line}, Contract}} -> + {ok, {{File, Line}, Contract, _Xtra}} -> Acc10 = Acc1, SpecReturnType0 = dialyzer_contracts:get_contract_return(Contract), SpecArgTypes0 = dialyzer_contracts:get_contract_args(Contract), diff --git a/lib/dialyzer/src/dialyzer_codeserver.erl b/lib/dialyzer/src/dialyzer_codeserver.erl index aab3d6add6..593e71f30b 100644 --- a/lib/dialyzer/src/dialyzer_codeserver.erl +++ b/lib/dialyzer/src/dialyzer_codeserver.erl @@ -278,10 +278,10 @@ lookup_mod_contracts(Mod, #codeserver{contracts = ContDict}) case ets_dict_find(Mod, ContDict) of error -> dict:new(); {ok, Keys} -> - dict:from_list([get_contract_pair(Key, ContDict)|| Key <- Keys]) + dict:from_list([get_file_contract(Key, ContDict)|| Key <- Keys]) end. -get_contract_pair(Key, ContDict) -> +get_file_contract(Key, ContDict) -> {Key, ets:lookup_element(ContDict, Key, 2)}. -spec lookup_mfa_contract(mfa(), codeserver()) -> diff --git a/lib/dialyzer/src/dialyzer_contracts.erl b/lib/dialyzer/src/dialyzer_contracts.erl index f27fc1a842..ee147ca102 100644 --- a/lib/dialyzer/src/dialyzer_contracts.erl +++ b/lib/dialyzer/src/dialyzer_contracts.erl @@ -43,7 +43,7 @@ %% Types used in other parts of the system below %%----------------------------------------------------------------------- --type file_contract() :: {file_line(), #contract{}}. +-type file_contract() :: {file_line(), #contract{}, Extra :: [_]}. -type plt_contracts() :: [{mfa(), #contract{}}]. % actually, an orddict() @@ -146,10 +146,10 @@ process_contract_remote_types(CodeServer) -> ExpTypes = dialyzer_codeserver:get_exported_types(CodeServer), RecordDict = dialyzer_codeserver:get_records(CodeServer), ContractFun = - fun({_M, _F, _A}, {File, #tmp_contract{contract_funs = CFuns, forms = Forms}}) -> + fun({_M, _F, _A}, {File, #tmp_contract{contract_funs = CFuns, forms = Forms}, Xtra}) -> NewCs = [CFun(ExpTypes, RecordDict) || CFun <- CFuns], Args = general_domain(NewCs), - {File, #contract{contracts = NewCs, args = Args, forms = Forms}} + {File, #contract{contracts = NewCs, args = Args, forms = Forms}, Xtra} end, ModuleFun = fun(_ModuleName, ContractDict) -> @@ -175,7 +175,7 @@ check_contracts(Contracts, Callgraph, FunTypes, FindOpaques) -> case dialyzer_callgraph:lookup_name(Label, Callgraph) of {ok, {M,F,A} = MFA} -> case orddict:find(MFA, Contracts) of - {ok, {_FileLine, Contract}} -> + {ok, {_FileLine, Contract, _Xtra}} -> Opaques = FindOpaques(M), case check_contract(Contract, Type, Opaques) of ok -> @@ -362,7 +362,7 @@ contracts_without_fun(Contracts, AllFuns0, Callgraph) -> [warn_spec_missing_fun(MFA, Contracts) || MFA <- ErrorContractMFAs]. warn_spec_missing_fun({M, F, A} = MFA, Contracts) -> - {FileLine, _Contract} = dict:fetch(MFA, Contracts), + {FileLine, _Contract, _Xtra} = dict:fetch(MFA, Contracts), {?WARN_CONTRACT_SYNTAX, FileLine, {spec_missing_fun, [M, F, A]}}. %% This treats the "when" constraints. It will be extended, we hope. @@ -386,14 +386,16 @@ insert_constraints([], Dict) -> Dict. -type types() :: erl_types:type_table(). --spec store_tmp_contract(mfa(), file_line(), [_], contracts(), types()) -> +-type spec_data() :: {TypeSpec :: [_], Xtra:: [_]}. + +-spec store_tmp_contract(mfa(), file_line(), spec_data(), contracts(), types()) -> contracts(). -store_tmp_contract(MFA, FileLine, TypeSpec, SpecDict, RecordsDict) -> +store_tmp_contract(MFA, FileLine, {TypeSpec, Xtra}, SpecDict, RecordsDict) -> %% io:format("contract from form: ~p\n", [TypeSpec]), TmpContract = contract_from_form(TypeSpec, RecordsDict, FileLine), %% io:format("contract: ~p\n", [TmpContract]), - dict:store(MFA, {FileLine, TmpContract}, SpecDict). + dict:store(MFA, {FileLine, TmpContract, Xtra}, SpecDict). contract_from_form(Forms, RecDict, FileLine) -> {CFuns, Forms1} = contract_from_form(Forms, RecDict, FileLine, [], []), @@ -597,7 +599,7 @@ get_invalid_contract_warnings_modules([Mod|Mods], CodeServer, Plt, FindOpaques, get_invalid_contract_warnings_modules([], _CodeServer, _Plt, _FindOpaques, Acc) -> Acc. -get_invalid_contract_warnings_funs([{MFA, {FileLine, Contract}}|Left], +get_invalid_contract_warnings_funs([{MFA, {FileLine, Contract, _Xtra}}|Left], Plt, RecDict, FindOpaques, Acc) -> case dialyzer_plt:lookup(Plt, MFA) of none -> diff --git a/lib/dialyzer/src/dialyzer_dataflow.erl b/lib/dialyzer/src/dialyzer_dataflow.erl index 03005e689f..46467a1303 100644 --- a/lib/dialyzer/src/dialyzer_dataflow.erl +++ b/lib/dialyzer/src/dialyzer_dataflow.erl @@ -2781,8 +2781,7 @@ filter_match_fail([]) -> %%% =========================================================================== state__new(Callgraph, Tree, Plt, Module, Records) -> - Opaques = erl_types:module_builtin_opaques(Module) ++ - erl_types:t_opaque_from_records(Records), + Opaques = erl_types:t_opaque_from_records(Records), TreeMap = build_tree_map(Tree), Funs = dict:fetch_keys(TreeMap), FunTab = init_fun_tab(Funs, dict:new(), TreeMap, Callgraph, Plt), diff --git a/lib/dialyzer/src/dialyzer_plt.erl b/lib/dialyzer/src/dialyzer_plt.erl index 63798f44b1..7c970daf41 100644 --- a/lib/dialyzer/src/dialyzer_plt.erl +++ b/lib/dialyzer/src/dialyzer_plt.erl @@ -158,9 +158,7 @@ lookup_contract(#mini_plt{contracts = ETSContracts}, ets_table_lookup(ETSContracts, MFA). -spec lookup_callbacks(plt(), module()) -> - 'none' | {'value', [{mfa(), {{Filename::string(), - Line::pos_integer()}, - #contract{}}}]}. + 'none' | {'value', [{mfa(), dialyzer_contracts:file_contract()}]}. lookup_callbacks(#mini_plt{callbacks = ETSCallbacks}, Mod) when is_atom(Mod) -> ets_table_lookup(ETSCallbacks, Mod). @@ -618,9 +616,7 @@ table_insert_list(Plt, [{Key, Val}|Left]) -> table_insert_list(Plt, []) -> Plt. -table_insert(Plt, Key, {_Ret, _Arg} = Obj) -> - dict:store(Key, Obj, Plt); -table_insert(Plt, Key, #contract{} = C) -> +table_insert(Plt, Key, {_File, #contract{}, _Xtra} = C) -> dict:store(Key, C, Plt). table_lookup(Plt, Obj) -> diff --git a/lib/dialyzer/src/dialyzer_succ_typings.erl b/lib/dialyzer/src/dialyzer_succ_typings.erl index ef9b00e203..6dc4285194 100644 --- a/lib/dialyzer/src/dialyzer_succ_typings.erl +++ b/lib/dialyzer/src/dialyzer_succ_typings.erl @@ -201,7 +201,7 @@ postprocess_dataflow_warns([{?WARN_CONTRACT_RANGE, {CallF, CallL}, Msg}|Rest], Codeserver, WAcc, Acc) -> {contract_range, [Contract, M, F, A, ArgStrings, CRet]} = Msg, case dialyzer_codeserver:lookup_mfa_contract({M,F,A}, Codeserver) of - {ok, {{ContrF, _ContrL} = FileLine, _C}} -> + {ok, {{ContrF, _ContrL} = FileLine, _C, _X}} -> case CallF =:= ContrF of true -> NewMsg = {contract_range, [Contract, M, F, ArgStrings, CallL, CRet]}, @@ -401,7 +401,7 @@ decorate_succ_typings(Contracts, Callgraph, FunTypes, FindOpaques) -> case dialyzer_callgraph:lookup_name(Label, Callgraph) of {ok, MFA} -> case orddict:find(MFA, Contracts) of - {ok, {_FileLine, Contract}} -> + {ok, {_FileLine, Contract, _Xtra}} -> Args = dialyzer_contracts:get_contract_args(Contract), Ret = dialyzer_contracts:get_contract_return(Contract), C = erl_types:t_fun(Args, Ret), @@ -422,10 +422,7 @@ lookup_and_find_opaques_fun(Codeserver) -> end. find_opaques_fun(Records) -> - fun(Module) -> - erl_types:module_builtin_opaques(Module) ++ - erl_types:t_opaque_from_records(Records) - end. + fun(_Module) -> erl_types:t_opaque_from_records(Records) end. get_fun_types_from_plt(FunList, Callgraph, Plt) -> get_fun_types_from_plt(FunList, Callgraph, Plt, dict:new()). diff --git a/lib/dialyzer/src/dialyzer_utils.erl b/lib/dialyzer/src/dialyzer_utils.erl index 5297a3a7b4..e5f5c69d45 100644 --- a/lib/dialyzer/src/dialyzer_utils.erl +++ b/lib/dialyzer/src/dialyzer_utils.erl @@ -345,8 +345,26 @@ merge_records(NewRecords, OldRecords) -> {'ok', spec_dict(), callback_dict()} | {'error', string()}. get_spec_info(ModName, AbstractCode, RecordsDict) -> + OptionalCallbacks0 = get_optional_callbacks(AbstractCode, ModName), + OptionalCallbacks = gb_sets:from_list(OptionalCallbacks0), get_spec_info(AbstractCode, dict:new(), dict:new(), - RecordsDict, ModName, "nofile"). + RecordsDict, ModName, OptionalCallbacks, "nofile"). + +get_optional_callbacks(Abs, ModName) -> + [{ModName, F, A} || {F, A} <- get_optional_callbacks(Abs)]. + +get_optional_callbacks(Abs) -> + L = [O || + {attribute, _, optional_callbacks, O} <- Abs, + is_fa_list(O)], + lists:append(L). + +is_fa_list([{FuncName, Arity}|L]) + when is_atom(FuncName), is_integer(Arity), Arity >= 0 -> + is_fa_list(L); +is_fa_list([]) -> true; +is_fa_list(_) -> false. + %% TypeSpec is a list of conditional contracts for a function. %% Each contract is of the form {[Argument], Range, [Constraint]} where @@ -355,13 +373,14 @@ get_spec_info(ModName, AbstractCode, RecordsDict) -> %% are erl_types:erl_type() get_spec_info([{attribute, Ln, Contract, {Id, TypeSpec}}|Left], - SpecDict, CallbackDict, RecordsDict, ModName, File) + SpecDict, CallbackDict, RecordsDict, ModName, OptCb, File) when ((Contract =:= 'spec') or (Contract =:= 'callback')), is_list(TypeSpec) -> MFA = case Id of {_, _, _} = T -> T; {F, A} -> {ModName, F, A} end, + Xtra = [optional_callback || gb_sets:is_member(MFA, OptCb)], ActiveDict = case Contract of spec -> SpecDict; @@ -369,8 +388,9 @@ get_spec_info([{attribute, Ln, Contract, {Id, TypeSpec}}|Left], end, try dict:find(MFA, ActiveDict) of error -> + SpecData = {TypeSpec, Xtra}, NewActiveDict = - dialyzer_contracts:store_tmp_contract(MFA, {File, Ln}, TypeSpec, + dialyzer_contracts:store_tmp_contract(MFA, {File, Ln}, SpecData, ActiveDict, RecordsDict), {NewSpecDict, NewCallbackDict} = case Contract of @@ -378,8 +398,8 @@ get_spec_info([{attribute, Ln, Contract, {Id, TypeSpec}}|Left], callback -> {SpecDict, NewActiveDict} end, get_spec_info(Left, NewSpecDict, NewCallbackDict, - RecordsDict, ModName,File); - {ok, {{OtherFile, L},_C}} -> + RecordsDict, ModName, OptCb, File); + {ok, {{OtherFile, L}, _D}} -> {Mod, Fun, Arity} = MFA, Msg = flat_format(" Contract/callback for function ~w:~w/~w " "already defined in ~s:~w\n", @@ -391,13 +411,15 @@ get_spec_info([{attribute, Ln, Contract, {Id, TypeSpec}}|Left], [Ln, Error])} end; get_spec_info([{attribute, _, file, {IncludeFile, _}}|Left], - SpecDict, CallbackDict, RecordsDict, ModName, _File) -> + SpecDict, CallbackDict, RecordsDict, ModName, OptCb, _File) -> get_spec_info(Left, SpecDict, CallbackDict, - RecordsDict, ModName, IncludeFile); + RecordsDict, ModName, OptCb, IncludeFile); get_spec_info([_Other|Left], SpecDict, CallbackDict, - RecordsDict, ModName, File) -> - get_spec_info(Left, SpecDict, CallbackDict, RecordsDict, ModName, File); -get_spec_info([], SpecDict, CallbackDict, _RecordsDict, _ModName, _File) -> + RecordsDict, ModName, OptCb, File) -> + get_spec_info(Left, SpecDict, CallbackDict, + RecordsDict, ModName, OptCb, File); +get_spec_info([], SpecDict, CallbackDict, + _RecordsDict, _ModName, _OptCb, _File) -> {ok, SpecDict, CallbackDict}. %% ============================================================================ @@ -449,7 +471,6 @@ cleanup_compile_options(Opts) -> %% Using abstract, not asm or core. keep_compile_option(from_asm) -> false; -keep_compile_option(asm) -> false; keep_compile_option(from_core) -> false; %% The parse transform will already have been applied, may cause %% problems if it is re-applied. diff --git a/lib/dialyzer/test/behaviour_SUITE_data/results/supervisor_incorrect_return b/lib/dialyzer/test/behaviour_SUITE_data/results/supervisor_incorrect_return index e89caf3cf7..4103a2d8b4 100644 --- a/lib/dialyzer/test/behaviour_SUITE_data/results/supervisor_incorrect_return +++ b/lib/dialyzer/test/behaviour_SUITE_data/results/supervisor_incorrect_return @@ -1,2 +1,2 @@ -supervisor_incorrect_return.erl:14: The inferred return type of init/1 ({'ok',{{'one_against_one',0,1},[{_,_,_,_,_,_},...]}}) has nothing in common with 'ignore' | {'ok',{{'one_for_all',non_neg_integer(),non_neg_integer()} | {'one_for_one',non_neg_integer(),non_neg_integer()} | {'rest_for_one',non_neg_integer(),non_neg_integer()} | {'simple_one_for_one',non_neg_integer(),non_neg_integer()},[{_,{atom() | tuple(),atom(),'undefined' | [any()]},'permanent' | 'temporary' | 'transient','brutal_kill' | 'infinity' | non_neg_integer(),'supervisor' | 'worker','dynamic' | [atom() | tuple()]}]}}, which is the expected return type for the callback of supervisor behaviour +supervisor_incorrect_return.erl:14: The inferred return type of init/1 ({'ok',{{'one_against_one',0,1},[{_,_,_,_,_,_},...]}}) has nothing in common with 'ignore' | {'ok',{{'one_for_all',non_neg_integer(),pos_integer()} | {'one_for_one',non_neg_integer(),pos_integer()} | {'rest_for_one',non_neg_integer(),pos_integer()} | {'simple_one_for_one',non_neg_integer(),pos_integer()} | #{},[{_,{atom() | tuple(),atom(),'undefined' | [any()]},'permanent' | 'temporary' | 'transient','brutal_kill' | 'infinity' | non_neg_integer(),'supervisor' | 'worker','dynamic' | [atom() | tuple()]} | #{}]}}, which is the expected return type for the callback of supervisor behaviour diff --git a/lib/dialyzer/test/behaviour_SUITE_data/src/custom_sup.erl b/lib/dialyzer/test/behaviour_SUITE_data/src/custom_sup.erl index 76da1fda70..401ee88eab 100644 --- a/lib/dialyzer/test/behaviour_SUITE_data/src/custom_sup.erl +++ b/lib/dialyzer/test/behaviour_SUITE_data/src/custom_sup.erl @@ -13,7 +13,7 @@ -export([init/1]). -spec init(atom()) -> - {ok, {{supervisor:strategy(), non_neg_integer(), non_neg_integer()}, + {ok, {{supervisor:strategy(), non_neg_integer(), pos_integer()}, [supervisor:child_spec()]}} | ignore. init(StorageName) -> diff --git a/lib/dialyzer/test/small_SUITE_data/results/behaviour_info b/lib/dialyzer/test/small_SUITE_data/results/behaviour_info new file mode 100644 index 0000000000..2da4d26acb --- /dev/null +++ b/lib/dialyzer/test/small_SUITE_data/results/behaviour_info @@ -0,0 +1,2 @@ + +with_bad_format_status.erl:12: The inferred type for the 1st argument of format_status/2 ('bad_arg') is not a supertype of 'normal' | 'terminate', which is expected type for this argument in the callback of the gen_server behaviour diff --git a/lib/dialyzer/test/small_SUITE_data/src/behaviour_info/with_bad_format_status.erl b/lib/dialyzer/test/small_SUITE_data/src/behaviour_info/with_bad_format_status.erl new file mode 100644 index 0000000000..24591e08fa --- /dev/null +++ b/lib/dialyzer/test/small_SUITE_data/src/behaviour_info/with_bad_format_status.erl @@ -0,0 +1,12 @@ +-module(with_bad_format_status). + +-behaviour(gen_server). +-export([handle_call/3,handle_cast/2,handle_info/2, + code_change/3, init/1, terminate/2, format_status/2]). +handle_call(_, _, S) -> {noreply, S}. +handle_cast(_, S) -> {noreply, S}. +handle_info(_, S) -> {noreply, S}. +code_change(_, _, _) -> {error, not_implemented}. +init(_) -> {ok, state}. +terminate(_, _) -> ok. +format_status(bad_arg, _) -> ok. % optional callback diff --git a/lib/dialyzer/test/small_SUITE_data/src/behaviour_info/with_format_status.erl b/lib/dialyzer/test/small_SUITE_data/src/behaviour_info/with_format_status.erl new file mode 100644 index 0000000000..a56ff63d1d --- /dev/null +++ b/lib/dialyzer/test/small_SUITE_data/src/behaviour_info/with_format_status.erl @@ -0,0 +1,13 @@ +-module(with_format_status). + +-behaviour(gen_server). +-export([handle_call/3,handle_cast/2,handle_info/2, + code_change/3, init/1, terminate/2, format_status/2]). +-export([handle_call/3,handle_cast/2,handle_info/2]). +handle_call(_, _, S) -> {noreply, S}. +handle_cast(_, S) -> {noreply, S}. +handle_info(_, S) -> {noreply, S}. +code_change(_, _, _) -> {error, not_implemented}. +init(_) -> {ok, state}. +terminate(_, _) -> ok. +format_status(normal, _) -> ok. % optional callback diff --git a/lib/dialyzer/test/small_SUITE_data/src/predef2.erl b/lib/dialyzer/test/small_SUITE_data/src/predef2.erl deleted file mode 100644 index b1d941a49a..0000000000 --- a/lib/dialyzer/test/small_SUITE_data/src/predef2.erl +++ /dev/null @@ -1,56 +0,0 @@ --module(predef2). - --export([array/1, dict/1, digraph/1, digraph2/1, gb_set/1, gb_tree/1, - queue/1, set/1, tid/0, tid2/0]). - --export_type([array/0, digraph/0, gb_set/0]). - --spec array(array()) -> array:array(). - -array(A) -> - array:relax(A). - --spec dict(dict()) -> dict:dict(). - -dict(D) -> - dict:store(1, a, D). - --spec digraph(digraph()) -> [digraph:edge()]. - -digraph(G) -> - digraph:edges(G). - --spec digraph2(digraph:graph()) -> [digraph:edge()]. - -digraph2(G) -> - digraph:edges(G). - --spec gb_set(gb_set()) -> gb_sets:set(). - -gb_set(S) -> - gb_sets:balance(S). - --spec gb_tree(gb_tree()) -> gb_trees:tree(). - -gb_tree(S) -> - gb_trees:balance(S). - --spec queue(queue()) -> queue:queue(). - -queue(Q) -> - queue:reverse(Q). - --spec set(set()) -> sets:set(). - -set(S) -> - sets:union([S]). - --spec tid() -> tid(). - -tid() -> - ets:new(tid, []). - --spec tid2() -> ets:tid(). - -tid2() -> - ets:new(tid, []). diff --git a/lib/edoc/src/edoc_data.erl b/lib/edoc/src/edoc_data.erl index f88ba05f4b..eceb5cb1bd 100644 --- a/lib/edoc/src/edoc_data.erl +++ b/lib/edoc/src/edoc_data.erl @@ -173,21 +173,34 @@ callbacks(Es, Module, Env, Opts) -> lists:keymember(callback, 1, Module#module.attributes) of true -> - try (Module#module.name):behaviour_info(callbacks) of - Fs -> - Fs1 = [{F,A} || {F,A} <- Fs, is_atom(F), is_integer(A)], - if Fs1 =:= [] -> - []; - true -> - [{callbacks, - [callback(F, Env, Opts) || F <- Fs1]}] - end - catch - _:_ -> [] - end; + M = Module#module.name, + Fs = get_callback_functions(M, callbacks), + Os1 = get_callback_functions(M, optional_callbacks), + Fs1 = [FA || FA <- Fs, not lists:member(FA, Os1)], + Req = if Fs1 =:= [] -> + []; + true -> + [{callbacks, + [callback(FA, Env, Opts) || FA <- Fs1]}] + end, + Opt = if Os1 =:= [] -> + []; + true -> + [{optional_callbacks, + [callback(FA, Env, Opts) || FA <- Os1]}] + end, + Req ++ Opt; false -> [] end. +get_callback_functions(M, Callbacks) -> + try + [FA || {F, A} = FA <- M:behaviour_info(Callbacks), + is_atom(F), is_integer(A), A >= 0] + catch + _:_ -> [] + end. + %% <!ELEMENT callback EMPTY> %% <!ATTLIST callback %% name CDATA #REQUIRED diff --git a/lib/edoc/src/edoc_layout.erl b/lib/edoc/src/edoc_layout.erl index a102d432bc..36d067d9bc 100644 --- a/lib/edoc/src/edoc_layout.erl +++ b/lib/edoc/src/edoc_layout.erl @@ -701,6 +701,8 @@ deprecated(Es, S) -> end. behaviours(Es, Name) -> + CBs = get_content(callbacks, Es), + OCBs = get_content(optional_callbacks, Es), (case get_elem(behaviour, Es) of [] -> []; Es1 -> @@ -709,13 +711,24 @@ behaviours(Es, Name) -> ?NL] end ++ - case get_content(callbacks, Es) of - [] -> []; - Es1 -> + if CBs =:= [], OCBs =:= [] -> + []; + true -> + Req = if CBs =:= [] -> + []; + true -> + [br, " Required callback functions: "] + ++ seq(fun callback/1, CBs, ["."]) + end, + Opt = if OCBs =:= [] -> + []; + true -> + [br, " Optional callback functions: "] + ++ seq(fun callback/1, OCBs, ["."]) + end, [{p, ([{b, ["This module defines the ", {tt, [Name]}, - " behaviour."]}, - br, " Required callback functions: "] - ++ seq(fun callback/1, Es1, ["."]))}, + " behaviour."]}] + ++ Req ++ Opt)}, ?NL] end). diff --git a/lib/edoc/src/edoc_specs.erl b/lib/edoc/src/edoc_specs.erl index 211a354c74..3bf81c6503 100644 --- a/lib/edoc/src/edoc_specs.erl +++ b/lib/edoc/src/edoc_specs.erl @@ -362,7 +362,7 @@ d2e({type,_,map,any}) -> #t_map{ types = []}; d2e({type,_,map,Es}) -> #t_map{ types = d2e(Es) }; -d2e({type,_,map_field_assoc,K,V}) -> +d2e({type,_,map_field_assoc,[K,V]}) -> #t_map_field{ k_type = d2e(K), v_type=d2e(V) }; d2e({type,_,map_field_exact,K,V}) -> #t_map_field{ k_type = d2e(K), v_type=d2e(V) }; @@ -388,6 +388,9 @@ d2e({record_field,L,_Name}=F) -> d2e({type,_,Name,Types0}) -> Types = d2e(Types0), typevar_anno(#t_type{name = #t_name{name = Name}, args = Types}, Types); +d2e({user_type,_,Name,Types0}) -> + Types = d2e(Types0), + typevar_anno(#t_type{name = #t_name{name = Name}, args = Types}, Types); d2e({var,_,'_'}) -> #t_type{name = #t_name{name = ?TOP_TYPE}}; d2e({var,_,TypeName}) -> diff --git a/lib/edoc/src/edoc_tags.erl b/lib/edoc/src/edoc_tags.erl index 264a533a52..82a1b72d84 100644 --- a/lib/edoc/src/edoc_tags.erl +++ b/lib/edoc/src/edoc_tags.erl @@ -329,10 +329,7 @@ parse_typedef(Data, Line, _Env, Where) -> NAs = length(As), case edoc_types:is_predefined(T, NAs) of true -> - case - edoc_types:is_new_predefined(T, NAs) - orelse edoc_types:is_predefined_otp_type(T, NAs) - of + case edoc_types:is_new_predefined(T, NAs) of false -> throw_error(Line, {"redefining built-in type '~w'.", [T]}); @@ -499,7 +496,6 @@ check_used_type(#t_name{name = N, module = Mod}=Name, Args, P, LocalTypes) -> Mod =/= [] orelse lists:member(TypeName, ets:lookup(DT, Name)) orelse edoc_types:is_predefined(N, NArgs) - orelse edoc_types:is_predefined_otp_type(N, NArgs) orelse lists:member(TypeName, LocalTypes) of true -> diff --git a/lib/edoc/src/edoc_types.erl b/lib/edoc/src/edoc_types.erl index 8a6c8eb33e..65fba61a72 100644 --- a/lib/edoc/src/edoc_types.erl +++ b/lib/edoc/src/edoc_types.erl @@ -25,7 +25,7 @@ -module(edoc_types). --export([is_predefined/2, is_new_predefined/2, is_predefined_otp_type/2, +-export([is_predefined/2, is_new_predefined/2, to_ref/1, to_xml/2, to_label/1, arg_names/1, set_arg_names/2, arg_descs/1, range_desc/1]). @@ -34,67 +34,13 @@ -include("edoc_types.hrl"). -include_lib("xmerl/include/xmerl.hrl"). - -is_predefined(any, 0) -> true; -is_predefined(atom, 0) -> true; -is_predefined(binary, 0) -> true; -is_predefined(bool, 0) -> true; % kept for backwards compatibility -is_predefined(char, 0) -> true; is_predefined(cons, 2) -> true; is_predefined(deep_string, 0) -> true; -is_predefined(float, 0) -> true; -is_predefined(function, 0) -> true; -is_predefined(integer, 0) -> true; -is_predefined(list, 0) -> true; -is_predefined(list, 1) -> true; -is_predefined(nil, 0) -> true; -is_predefined(none, 0) -> true; -is_predefined(no_return, 0) -> true; -is_predefined(number, 0) -> true; -is_predefined(pid, 0) -> true; -is_predefined(port, 0) -> true; -is_predefined(reference, 0) -> true; -is_predefined(string, 0) -> true; -is_predefined(term, 0) -> true; -is_predefined(tuple, 0) -> true; -is_predefined(F, A) -> is_new_predefined(F, A). +is_predefined(F, A) -> erl_internal:is_type(F, A). -%% Should eventually be coalesced with is_predefined/2. -is_new_predefined(arity, 0) -> true; -is_new_predefined(bitstring, 0) -> true; -is_new_predefined(boolean, 0) -> true; -is_new_predefined(byte, 0) -> true; -is_new_predefined(iodata, 0) -> true; -is_new_predefined(iolist, 0) -> true; is_new_predefined(map, 0) -> true; -is_new_predefined(maybe_improper_list, 0) -> true; -is_new_predefined(maybe_improper_list, 2) -> true; -is_new_predefined(mfa, 0) -> true; -is_new_predefined(module, 0) -> true; -is_new_predefined(neg_integer, 0) -> true; -is_new_predefined(node, 0) -> true; -is_new_predefined(non_neg_integer, 0) -> true; -is_new_predefined(nonempty_improper_list, 2) -> true; -is_new_predefined(nonempty_list, 0) -> true; -is_new_predefined(nonempty_list, 1) -> true; -is_new_predefined(nonempty_maybe_improper_list, 0) -> true; -is_new_predefined(nonempty_maybe_improper_list, 2) -> true; -is_new_predefined(nonempty_string, 0) -> true; -is_new_predefined(pos_integer, 0) -> true; -is_new_predefined(timeout, 0) -> true; is_new_predefined(_, _) -> false. -%% The following types will be removed later, but they are currently -%% kind of built-in. -is_predefined_otp_type(array, 0) -> true; -is_predefined_otp_type(dict, 0) -> true; -is_predefined_otp_type(digraph, 0) -> true; -is_predefined_otp_type(gb_set, 0) -> true; -is_predefined_otp_type(gb_tree, 0) -> true; -is_predefined_otp_type(queue, 0) -> true; -is_predefined_otp_type(set, 0) -> true; -is_predefined_otp_type(_, _) -> false. - to_ref(#t_typedef{name = N}) -> to_ref(N); to_ref(#t_def{name = N}) -> @@ -129,8 +75,7 @@ to_xml(#t_type{name = N, args = As}, Env) -> Predef = case N of #t_name{module = [], name = T} -> NArgs = length(As), - (is_predefined(T, NArgs) - orelse is_predefined_otp_type(T, NArgs)); + is_predefined(T, NArgs); _ -> false end, diff --git a/lib/eldap/asn1/ELDAPv3.asn1 b/lib/eldap/asn1/ELDAPv3.asn1 index 72b87d7221..3fe7e815cc 100644 --- a/lib/eldap/asn1/ELDAPv3.asn1 +++ b/lib/eldap/asn1/ELDAPv3.asn1 @@ -274,5 +274,17 @@ IntermediateResponse ::= [APPLICATION 25] SEQUENCE { responseName [0] LDAPOID OPTIONAL, responseValue [1] OCTET STRING OPTIONAL } +-- Extended syntax for Password Modify (RFC 3062, Section 2) + +-- passwdModifyOID OBJECT IDENTIFIER ::= 1.3.6.1.4.1.4203.1.11.1 + +PasswdModifyRequestValue ::= SEQUENCE { + userIdentity [0] OCTET STRING OPTIONAL, + oldPasswd [1] OCTET STRING OPTIONAL, + newPasswd [2] OCTET STRING OPTIONAL } + +PasswdModifyResponseValue ::= SEQUENCE { + genPasswd [0] OCTET STRING OPTIONAL } + END diff --git a/lib/eldap/doc/src/eldap.xml b/lib/eldap/doc/src/eldap.xml index 4417551aa8..718a8afeec 100644 --- a/lib/eldap/doc/src/eldap.xml +++ b/lib/eldap/doc/src/eldap.xml @@ -214,6 +214,46 @@ filter() See present/1, substrings/2, </desc> </func> <func> + <name>modify_password(Handle, Dn, NewPasswd) -> ok | {ok, GenPasswd} | {error, Reason}</name> + <fsummary>Modify the password of a user.</fsummary> + <type> + <v>Dn = string()</v> + <v>NewPasswd = string()</v> + </type> + <desc> + <p>Modify the password of a user. See <seealso marker="#modify_password/4">modify_password/4</seealso>.</p> + </desc> + </func> + <func> + <name>modify_password(Handle, Dn, NewPasswd, OldPasswd) -> ok | {ok, GenPasswd} | {error, Reason}</name> + <fsummary>Modify the password of a user.</fsummary> + <type> + <v>Dn = string()</v> + <v>NewPasswd = string()</v> + <v>OldPasswd = string()</v> + <v>GenPasswd = string()</v> + </type> + <desc> + <p>Modify the password of a user.</p> + <list type="bulleted"> + <item> + <p><c>Dn</c>. The user to modify. Should be "" if the + modify request is for the user of the LDAP session.</p> + </item> + <item> + <p><c>NewPasswd</c>. The new password to set. Should be "" + if the server is to generate the password. In this case, + the result will be <c>{ok, GenPasswd}</c>.</p> + </item> + <item> + <p><c>OldPasswd</c>. Sometimes required by server policy + for a user to change their password. If not required, use + <seealso marker="#modify_password/3">modify_password/3</seealso>.</p> + </item> + </list> + </desc> + </func> + <func> <name>modify_dn(Handle, Dn, NewRDN, DeleteOldRDN, NewSupDN) -> ok | {error, Reason}</name> <fsummary>Modify the DN of an entry.</fsummary> <type> diff --git a/lib/eldap/src/eldap.erl b/lib/eldap/src/eldap.erl index 3fa440d37d..66f80d8d8f 100644 --- a/lib/eldap/src/eldap.erl +++ b/lib/eldap/src/eldap.erl @@ -12,6 +12,7 @@ -vc('$Id$ '). -export([open/1,open/2,simple_bind/3,controlling_process/2, start_tls/2, start_tls/3, + modify_password/3, modify_password/4, getopts/2, baseObject/0,singleLevel/0,wholeSubtree/0,close/1, equalityMatch/2,greaterOrEqual/2,lessOrEqual/2, @@ -94,6 +95,23 @@ start_tls(Handle, TlsOptions, Timeout) -> recv(Handle). %%% -------------------------------------------------------------------- +%%% Modify the password of a user. +%%% +%%% Dn - Name of the entry to modify. If empty, the session user. +%%% NewPasswd - New password. If empty, the server returns a new password. +%%% OldPasswd - Original password for server verification, may be empty. +%%% +%%% Returns: ok | {ok, GenPasswd} | {error, term()} +%%% -------------------------------------------------------------------- +modify_password(Handle, Dn, NewPasswd) -> + modify_password(Handle, Dn, NewPasswd, []). + +modify_password(Handle, Dn, NewPasswd, OldPasswd) + when is_pid(Handle), is_list(Dn), is_list(NewPasswd), is_list(OldPasswd) -> + send(Handle, {passwd_modify,optional(Dn),optional(NewPasswd),optional(OldPasswd)}), + recv(Handle). + +%%% -------------------------------------------------------------------- %%% Ask for option values on the socket. %%% Warning: This is an undocumented function for testing purposes only. %%% Use at own risk... @@ -505,6 +523,11 @@ loop(Cpid, Data) -> send(From,Res), ?MODULE:loop(Cpid, NewData); + {From, {passwd_modify,Dn,NewPasswd,OldPasswd}} -> + {Res,NewData} = do_passwd_modify(Data, Dn, NewPasswd, OldPasswd), + send(From, Res), + ?MODULE:loop(Cpid, NewData); + {_From, close} -> unlink(Cpid), exit(closed); @@ -795,6 +818,60 @@ do_modify_0(Data, Obj, Mod) -> check_reply(Data#eldap{id = Id}, Resp, modifyResponse). %%% -------------------------------------------------------------------- +%%% PasswdModifyRequest +%%% -------------------------------------------------------------------- + +-define(PASSWD_MODIFY_OID, "1.3.6.1.4.1.4203.1.11.1"). + +do_passwd_modify(Data, Dn, NewPasswd, OldPasswd) -> + case catch do_passwd_modify_0(Data, Dn, NewPasswd, OldPasswd) of + {error,Emsg} -> {ldap_closed_p(Data, Emsg),Data}; + {'EXIT',Error} -> {ldap_closed_p(Data, Error),Data}; + {ok,NewData} -> {ok,NewData}; + {ok,Passwd,NewData} -> {{ok, Passwd},NewData}; + Else -> {ldap_closed_p(Data, Else),Data} + end. + +do_passwd_modify_0(Data, Dn, NewPasswd, OldPasswd) -> + Req = #'PasswdModifyRequestValue'{userIdentity = Dn, + oldPasswd = OldPasswd, + newPasswd = NewPasswd}, + log2(Data, "modify password request = ~p~n", [Req]), + {ok, Bytes} = 'ELDAPv3':encode('PasswdModifyRequestValue', Req), + ExtReq = #'ExtendedRequest'{requestName = ?PASSWD_MODIFY_OID, + requestValue = Bytes}, + Id = bump_id(Data), + log2(Data, "extended request = ~p~n", [ExtReq]), + Reply = request(Data#eldap.fd, Data, Id, {extendedReq, ExtReq}), + log2(Data, "modify password reply = ~p~n", [Reply]), + exec_passwd_modify_reply(Data#eldap{id = Id}, Reply). + +exec_passwd_modify_reply(Data, {ok,Msg}) when + Msg#'LDAPMessage'.messageID == Data#eldap.id -> + case Msg#'LDAPMessage'.protocolOp of + {extendedResp, Result} -> + case Result#'ExtendedResponse'.resultCode of + success -> + case Result#'ExtendedResponse'.responseValue of + asn1_NOVALUE -> + {ok, Data}; + Value -> + case 'ELDAPv3':decode('PasswdModifyResponseValue', Value) of + {ok,#'PasswdModifyResponseValue'{genPasswd = Passwd}} -> + {ok, Passwd, Data}; + Error -> + throw(Error) + end + end; + Error -> + {error, {response,Error}} + end; + Other -> {error, Other} + end; +exec_passwd_modify_reply(_, Error) -> + {error, Error}. + +%%% -------------------------------------------------------------------- %%% modifyDNRequest %%% -------------------------------------------------------------------- diff --git a/lib/eldap/test/eldap_basic_SUITE.erl b/lib/eldap/test/eldap_basic_SUITE.erl index d87f3ac4ac..7f2be54b71 100644 --- a/lib/eldap/test/eldap_basic_SUITE.erl +++ b/lib/eldap/test/eldap_basic_SUITE.erl @@ -200,6 +200,7 @@ do_api_checks(H, Config) -> chk_add(H, BasePath), {ok,FB} = chk_search(H, BasePath), chk_modify(H, FB), + chk_modify_password(H, FB), chk_delete(H, BasePath), chk_modify_dn(H, FB). @@ -250,6 +251,23 @@ chk_modify(H, FB) -> %% DELETE ATTR ok = eldap:modify(H, FB, [eldap:mod_delete("telephoneNumber", [])]). +chk_modify_password(H, FB) -> + %% Change password, and ensure we can bind with it. + ok = eldap:simple_bind(H, "cn=Manager,dc=ericsson,dc=se", "hejsan"), + ok = eldap:modify_password(H, FB, "example"), + ok = eldap:simple_bind(H, FB, "example"), + %% Change password to a server generated value. + ok = eldap:simple_bind(H, "cn=Manager,dc=ericsson,dc=se", "hejsan"), + {ok, Passwd} = eldap:modify_password(H, FB, []), + ok = eldap:simple_bind(H, FB, Passwd), + %% Change own password to server generated value. + {ok, NewPasswd} = eldap:modify_password(H, [], [], Passwd), + ok = eldap:simple_bind(H, FB, NewPasswd), + %% Change own password to explicit value. + ok = eldap:modify_password(H, [], "example", NewPasswd), + ok = eldap:simple_bind(H, FB, "example"), + %% Restore original binding. + ok = eldap:simple_bind(H, "cn=Manager,dc=ericsson,dc=se", "hejsan"). chk_delete(H, BasePath) -> {error, entryAlreadyExists} = eldap:add(H, "cn=Jonas Jonsson," ++ BasePath, diff --git a/lib/erl_docgen/src/docgen_otp_specs.erl b/lib/erl_docgen/src/docgen_otp_specs.erl index 1075c47801..e2eee2b3c0 100644 --- a/lib/erl_docgen/src/docgen_otp_specs.erl +++ b/lib/erl_docgen/src/docgen_otp_specs.erl @@ -616,7 +616,7 @@ ot_map(Es) -> {type,0,map,[ot_map_field(E) || E <- get_elem(map_field,Es)]}. ot_map_field(#xmlElement{content=[K,V]}) -> - {type,0,map_field_assoc, ot_utype_elem(K), ot_utype_elem(V)}. + {type,0,map_field_assoc,[ot_utype_elem(K),ot_utype_elem(V)]}. ot_fun(Es) -> Range = ot_utype(get_elem(type, Es)), diff --git a/lib/hipe/cerl/erl_types.erl b/lib/hipe/cerl/erl_types.erl index 4b2bec5fa8..5124e7238a 100644 --- a/lib/hipe/cerl/erl_types.erl +++ b/lib/hipe/cerl/erl_types.erl @@ -40,7 +40,6 @@ any_none_or_unit/1, lookup_record/3, max/2, - module_builtin_opaques/1, min/2, number_max/1, number_max/2, number_min/1, number_min/2, @@ -188,7 +187,6 @@ t_subtract_list/2, t_sup/1, t_sup/2, - t_tid/0, t_timeout/0, t_to_string/1, t_to_string/2, @@ -466,16 +464,6 @@ has_opaque_subtype(T) -> t_opaque_structure(?opaque(Elements)) -> t_sup([Struct || #opaque{struct = Struct} <- ordsets:to_list(Elements)]). --spec t_opaque_modules(erl_type()) -> [module()]. - -t_opaque_modules(?opaque(Elements)) -> - case ordsets:size(Elements) of - 1 -> - [#opaque{mod = Mod}] = set_to_list(Elements), - [Mod]; - _ -> throw({error, "Unexpected multiple opaque types"}) - end. - -spec t_contains_opaque(erl_type()) -> boolean(). t_contains_opaque(Type) -> @@ -801,11 +789,6 @@ t_struct_from_opaque(Type, _Opaques) -> Type. list_struct_from_opaque(Types, Opaques) -> [t_struct_from_opaque(Type, Opaques) || Type <- Types]. --spec module_builtin_opaques(module()) -> [erl_type()]. - -module_builtin_opaques(Module) -> - [O || O <- all_opaque_builtins(), lists:member(Module, t_opaque_modules(O))]. - %%----------------------------------------------------------------------------- %% Remote types: these types are used for preprocessing; %% they should never reach the analysis stage. @@ -1987,82 +1970,6 @@ t_parameterized_module() -> t_timeout() -> t_sup(t_non_neg_integer(), t_atom('infinity')). -%%----------------------------------------------------------------------------- -%% Some built-in opaque types -%% - --spec t_array() -> erl_type(). - -t_array() -> - t_opaque(array, array, [t_any()], - t_tuple([t_atom('array'), - t_sup([t_atom('undefined'), t_non_neg_integer()]), - t_sup([t_atom('undefined'), t_non_neg_integer()]), - t_any(), - t_any()])). - --spec t_dict() -> erl_type(). - -t_dict() -> - t_opaque(dict, dict, [t_any(), t_any()], - t_tuple([t_atom('dict'), - t_sup([t_atom('undefined'), t_non_neg_integer()]), - t_sup([t_atom('undefined'), t_non_neg_integer()]), - t_sup([t_atom('undefined'), t_non_neg_integer()]), - t_sup([t_atom('undefined'), t_non_neg_integer()]), - t_sup([t_atom('undefined'), t_non_neg_integer()]), - t_sup([t_atom('undefined'), t_non_neg_integer()]), - t_sup([t_atom('undefined'), t_tuple()]), - t_sup([t_atom('undefined'), t_tuple()])])). - --spec t_digraph() -> erl_type(). - -t_digraph() -> - t_opaque(digraph, digraph, [], - t_tuple([t_atom('digraph'), - t_sup(t_atom(), t_tid()), - t_sup(t_atom(), t_tid()), - t_sup(t_atom(), t_tid()), - t_boolean()])). - --spec t_gb_set() -> erl_type(). - -t_gb_set() -> - t_opaque(gb_sets, gb_set, [], - t_tuple([t_non_neg_integer(), t_sup(t_atom('nil'), t_tuple(3))])). - --spec t_gb_tree() -> erl_type(). - -t_gb_tree() -> - t_opaque(gb_trees, gb_tree, [], - t_tuple([t_non_neg_integer(), t_sup(t_atom('nil'), t_tuple(4))])). - --spec t_queue() -> erl_type(). - -t_queue() -> - t_opaque(queue, queue, [t_any()], t_tuple([t_list(), t_list()])). - --spec t_set() -> erl_type(). - -t_set() -> - t_opaque(sets, set, [t_any()], - t_tuple([t_atom('set'), t_non_neg_integer(), t_non_neg_integer(), - t_pos_integer(), t_non_neg_integer(), t_non_neg_integer(), - t_non_neg_integer(), - t_sup([t_atom('undefined'), t_tuple()]), - t_sup([t_atom('undefined'), t_tuple()])])). - --spec t_tid() -> erl_type(). - -t_tid() -> - t_opaque(ets, tid, [], t_integer()). - --spec all_opaque_builtins() -> [erl_type(),...]. - -all_opaque_builtins() -> - [t_array(), t_dict(), t_digraph(), t_gb_set(), - t_gb_tree(), t_queue(), t_set(), t_tid()]. - %%------------------------------------ %% ?none is allowed in products. A product of size 1 is not a product. @@ -3317,8 +3224,8 @@ is_opaque_type2(#opaque{mod = Mod1, name = Name1, args = Args1}, Opaques) -> is_type_name(Mod, Name, Args1, Mod, Name, Args2) -> length(Args1) =:= length(Args2); -is_type_name(Mod1, Name1, Args1, Mod2, Name2, Args2) -> - is_same_type_name2(Mod1, Name1, Args1, Mod2, Name2, Args2). +is_type_name(_Mod1, _Name1, _Args1, _Mod2, _Name2, _Args2) -> + false. %% Two functions since t_unify is not symmetric. unify_tuple_set_and_tuple1(?tuple_set([{Arity, List}]), @@ -4156,15 +4063,7 @@ opaque_name(Mod, Name, Extra) -> flat_format("~s(~s)", [S, Extra]). mod_name(Mod, Name) -> - case is_obsolete_opaque_builtin(Mod, Name) of - true -> flat_format("~w", [Name]); - false -> flat_format("~w:~w", [Mod, Name]) - end. - -is_obsolete_opaque_builtin(digraph, digraph) -> true; -is_obsolete_opaque_builtin(gb_sets, gb_set) -> true; -is_obsolete_opaque_builtin(gb_trees, gb_tree) -> true; -is_obsolete_opaque_builtin(_, _) -> false. + flat_format("~w:~w", [Mod, Name]). %%============================================================================= %% @@ -4229,8 +4128,6 @@ t_from_form({type, _L, any, []}, _TypeNames, _RecDict, _VarDict) -> {t_any(), []}; t_from_form({type, _L, arity, []}, _TypeNames, _RecDict, _VarDict) -> {t_arity(), []}; -t_from_form({type, _L, array, []}, TypeNames, RecDict, VarDict) -> - builtin_type(array, t_array(), TypeNames, RecDict, VarDict); t_from_form({type, _L, atom, []}, _TypeNames, _RecDict, _VarDict) -> {t_atom(), []}; t_from_form({type, _L, binary, []}, _TypeNames, _RecDict, _VarDict) -> @@ -4252,10 +4149,6 @@ t_from_form({type, _L, byte, []}, _TypeNames, _RecDict, _VarDict) -> {t_byte(), []}; t_from_form({type, _L, char, []}, _TypeNames, _RecDict, _VarDict) -> {t_char(), []}; -t_from_form({type, _L, dict, []}, TypeNames, RecDict, VarDict) -> - builtin_type(dict, t_dict(), TypeNames, RecDict, VarDict); -t_from_form({type, _L, digraph, []}, TypeNames, RecDict, VarDict) -> - builtin_type(digraph, t_digraph(), TypeNames, RecDict, VarDict); t_from_form({type, _L, float, []}, _TypeNames, _RecDict, _VarDict) -> {t_float(), []}; t_from_form({type, _L, function, []}, _TypeNames, _RecDict, _VarDict) -> @@ -4271,10 +4164,6 @@ t_from_form({type, _L, 'fun', [{type, _, product, Domain}, Range]}, {L, R1} = list_from_form(Domain, TypeNames, RecDict, VarDict), {T, R2} = t_from_form(Range, TypeNames, RecDict, VarDict), {t_fun(L, T), R1 ++ R2}; -t_from_form({type, _L, gb_set, []}, TypeNames, RecDict, VarDict) -> - builtin_type(gb_set, t_gb_set(), TypeNames, RecDict, VarDict); -t_from_form({type, _L, gb_tree, []}, TypeNames, RecDict, VarDict) -> - builtin_type(gb_tree, t_gb_tree(), TypeNames, RecDict, VarDict); t_from_form({type, _L, identifier, []}, _TypeNames, _RecDict, _VarDict) -> {t_identifier(), []}; t_from_form({type, _L, integer, []}, _TypeNames, _RecDict, _VarDict) -> @@ -4347,8 +4236,6 @@ t_from_form({type, _L, maybe_improper_list, [Content, Termination]}, t_from_form({type, _L, product, Elements}, TypeNames, RecDict, VarDict) -> {L, R} = list_from_form(Elements, TypeNames, RecDict, VarDict), {t_product(L), R}; -t_from_form({type, _L, queue, []}, TypeNames, RecDict, VarDict) -> - builtin_type(queue, t_queue(), TypeNames, RecDict, VarDict); t_from_form({type, _L, range, [From, To]} = Type, _TypeNames, _RecDict, _VarDict) -> case {erl_eval:partial_eval(From), erl_eval:partial_eval(To)} of @@ -4360,14 +4247,10 @@ t_from_form({type, _L, record, [Name|Fields]}, TypeNames, RecDict, VarDict) -> record_from_form(Name, Fields, TypeNames, RecDict, VarDict); t_from_form({type, _L, reference, []}, _TypeNames, _RecDict, _VarDict) -> {t_reference(), []}; -t_from_form({type, _L, set, []}, TypeNames, RecDict, VarDict) -> - builtin_type(set, t_set(), TypeNames, RecDict, VarDict); t_from_form({type, _L, string, []}, _TypeNames, _RecDict, _VarDict) -> {t_string(), []}; t_from_form({type, _L, term, []}, _TypeNames, _RecDict, _VarDict) -> {t_any(), []}; -t_from_form({type, _L, tid, []}, TypeNames, RecDict, VarDict) -> - builtin_type(tid, t_tid(), TypeNames, RecDict, VarDict); t_from_form({type, _L, timeout, []}, _TypeNames, _RecDict, _VarDict) -> {t_timeout(), []}; t_from_form({type, _L, tuple, any}, _TypeNames, _RecDict, _VarDict) -> @@ -4378,7 +4261,10 @@ t_from_form({type, _L, tuple, Args}, TypeNames, RecDict, VarDict) -> t_from_form({type, _L, union, Args}, TypeNames, RecDict, VarDict) -> {L, R} = list_from_form(Args, TypeNames, RecDict, VarDict), {t_sup(L), R}; +t_from_form({user_type, _L, Name, Args}, TypeNames, RecDict, VarDict) -> + type_from_form(Name, Args, TypeNames, RecDict, VarDict); t_from_form({type, _L, Name, Args}, TypeNames, RecDict, VarDict) -> + %% Compatibility: modules compiled before Erlang/OTP 18.0. type_from_form(Name, Args, TypeNames, RecDict, VarDict); t_from_form({opaque, _L, Name, {Mod, Args, Rep}}, _TypeNames, _RecDict, _VarDict) -> @@ -4622,9 +4508,12 @@ t_form_to_string({type, _L, Name, []} = T) -> try t_to_string(t_from_form(T)) catch throw:{error, _} -> atom_to_string(Name) ++ "()" end; -t_form_to_string({type, _L, Name, List}) -> +t_form_to_string({user_type, _L, Name, List}) -> flat_format("~w(~s)", - [Name, string:join(t_form_to_string_list(List), ",")]). + [Name, string:join(t_form_to_string_list(List), ",")]); +t_form_to_string({type, L, Name, List}) -> + %% Compatibility: modules compiled before Erlang/OTP 18.0. + t_form_to_string({user_type, L, Name, List}). t_form_to_string_list(List) -> t_form_to_string_list(List, []). @@ -4737,27 +4626,14 @@ do_opaque(Type, _Opaques, Pred) -> is_same_type_name(ModNameArgs, ModNameArgs) -> true; is_same_type_name({Mod, Name, Args1}, {Mod, Name, Args2}) -> all_any(Args1) orelse all_any(Args2); -is_same_type_name({Mod1, Name1, Args1}, {Mod2, Name2, Args2}) -> - is_same_type_name2(Mod1, Name1, Args1, Mod2, Name2, Args2). +is_same_type_name(_ModNameArgs1, _ModNameArgs2) -> + false. all_any([]) -> true; all_any([T|L]) -> t_is_any(T) andalso all_any(L); all_any(_) -> false. -%% Compatibility. In Erlang/OTP 17 the pre-defined opaque types -%% digraph() and so on can be used, but there are also new types such -%% as digraph:graph() with the exact same meaning. In Erlang/OTP R18.0 -%% all but the last clause can be removed. - -is_same_type_name2(digraph, digraph, [], digraph, graph, []) -> true; -is_same_type_name2(digraph, graph, [], digraph, digraph, []) -> true; -is_same_type_name2(gb_sets, gb_set, [], gb_sets, set, [_]) -> true; -is_same_type_name2(gb_sets, set, [_], gb_sets, gb_set, []) -> true; -is_same_type_name2(gb_trees, gb_tree, [], gb_trees, tree, [_, _]) -> true; -is_same_type_name2(gb_trees, tree, [_, _], gb_trees, gb_tree, []) -> true; -is_same_type_name2(_, _, _, _, _, _) -> false. - map_keys(?map(Pairs)) -> [K || {K, _} <- Pairs]. diff --git a/lib/inets/src/http_client/httpc_handler.erl b/lib/inets/src/http_client/httpc_handler.erl index 0bbd40d656..0a42e7210c 100644 --- a/lib/inets/src/http_client/httpc_handler.erl +++ b/lib/inets/src/http_client/httpc_handler.erl @@ -1850,6 +1850,7 @@ update_session(ProfileName, #session{id = SessionId} = Session, Pos, Value) -> Session2 = erlang:setelement(Pos, Session, Value), insert_session(Session2, ProfileName); T:E -> + Stacktrace = erlang:get_stacktrace(), error_logger:error_msg("Failed updating session: " "~n ProfileName: ~p" "~n SessionId: ~p" @@ -1873,7 +1874,7 @@ update_session(ProfileName, #session{id = SessionId} = Session, Pos, Value) -> {value, Value}, {etype, T}, {error, E}, - {stacktrace, erlang:get_stacktrace()}]}) + {stacktrace, Stacktrace}]}) end. diff --git a/lib/kernel/doc/src/file.xml b/lib/kernel/doc/src/file.xml index dcb9640dcf..338d62e82b 100644 --- a/lib/kernel/doc/src/file.xml +++ b/lib/kernel/doc/src/file.xml @@ -1693,9 +1693,9 @@ <desc> <p>Makes sure that any buffers kept by the operating system (not by the Erlang runtime system) are written to disk. In - many ways it's resembles fsync but it not requires to update - some of file's metadata such as the access time. On - some platforms, this function might have no effect.</p> + many ways it resembles fsync but it does not update + some of the file's metadata such as the access time. On + some platforms this function has no effect.</p> <p>Applications that access databases or log files often write a tiny data fragment (e.g., one line in a log file) and then call fsync() immediately in order to ensure that the written @@ -1703,11 +1703,11 @@ will always initiate two write operations: one for the newly written data and another one in order to update the modification time stored in the inode. If the modification time is not a part - of the transaction concept fdatasync() can be used to avoid + of the transaction concept, fdatasync() can be used to avoid unnecessary inode disk write operations.</p> - <p>Available only in some POSIX systems. This call results in a - call to fsync(), or has no effect, in systems not implementing - the fdatasync syscall.</p> + <p>Available only in some POSIX systems, this call results in a + call to fsync(), or has no effect in systems not implementing + the fdatasync() syscall.</p> </desc> </func> <func> diff --git a/lib/kernel/doc/src/pg2.xml b/lib/kernel/doc/src/pg2.xml index 5eb63c1ef6..35cf85470a 100644 --- a/lib/kernel/doc/src/pg2.xml +++ b/lib/kernel/doc/src/pg2.xml @@ -34,11 +34,8 @@ <module>pg2</module> <modulesummary>Distributed Named Process Groups</modulesummary> <description> - <p>This module implements process groups. The groups in this - module differ from the groups in the module <c>pg</c> in several - ways. In <c>pg</c>, each message is sent to all members in the - group. In this module, each message may be sent to one, some, or - all members. + <p>This module implements process groups. Each message may be sent + to one, some, or all members of the group. </p> <p>A group of processes can be accessed by a common name. For example, if there is a group named <c>foobar</c>, there can be a @@ -160,8 +157,7 @@ <section> <title>See Also</title> - <p><seealso marker="kernel_app">kernel(6)</seealso>, - <seealso marker="stdlib:pg">pg(3)</seealso></p> + <p><seealso marker="kernel_app">kernel(6)</seealso></p> </section> </erlref> diff --git a/lib/kernel/src/file.erl b/lib/kernel/src/file.erl index 3d6665a36a..b6b153ae56 100644 --- a/lib/kernel/src/file.erl +++ b/lib/kernel/src/file.erl @@ -445,21 +445,15 @@ open(Item, ModeList) when is_list(ModeList) -> case lists:member(raw, ModeList) of %% Raw file, use ?PRIM_FILE to handle this file true -> - %% check if raw file mode is disabled - case catch application:get_env(kernel, raw_files) of - {ok,false} -> - open(Item, lists:delete(raw, ModeList)); - _ -> % undefined | {ok,true} - Args = [file_name(Item) | ModeList], - case check_args(Args) of - ok -> - [FileName | _] = Args, - %% We rely on the returned Handle (in {ok, Handle}) - %% being a pid() or a #file_descriptor{} - ?PRIM_FILE:open(FileName, ModeList); - Error -> - Error - end + Args = [file_name(Item) | ModeList], + case check_args(Args) of + ok -> + [FileName | _] = Args, + %% We rely on the returned Handle (in {ok, Handle}) + %% being a pid() or a #file_descriptor{} + ?PRIM_FILE:open(FileName, ModeList); + Error -> + Error end; false -> case lists:member(ram, ModeList) of diff --git a/lib/kernel/src/group.erl b/lib/kernel/src/group.erl index b36dbf33dd..046885f885 100644 --- a/lib/kernel/src/group.erl +++ b/lib/kernel/src/group.erl @@ -111,8 +111,13 @@ start_shell1(Fun) -> server_loop(Drv, Shell, Buf0) -> receive {io_request,From,ReplyAs,Req} when is_pid(From) -> - Buf = io_request(Req, From, ReplyAs, Drv, Buf0), - server_loop(Drv, Shell, Buf); + %% This io_request may cause a transition to a couple of + %% selective receive loops elsewhere in this module. + Buf = io_request(Req, From, ReplyAs, Drv, Buf0), + server_loop(Drv, Shell, Buf); + {reply,{{From,ReplyAs},Reply}} -> + io_reply(From, ReplyAs, Reply), + server_loop(Drv, Shell, Buf0); {driver_id,ReplyTo} -> ReplyTo ! {self(),driver_id,Drv}, server_loop(Drv, Shell, Buf0); @@ -172,10 +177,13 @@ set_unicode_state(Drv,Bool) -> io_request(Req, From, ReplyAs, Drv, Buf0) -> - case io_request(Req, Drv, Buf0) of + case io_request(Req, Drv, {From,ReplyAs}, Buf0) of {ok,Reply,Buf} -> io_reply(From, ReplyAs, Reply), Buf; + {noreply,Buf} -> + %% We expect a {reply,_} message from the Drv when request is done + Buf; {error,Reply,Buf} -> io_reply(From, ReplyAs, Reply), Buf; @@ -196,78 +204,85 @@ io_request(Req, From, ReplyAs, Drv, Buf0) -> %% io_request({put_chars,unicode,Binary}, Drv, Buf) when is_binary(Binary) -> %% send_drv(Drv, {put_chars,Binary}), %% {ok,ok,Buf}; -io_request({put_chars,unicode,Chars}, Drv, Buf) -> +%% +%% These put requests have to be synchronous to the driver as otherwise +%% there is no guarantee that the data has actually been printed. +io_request({put_chars,unicode,Chars}, Drv, From, Buf) -> case catch unicode:characters_to_binary(Chars,utf8) of Binary when is_binary(Binary) -> - send_drv(Drv, {put_chars, unicode, Binary}), - {ok,ok,Buf}; + send_drv(Drv, {put_chars_sync, unicode, Binary, {From,ok}}), + {noreply,Buf}; _ -> {error,{error,{put_chars, unicode,Chars}},Buf} end; -io_request({put_chars,unicode,M,F,As}, Drv, Buf) -> +io_request({put_chars,unicode,M,F,As}, Drv, From, Buf) -> case catch apply(M, F, As) of Binary when is_binary(Binary) -> - send_drv(Drv, {put_chars, unicode,Binary}), - {ok,ok,Buf}; + send_drv(Drv, {put_chars_sync, unicode, Binary, {From,ok}}), + {noreply,Buf}; Chars -> case catch unicode:characters_to_binary(Chars,utf8) of B when is_binary(B) -> - send_drv(Drv, {put_chars, unicode,B}), - {ok,ok,Buf}; + send_drv(Drv, {put_chars_sync, unicode, B, {From,ok}}), + {noreply,Buf}; _ -> {error,{error,F},Buf} end end; -io_request({put_chars,latin1,Binary}, Drv, Buf) when is_binary(Binary) -> - send_drv(Drv, {put_chars, unicode,unicode:characters_to_binary(Binary,latin1)}), - {ok,ok,Buf}; -io_request({put_chars,latin1,Chars}, Drv, Buf) -> +io_request({put_chars,latin1,Binary}, Drv, From, Buf) when is_binary(Binary) -> + send_drv(Drv, {put_chars_sync, unicode, + unicode:characters_to_binary(Binary,latin1), + {From,ok}}), + {noreply,Buf}; +io_request({put_chars,latin1,Chars}, Drv, From, Buf) -> case catch unicode:characters_to_binary(Chars,latin1) of Binary when is_binary(Binary) -> - send_drv(Drv, {put_chars, unicode,Binary}), - {ok,ok,Buf}; + send_drv(Drv, {put_chars_sync, unicode, Binary, {From,ok}}), + {noreply,Buf}; _ -> {error,{error,{put_chars,latin1,Chars}},Buf} end; -io_request({put_chars,latin1,M,F,As}, Drv, Buf) -> +io_request({put_chars,latin1,M,F,As}, Drv, From, Buf) -> case catch apply(M, F, As) of Binary when is_binary(Binary) -> - send_drv(Drv, {put_chars, unicode,unicode:characters_to_binary(Binary,latin1)}), - {ok,ok,Buf}; + send_drv(Drv, {put_chars_sync, unicode, + unicode:characters_to_binary(Binary,latin1), + {From,ok}}), + {noreply,Buf}; Chars -> case catch unicode:characters_to_binary(Chars,latin1) of B when is_binary(B) -> - send_drv(Drv, {put_chars, unicode,B}), - {ok,ok,Buf}; + send_drv(Drv, {put_chars_sync, unicode, B, {From,ok}}), + {noreply,Buf}; _ -> {error,{error,F},Buf} end end; -io_request({get_chars,Encoding,Prompt,N}, Drv, Buf) -> +io_request({get_chars,Encoding,Prompt,N}, Drv, _From, Buf) -> get_chars(Prompt, io_lib, collect_chars, N, Drv, Buf, Encoding); -io_request({get_line,Encoding,Prompt}, Drv, Buf) -> +io_request({get_line,Encoding,Prompt}, Drv, _From, Buf) -> get_chars(Prompt, io_lib, collect_line, [], Drv, Buf, Encoding); -io_request({get_until,Encoding, Prompt,M,F,As}, Drv, Buf) -> +io_request({get_until,Encoding, Prompt,M,F,As}, Drv, _From, Buf) -> get_chars(Prompt, io_lib, get_until, {M,F,As}, Drv, Buf, Encoding); -io_request({get_password,_Encoding},Drv,Buf) -> +io_request({get_password,_Encoding},Drv,_From,Buf) -> get_password_chars(Drv, Buf); -io_request({setopts,Opts}, Drv, Buf) when is_list(Opts) -> +io_request({setopts,Opts}, Drv, _From, Buf) when is_list(Opts) -> setopts(Opts, Drv, Buf); -io_request(getopts, Drv, Buf) -> +io_request(getopts, Drv, _From, Buf) -> getopts(Drv, Buf); -io_request({requests,Reqs}, Drv, Buf) -> - io_requests(Reqs, {ok,ok,Buf}, Drv); +io_request({requests,Reqs}, Drv, From, Buf) -> + io_requests(Reqs, {ok,ok,Buf}, From, Drv); %% New in R12 -io_request({get_geometry,columns},Drv,Buf) -> +io_request({get_geometry,columns},Drv,_From,Buf) -> case get_tty_geometry(Drv) of {W,_H} -> {ok,W,Buf}; _ -> {error,{error,enotsup},Buf} end; -io_request({get_geometry,rows},Drv,Buf) -> +io_request({get_geometry,rows},Drv,_From,Buf) -> case get_tty_geometry(Drv) of {_W,H} -> {ok,H,Buf}; @@ -276,38 +291,49 @@ io_request({get_geometry,rows},Drv,Buf) -> end; %% BC with pre-R13 -io_request({put_chars,Chars}, Drv, Buf) -> - io_request({put_chars,latin1,Chars}, Drv, Buf); -io_request({put_chars,M,F,As}, Drv, Buf) -> - io_request({put_chars,latin1,M,F,As}, Drv, Buf); -io_request({get_chars,Prompt,N}, Drv, Buf) -> - io_request({get_chars,latin1,Prompt,N}, Drv, Buf); -io_request({get_line,Prompt}, Drv, Buf) -> - io_request({get_line,latin1,Prompt}, Drv, Buf); -io_request({get_until, Prompt,M,F,As}, Drv, Buf) -> - io_request({get_until,latin1, Prompt,M,F,As}, Drv, Buf); -io_request(get_password,Drv,Buf) -> - io_request({get_password,latin1},Drv,Buf); - - - -io_request(_, _Drv, Buf) -> +io_request({put_chars,Chars}, Drv, From, Buf) -> + io_request({put_chars,latin1,Chars}, Drv, From, Buf); +io_request({put_chars,M,F,As}, Drv, From, Buf) -> + io_request({put_chars,latin1,M,F,As}, Drv, From, Buf); +io_request({get_chars,Prompt,N}, Drv, From, Buf) -> + io_request({get_chars,latin1,Prompt,N}, Drv, From, Buf); +io_request({get_line,Prompt}, Drv, From, Buf) -> + io_request({get_line,latin1,Prompt}, Drv, From, Buf); +io_request({get_until, Prompt,M,F,As}, Drv, From, Buf) -> + io_request({get_until,latin1, Prompt,M,F,As}, Drv, From, Buf); +io_request(get_password,Drv,From,Buf) -> + io_request({get_password,latin1},Drv,From,Buf); + + + +io_request(_, _Drv, _From, Buf) -> {error,{error,request},Buf}. -%% Status = io_requests(RequestList, PrevStat, Drv) -%% Process a list of output requests as long as the previous status is 'ok'. - -io_requests([R|Rs], {ok,ok,Buf}, Drv) -> - io_requests(Rs, io_request(R, Drv, Buf), Drv); -io_requests([_|_], Error, _Drv) -> +%% Status = io_requests(RequestList, PrevStat, From, Drv) +%% Process a list of output requests as long as +%% the previous status is 'ok' or noreply. +%% +%% We use undefined as the From for all but the last request +%% in order to discards acknowledgements from those requests. +%% +io_requests([R|Rs], {noreply,Buf}, From, Drv) -> + ReqFrom = if Rs =:= [] -> From; true -> undefined end, + io_requests(Rs, io_request(R, Drv, ReqFrom, Buf), From, Drv); +io_requests([R|Rs], {ok,ok,Buf}, From, Drv) -> + ReqFrom = if Rs =:= [] -> From; true -> undefined end, + io_requests(Rs, io_request(R, Drv, ReqFrom, Buf), From, Drv); +io_requests([_|_], Error, _From, _Drv) -> Error; -io_requests([], Stat, _) -> +io_requests([], Stat, _From, _) -> Stat. %% io_reply(From, ReplyAs, Reply) %% The function for sending i/o command acknowledgement. %% The ACK contains the return value. +io_reply(undefined, _ReplyAs, _Reply) -> + %% Ignore these replies as they are generated from io_requests/4. + ok; io_reply(From, ReplyAs, Reply) -> From ! {io_reply,ReplyAs,Reply}, ok. @@ -619,6 +645,10 @@ more_data(What, Cont0, Drv, Ls, Encoding) -> io_request(Req, From, ReplyAs, Drv, []), %WRONG!!! send_drv_reqs(Drv, edlin:redraw_line(Cont)), get_line1({more_chars,Cont,[]}, Drv, Ls, Encoding); + {reply,{{From,ReplyAs},Reply}} -> + %% We take care of replies from puts here as well + io_reply(From, ReplyAs, Reply), + more_data(What, Cont0, Drv, Ls, Encoding); {'EXIT',Drv,interrupt} -> interrupted; {'EXIT',Drv,_} -> @@ -641,6 +671,10 @@ get_line_echo_off1({Chars,[]}, Drv) -> {io_request,From,ReplyAs,Req} when is_pid(From) -> io_request(Req, From, ReplyAs, Drv, []), get_line_echo_off1({Chars,[]}, Drv); + {reply,{{From,ReplyAs},Reply}} when From =/= undefined -> + %% We take care of replies from puts here as well + io_reply(From, ReplyAs, Reply), + get_line_echo_off1({Chars,[]},Drv); {'EXIT',Drv,interrupt} -> interrupted; {'EXIT',Drv,_} -> @@ -790,6 +824,10 @@ get_password1({Chars,[]}, Drv) -> %% set to []. But do we expect anything but plain output? get_password1({Chars, []}, Drv); + {reply,{{From,ReplyAs},Reply}} -> + %% We take care of replies from puts here as well + io_reply(From, ReplyAs, Reply), + get_password1({Chars, []},Drv); {'EXIT',Drv,interrupt} -> interrupted; {'EXIT',Drv,_} -> diff --git a/lib/kernel/src/kernel.appup.src b/lib/kernel/src/kernel.appup.src index f8f4cc1ec2..1bae762bed 100644 --- a/lib/kernel/src/kernel.appup.src +++ b/lib/kernel/src/kernel.appup.src @@ -17,9 +17,7 @@ %% %CopyrightEnd% {"%VSN%", %% Up from - max one major revision back - [{<<"3\\.0(\\.[0-9]+)*">>,[restart_new_emulator]}, %% R17 - {<<"2\\.16(\\.[0-9]+)*">>,[restart_new_emulator]}],%% R16 + [{<<"3\\.0(\\.[0-9]+)*">>,[restart_new_emulator]}], % OTP-17 %% Down to - max one major revision back - [{<<"3\\.0(\\.[0-9]+)*">>,[restart_new_emulator]}, %% R17 - {<<"2\\.16(\\.[0-9]+)*">>,[restart_new_emulator]}] %% R16 + [{<<"3\\.0(\\.[0-9]+)*">>,[restart_new_emulator]}] % OTP-17 }. diff --git a/lib/kernel/src/user_drv.erl b/lib/kernel/src/user_drv.erl index a91c23539d..e6ce85c379 100644 --- a/lib/kernel/src/user_drv.erl +++ b/lib/kernel/src/user_drv.erl @@ -29,6 +29,7 @@ -define(OP_INSC,2). -define(OP_DELC,3). -define(OP_BEEP,4). +-define(OP_PUTC_SYNC,5). % Control op -define(CTRL_OP_GET_WINSIZE,100). -define(CTRL_OP_GET_UNICODE_STATE,101). @@ -133,7 +134,7 @@ server1(Iport, Oport, Shell) -> [erlang:system_info(system_version)]))}, Iport, Oport), %% Enter the server loop. - server_loop(Iport, Oport, Curr, User, Gr). + server_loop(Iport, Oport, Curr, User, Gr, queue:new()). rem_sh_opts(Node) -> [{expand_fun,fun(B)-> rpc:call(Node,edlin_expand,expand,[B]) end}]. @@ -158,42 +159,41 @@ start_user() -> User end. -server_loop(Iport, Oport, User, Gr) -> +server_loop(Iport, Oport, User, Gr, IOQueue) -> Curr = gr_cur_pid(Gr), put(current_group, Curr), - server_loop(Iport, Oport, Curr, User, Gr). + server_loop(Iport, Oport, Curr, User, Gr, IOQueue). -server_loop(Iport, Oport, Curr, User, Gr) -> +server_loop(Iport, Oport, Curr, User, Gr, IOQueue) -> receive {Iport,{data,Bs}} -> BsBin = list_to_binary(Bs), Unicode = unicode:characters_to_list(BsBin,utf8), - port_bytes(Unicode, Iport, Oport, Curr, User, Gr); + port_bytes(Unicode, Iport, Oport, Curr, User, Gr, IOQueue); {Iport,eof} -> Curr ! {self(),eof}, - server_loop(Iport, Oport, Curr, User, Gr); - {User,Req} -> % never block from user! - io_request(Req, Iport, Oport), - server_loop(Iport, Oport, Curr, User, Gr); - {Curr,tty_geometry} -> - Curr ! {self(),tty_geometry,get_tty_geometry(Iport)}, - server_loop(Iport, Oport, Curr, User, Gr); - {Curr,get_unicode_state} -> - Curr ! {self(),get_unicode_state,get_unicode_state(Iport)}, - server_loop(Iport, Oport, Curr, User, Gr); - {Curr,set_unicode_state, Bool} -> - Curr ! {self(),set_unicode_state,set_unicode_state(Iport,Bool)}, - server_loop(Iport, Oport, Curr, User, Gr); - {Curr,Req} -> - io_request(Req, Iport, Oport), - server_loop(Iport, Oport, Curr, User, Gr); + server_loop(Iport, Oport, Curr, User, Gr, IOQueue); + Req when element(1,Req) =:= User orelse element(1,Req) =:= Curr, + tuple_size(Req) =:= 2 orelse tuple_size(Req) =:= 3 -> + %% We match {User|Curr,_}|{User|Curr,_,_} + NewQ = handle_req(Req, Iport, Oport, IOQueue), + server_loop(Iport, Oport, Curr, User, Gr, NewQ); + {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,Reply}, + NewQ = handle_req(next, Iport, Oport, ReplyQ), + server_loop(Iport, Oport, Curr, User, Gr, NewQ); {'EXIT',Iport,_R} -> - server_loop(Iport, Oport, Curr, User, Gr); + server_loop(Iport, Oport, Curr, User, Gr, IOQueue); {'EXIT',Oport,_R} -> - server_loop(Iport, Oport, Curr, User, Gr); + server_loop(Iport, Oport, Curr, User, Gr, IOQueue); + {'EXIT',User,shutdown} -> % force data to port + server_loop(Iport, Oport, Curr, User, Gr, IOQueue); {'EXIT',User,_R} -> % keep 'user' alive NewU = start_user(), - server_loop(Iport, Oport, Curr, NewU, gr_set_num(Gr, 1, NewU, {})); + server_loop(Iport, Oport, Curr, NewU, gr_set_num(Gr, 1, NewU, {}), IOQueue); {'EXIT',Pid,R} -> % shell and group leader exit case gr_cur_pid(Gr) of Pid when R =/= die , @@ -213,18 +213,51 @@ server_loop(Iport, Oport, Curr, User, Gr) -> {ok,Gr2} = gr_set_cur(gr_set_num(Gr1, Ix, Pid1, {shell,start,Params}), Ix), put(current_group, Pid1), - server_loop(Iport, Oport, Pid1, User, Gr2); + server_loop(Iport, Oport, Pid1, User, Gr2, IOQueue); _ -> % remote shell io_requests([{put_chars,unicode,"(^G to start new job) ***\n"}], Iport, Oport), - server_loop(Iport, Oport, Curr, User, Gr1) + server_loop(Iport, Oport, Curr, User, Gr1, IOQueue) end; _ -> % not current, just remove it - server_loop(Iport, Oport, Curr, User, gr_del_pid(Gr, Pid)) + server_loop(Iport, Oport, Curr, User, gr_del_pid(Gr, Pid), IOQueue) end; _X -> %% Ignore unknown messages. - server_loop(Iport, Oport, Curr, User, Gr) + server_loop(Iport, Oport, Curr, User, Gr, IOQueue) + end. + +%% We always handle geometry and unicode requests +handle_req({Curr,tty_geometry},Iport,_Oport,IOQueue) -> + Curr ! {self(),tty_geometry,get_tty_geometry(Iport)}, + IOQueue; +handle_req({Curr,get_unicode_state},Iport,_Oport,IOQueue) -> + Curr ! {self(),get_unicode_state,get_unicode_state(Iport)}, + 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); + {empty,_} -> + IOQueue + end; +handle_req(Msg,Iport,Oport,IOQueue) -> + case queue:peek(IOQueue) of + empty -> + {Origin,Req} = Msg, + case io_request(Req, Iport, Oport) of + ok -> IOQueue; + 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. %% port_bytes(Bytes, InPort, OutPort, CurrentProcess, UserProcess, Group) @@ -232,34 +265,34 @@ server_loop(Iport, Oport, Curr, User, Gr) -> %% either escape to switch_loop or restart the shell. Otherwise send %% the bytes to Curr. -port_bytes([$\^G|_Bs], Iport, Oport, _Curr, User, Gr) -> - handle_escape(Iport, Oport, User, Gr); +port_bytes([$\^G|_Bs], Iport, Oport, _Curr, User, Gr, IOQueue) -> + handle_escape(Iport, Oport, User, Gr, IOQueue); -port_bytes([$\^C|_Bs], Iport, Oport, Curr, User, Gr) -> - interrupt_shell(Iport, Oport, Curr, User, Gr); +port_bytes([$\^C|_Bs], Iport, Oport, Curr, User, Gr, IOQueue) -> + interrupt_shell(Iport, Oport, Curr, User, Gr, IOQueue); -port_bytes([B], Iport, Oport, Curr, User, Gr) -> +port_bytes([B], Iport, Oport, Curr, User, Gr, IOQueue) -> Curr ! {self(),{data,[B]}}, - server_loop(Iport, Oport, Curr, User, Gr); -port_bytes(Bs, Iport, Oport, Curr, User, Gr) -> + server_loop(Iport, Oport, Curr, User, Gr, IOQueue); +port_bytes(Bs, Iport, Oport, Curr, User, Gr, IOQueue) -> case member($\^G, Bs) of true -> - handle_escape(Iport, Oport, User, Gr); + handle_escape(Iport, Oport, User, Gr, IOQueue); false -> Curr ! {self(),{data,Bs}}, - server_loop(Iport, Oport, Curr, User, Gr) + server_loop(Iport, Oport, Curr, User, Gr, IOQueue) end. -interrupt_shell(Iport, Oport, Curr, User, Gr) -> +interrupt_shell(Iport, Oport, Curr, User, Gr, IOQueue) -> case gr_get_info(Gr, Curr) of undefined -> ok; % unknown _ -> exit(Curr, interrupt) end, - server_loop(Iport, Oport, Curr, User, Gr). + server_loop(Iport, Oport, Curr, User, Gr, IOQueue). -handle_escape(Iport, Oport, User, Gr) -> +handle_escape(Iport, Oport, User, Gr, IOQueue) -> case application:get_env(stdlib, shell_esc) of {ok,abort} -> Pid = gr_cur_pid(Gr), @@ -278,11 +311,11 @@ handle_escape(Iport, Oport, User, Gr) -> Pid1 = group:start(self(), {shell,start,[]}), io_request({put_chars,unicode,"\n"}, Iport, Oport), server_loop(Iport, Oport, User, - gr_add_cur(Gr1, Pid1, {shell,start,[]})); + gr_add_cur(Gr1, Pid1, {shell,start,[]}), IOQueue); _ -> % {ok,jcl} | undefined io_request({put_chars,unicode,"\nUser switch command\n"}, Iport, Oport), - server_loop(Iport, Oport, User, switch_loop(Iport, Oport, Gr)) + server_loop(Iport, Oport, User, switch_loop(Iport, Oport, Gr), IOQueue) end. switch_loop(Iport, Oport, Gr) -> @@ -492,9 +525,12 @@ set_unicode_state(Iport, Bool) -> io_request(Request, Iport, Oport) -> try io_command(Request) of - Command -> + {command,_} = Command -> Oport ! {self(),Command}, - ok + ok; + {Command,Reply} -> + Oport ! {self(),Command}, + Reply catch {requests,Rs} -> io_requests(Rs, Iport, Oport); @@ -511,6 +547,13 @@ io_requests([], _Iport, _Oport) -> put_int16(N, Tail) -> [(N bsr 8)band 255,N band 255|Tail]. +%% When a put_chars_sync command is used, user_drv guarantees that +%% the bytes have been put in the buffer of the port before an acknowledgement +%% is sent back to the process sending the request. This command was added in +%% OTP 18 to make sure that data sent from io:format is actually printed +%% to the console before the vm stops when calling erlang:halt(integer()). +io_command({put_chars_sync, unicode,Cs,Reply}) -> + {{command,[?OP_PUTC_SYNC|unicode:characters_to_binary(Cs,utf8)]},Reply}; io_command({put_chars, unicode,Cs}) -> {command,[?OP_PUTC|unicode:characters_to_binary(Cs,utf8)]}; io_command({move_rel,N}) -> diff --git a/lib/kernel/test/pdict_SUITE.erl b/lib/kernel/test/pdict_SUITE.erl index 98cff0222e..4b60beb9dc 100644 --- a/lib/kernel/test/pdict_SUITE.erl +++ b/lib/kernel/test/pdict_SUITE.erl @@ -31,7 +31,7 @@ -export([all/0, suite/0,groups/0,init_per_suite/1, end_per_suite/1, init_per_group/2,end_per_group/2, - simple/1, complicated/1, heavy/1, info/1]). + simple/1, complicated/1, heavy/1, simple_all_keys/1, info/1]). -export([init_per_testcase/2, end_per_testcase/2]). -export([other_process/2]). @@ -46,7 +46,7 @@ end_per_testcase(_Case, Config) -> suite() -> [{ct_hooks,[ts_install_cth]}]. all() -> - [simple, complicated, heavy, info]. + [simple, complicated, heavy, simple_all_keys, info]. groups() -> []. @@ -70,6 +70,7 @@ simple(suite) -> []; simple(Config) when is_list(Config) -> XX = get(), + ok = match_keys(XX), erase(), L = [a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p, q,r,s,t,u,v,x,y,z,'A','B','C','D'], @@ -105,6 +106,7 @@ simple(Config) when is_list(Config) -> complicated(Config) when is_list(Config) -> Previous = get(), + ok = match_keys(Previous), Previous = erase(), N = case ?t:is_debug() of false -> 500000; @@ -113,8 +115,10 @@ complicated(Config) when is_list(Config) -> comp_1(N), comp_2(N), N = comp_3(lists:sort(get()), 1), + ok = match_keys(get()), comp_4(get()), [] = get(), + [] = get_keys(), [put(Key, Value) || {Key,Value} <- Previous], ok. @@ -160,6 +164,26 @@ heavy(Config) when is_list(Config) -> [put(Key, Value) || {Key,Value} <- XX], ok. +simple_all_keys(Config) when is_list(Config) -> + erase(), + ok = simple_all_keys_add_loop(1000), + [] = get_keys(), + [] = get(), + ok. + +simple_all_keys_add_loop(0) -> + simple_all_keys_del_loop(erlang:get_keys()); +simple_all_keys_add_loop(N) -> + put(gen_key(N),value), + ok = match_keys(get()), + simple_all_keys_add_loop(N-1). + +simple_all_keys_del_loop([]) -> ok; +simple_all_keys_del_loop([K|Ks]) -> + value = erase(K), + ok = match_keys(get()), + simple_all_keys_del_loop(Ks). + info(doc) -> ["Tests process_info(Pid, dictionary)"]; info(suite) -> @@ -339,3 +363,8 @@ m(A,B,Module,Line) -> [A,B,Module,Line]), exit({no_match,{A,B},Module,Line}) end. + +match_keys(All) -> + Ks = lists:sort([K||{K,_}<-All]), + Ks = lists:sort(erlang:get_keys()), + ok. diff --git a/lib/observer/test/crashdump_viewer_SUITE.erl b/lib/observer/test/crashdump_viewer_SUITE.erl index 03ab0c20e1..1266b1f9b9 100644 --- a/lib/observer/test/crashdump_viewer_SUITE.erl +++ b/lib/observer/test/crashdump_viewer_SUITE.erl @@ -101,7 +101,7 @@ end_per_group(_GroupName, Config) -> init_per_suite(Config) when is_list(Config) -> delete_saved(Config), DataDir = ?config(data_dir,Config), - Rels = [R || R <- [r15b,r16b], ?t:is_release_available(R)] ++ [current], + Rels = [R || R <- [r16b,'17'], ?t:is_release_available(R)] ++ [current], io:format("Creating crash dumps for the following releases: ~p", [Rels]), AllDumps = create_dumps(DataDir,Rels), [{dumps,AllDumps}|Config]. @@ -563,12 +563,6 @@ dump_with_strange_module_name(DataDir,Rel,DumpName) -> CD. dump(Node,DataDir,Rel,DumpName) -> - case Rel of - _ when Rel<r15b, Rel=/=current -> - rpc:call(Node,os,putenv,["ERL_CRASH_DUMP_SECONDS","600"]); - _ -> - ok - end, rpc:call(Node,erlang,halt,[DumpName]), Crashdump0 = filename:join(filename:dirname(code:which(?t)), "erl_crash_dump.n1"), @@ -623,42 +617,21 @@ dos_dump(DataDir,Rel,Dump) -> rel_opt(Rel) -> case Rel of - r9b -> [{erl,[{release,"r9b_patched"}]}]; - r9c -> [{erl,[{release,"r9c_patched"}]}]; - r10b -> [{erl,[{release,"r10b_patched"}]}]; - r11b -> [{erl,[{release,"r11b_patched"}]}]; - r12b -> [{erl,[{release,"r12b_patched"}]}]; - r13b -> [{erl,[{release,"r13b_patched"}]}]; - r14b -> [{erl,[{release,"r14b_latest"}]}]; %naming convention changed - r15b -> [{erl,[{release,"r15b_latest"}]}]; r16b -> [{erl,[{release,"r16b_latest"}]}]; + '17' -> [{erl,[{release,"17_latest"}]}]; current -> [] end. dump_prefix(Rel) -> case Rel of - r9b -> "r9b_dump."; - r9c -> "r9c_dump."; - r10b -> "r10b_dump."; - r11b -> "r11b_dump."; - r12b -> "r12b_dump."; - r13b -> "r13b_dump."; - r14b -> "r14b_dump."; - r15b -> "r15b_dump."; r16b -> "r16b_dump."; - current -> "r17b_dump." + '17' -> "r17_dump."; + current -> "r18_dump." end. compat_rel(Rel) -> case Rel of - r9b -> "+R9 "; - r9c -> "+R9 "; - r10b -> "+R10 "; - r11b -> "+R11 "; - r12b -> "+R12 "; - r13b -> "+R13 "; - r14b -> "+R14 "; - r15b -> "+R15 "; r16b -> "+R16 "; + '17' -> "+R17 "; current -> "" end. diff --git a/lib/reltool/test/reltool_server_SUITE.erl b/lib/reltool/test/reltool_server_SUITE.erl index 347e80ed7c..b3b7afd1a9 100644 --- a/lib/reltool/test/reltool_server_SUITE.erl +++ b/lib/reltool/test/reltool_server_SUITE.erl @@ -1205,14 +1205,9 @@ create_slim(Config) -> RootDir = code:root_dir(), Erl = filename:join([RootDir, "bin", "erl"]), - EscapedQuote = - case os:type() of - {win32,_} -> "\\\""; - _ -> "\"" - end, Args = ["-boot_var", "RELTOOL_EXT_LIB", TargetLibDir, "-boot", filename:join(TargetRelVsnDir,RelName), - "-sasl", "releases_dir", EscapedQuote++TargetRelDir++EscapedQuote], + "-sasl", "releases_dir", "\""++TargetRelDir++"\""], {ok, Node} = ?msym({ok, _}, start_node(?NODE_NAME, Erl, Args)), ?msym(RootDir, rpc:call(Node, code, root_dir, [])), wait_for_app(Node,sasl,50), diff --git a/lib/sasl/doc/src/appup.xml b/lib/sasl/doc/src/appup.xml index 95f315d269..f0f41b0c7e 100644 --- a/lib/sasl/doc/src/appup.xml +++ b/lib/sasl/doc/src/appup.xml @@ -180,15 +180,28 @@ <c>Mod</c> when upgrading, and vice versa when downgrading.</p> <pre> {add_module, Mod} +{add_module, Mod, DepMods} Mod = atom() + DepMods = [Mod] </pre> <p>Loads a new module <c>Mod</c>.</p> + <p><c>DepMods</c> defaults to [] and defines which other modules + <c>Mod</c> is dependent on. In <c>relup</c>, instructions + related to these modules will come before the instruction for + loading <c>Mod</c> when upgrading, and vice versa when + downgrading.</p> <pre> {delete_module, Mod} +{delete_module, Mod, DepMods} Mod = atom() </pre> <p>Deletes a module <c>Mod</c> using the low-level instructions <c>remove</c> and <c>purge</c>.</p> + <p><c>DepMods</c> defaults to [] and defines which other modules + <c>Mod</c> is dependent on. In <c>relup</c>, instructions + related to these modules will come before the instruction for + removing <c>Mod</c> when upgrading, and vice versa when + downgrading.</p> <pre> {add_application, Application} {add_application, Application, Type} diff --git a/lib/sasl/src/sasl.appup.src b/lib/sasl/src/sasl.appup.src index e789853eea..af04d007ac 100644 --- a/lib/sasl/src/sasl.appup.src +++ b/lib/sasl/src/sasl.appup.src @@ -17,9 +17,7 @@ %% %CopyrightEnd% {"%VSN%", %% Up from - max one major revision back - [{<<"2\\.4(\\.[0-9]+)*">>,[restart_new_emulator]}, %% R17 - {<<"2\\.3(\\.[0-9]+)*">>,[restart_new_emulator]}], %% R16 + [{<<"2\\.4(\\.[0-9]+)*">>,[restart_new_emulator]}], % OTP-17 %% Down to - max one major revision back - [{<<"2\\.4(\\.[0-9]+)*">>,[restart_new_emulator]}, %% R17 - {<<"2\\.3(\\.[0-9]+)*">>,[restart_new_emulator]}] %% R16 + [{<<"2\\.4(\\.[0-9]+)*">>,[restart_new_emulator]}] % OTP-17 }. diff --git a/lib/sasl/src/systools_rc.erl b/lib/sasl/src/systools_rc.erl index 76f753c3d0..11e097996c 100644 --- a/lib/sasl/src/systools_rc.erl +++ b/lib/sasl/src/systools_rc.erl @@ -32,7 +32,6 @@ %% {load_module, Mod, PrePurge, PostPurge, [Mod]} %% {add_module, Mod} %% {add_module, Mod, [Mod]} -%% {remove_module, Mod, PrePurge, PostPurge, [Mod]} %% {restart_application, Appl} %% {add_application, Appl, Type} %% {remove_application, Appl} @@ -59,7 +58,7 @@ %% High-level instructions that contain dependencies %% --define(DEP_INSTRS, [update, load_module, add_module, remove_module]). +-define(DEP_INSTRS, [update, load_module, add_module, delete_module]). %%----------------------------------------------------------------- %% translate_scripts(Scripts, Appls, PreAppls) -> Res @@ -107,9 +106,6 @@ expand_script([I|Script]) -> {update, Mod, Change, Mods} when Change==soft, is_list(Mods) -> {update, Mod, Change, brutal_purge,brutal_purge, Mods}; - {delete_module, Mod} -> - [{remove, {Mod, brutal_purge, brutal_purge}}, - {purge, [Mod]}]; {add_application, Application} -> {add_application, Application, permanent}; _ -> @@ -301,6 +297,8 @@ normalize_instrs(Script) -> PostPurge, Mods}; ({add_module, Mod}) -> {add_module, Mod, []}; + ({delete_module, Mod}) -> + {delete_module, Mod, []}; (I) -> I end, Script). @@ -412,7 +410,7 @@ translate_add_module_instrs(Before, After) -> %%----------------------------------------------------------------- %%----------------------------------------------------------------- -%% Translates update, load_module and remove_module, and reorder the +%% Translates update, load_module and delete_module, and reorder the %% instructions according to dependencies. Leaves other instructions %% unchanged. %%----------------------------------------------------------------- @@ -538,7 +536,7 @@ get_dependent_instructions(G, WCs, Mod) -> %% Instructions are in order of dependency. %% Appls = [#application] %% -%% Instructions translated are: update, load_module, and remove_module +%% Instructions translated are: update, load_module, and delete_module %% %% Before = [{load_object_code, ...}] %% After = [{suspend, ...}] ++ CodeInstrs ++ [{resume, ...}] @@ -576,17 +574,19 @@ translate_dep_to_low(Mode, Instructions, Appls) -> end, RevUpdateMods)}] end, - LoadRemoveInstrs = + LoadRemoveInstrs0 = filtermap(fun({update, Mod, _, _, _, PreP, PostP, _}) -> {true, {load, {Mod, PreP, PostP}}}; ({load_module, Mod, PreP, PostP, _}) -> {true, {load, {Mod, PreP, PostP}}}; - ({remove_module, Mod, PreP, PostP, _}) -> - {true, {remove, {Mod, PreP, PostP}}}; + ({delete_module, Mod, _}) -> + {true,[{remove, {Mod, brutal_purge, brutal_purge}}, + {purge, [Mod]}]}; (_) -> false end, Instructions), - RevLoadRemoveInstrs = lists:reverse(LoadRemoveInstrs), + LoadRemoveInstrs = lists:flatten(LoadRemoveInstrs0), + RevLoadRemoveInstrs = lists:flatten(lists:reverse(LoadRemoveInstrs0)), %% The order of loading object code is unimportant. The order %% chosen is the order of dependency. @@ -781,10 +781,10 @@ check_op({add_module, Mod, Mods}) -> check_mod(Mod), check_list(Mods), lists:foreach(fun(M) -> check_mod(M) end, Mods); -check_op({remove_module, Mod, PrePurge, PostPurge, Mods}) -> +check_op({delete_module, Mod}) -> + check_mod(Mod); +check_op({delete_module, Mod, Mods}) -> check_mod(Mod), - check_purge(PrePurge), - check_purge(PostPurge), check_list(Mods), lists:foreach(fun(M) -> check_mod(M) end, Mods); check_op({remove_application, Appl}) -> diff --git a/lib/sasl/test/release_handler_SUITE_data/lib/README b/lib/sasl/test/release_handler_SUITE_data/lib/README index ffb8c5120b..5d17950b0b 100644 --- a/lib/sasl/test/release_handler_SUITE_data/lib/README +++ b/lib/sasl/test/release_handler_SUITE_data/lib/README @@ -21,7 +21,7 @@ start version, includes b_lib and b_server b-2.0: can be upgraded to from b-1.0. -Removes b_lib (soft_purge) and updates b_server (brutal_purge) +Removes b_lib (brutal_purge) and updates b_server (soft_purge) * The diff in purge method is important for test "check_and_purge", in order to check that the purge option to check_install_release works for both methods. diff --git a/lib/sasl/test/release_handler_SUITE_data/lib/b-2.0/ebin/b.appup b/lib/sasl/test/release_handler_SUITE_data/lib/b-2.0/ebin/b.appup index 001255a88c..9df590e63f 100644 --- a/lib/sasl/test/release_handler_SUITE_data/lib/b-2.0/ebin/b.appup +++ b/lib/sasl/test/release_handler_SUITE_data/lib/b-2.0/ebin/b.appup @@ -1,6 +1,6 @@ %% -*- erlang -*- {"2.0", - [{"1.0",[{remove_module,b_lib,soft_purge,soft_purge,[]}, - {update,b_server,{advanced,[]}}]}], + [{"1.0",[{delete_module,b_lib}, + {update,b_server,{advanced,[]},soft_purge,soft_purge,[]}]}], [{"1.0",[{add_module,b_lib}, - {update,b_server,{advanced,[]}}]}]}. + {update,b_server,{advanced,[]},soft_purge,soft_purge,[]}]}]}. diff --git a/lib/sasl/test/systools_rc_SUITE.erl b/lib/sasl/test/systools_rc_SUITE.erl index 5efab7c028..1afef986d2 100644 --- a/lib/sasl/test/systools_rc_SUITE.erl +++ b/lib/sasl/test/systools_rc_SUITE.erl @@ -22,14 +22,16 @@ -include_lib("sasl/src/systools.hrl"). -export([all/0,groups/0,init_per_group/2,end_per_group/2, syntax_check/1, translate/1, translate_app/1, - translate_emulator_restarts/1]). + translate_emulator_restarts/1, + translate_add_delete_module/1]). %%----------------------------------------------------------------- %% erl -compile systools_rc_SUITE @i ../src/ @i ../../test_server/include/ %% c(systools_rc_SUITE, [{i, "../src"}, {i, "../../test_server/include"}]). %%----------------------------------------------------------------- all() -> - [syntax_check, translate, translate_app, translate_emulator_restarts]. + [syntax_check, translate, translate_app, translate_emulator_restarts, + translate_add_delete_module]. groups() -> []. @@ -707,3 +709,59 @@ translate_emulator_restarts(_Config) -> restart_emulator] = X6, ok. + +translate_add_delete_module(_Config) -> + PreApps = + [#application{name = test, + description = "TEST", + vsn = "0.1", + modules = [foo,bar,baz,old_mod], + regs = [], + mod = {sasl, []}}], + Apps = + [#application{name = test, + description = "TEST", + vsn = "1.0", + modules = [foo,bar,baz,new_mod], + regs = [], + mod = {sasl, []}}], + S1 = [ + {delete_module, old_mod}, + {add_module, new_mod}, + {load_module, foo} + ], + {ok, X1} = systools_rc:translate_scripts([S1], Apps, PreApps), + [{load_object_code,{test,"1.0",[new_mod,foo]}}, + point_of_no_return, + {remove,{old_mod,brutal_purge,brutal_purge}}, + {purge,[old_mod]}, + {load,{new_mod,brutal_purge,brutal_purge}}, + {load,{foo,brutal_purge,brutal_purge}}] = X1, + + S2 = [ + {delete_module, old_mod}, + {add_module, new_mod, [foo]}, + {load_module, foo} + ], + {ok, X2} = systools_rc:translate_scripts([S2], Apps, PreApps), + [{load_object_code,{test,"1.0",[new_mod,foo]}}, + point_of_no_return, + {remove,{old_mod,brutal_purge,brutal_purge}}, + {purge,[old_mod]}, + {load,{foo,brutal_purge,brutal_purge}}, + {load,{new_mod,brutal_purge,brutal_purge}}] = X2, + + S3 = [ + {delete_module, old_mod, [new_mod]}, + {add_module, new_mod, [foo]}, + {load_module, foo} + ], + {ok, X3} = systools_rc:translate_scripts([S3], Apps, PreApps), + [{load_object_code,{test,"1.0",[new_mod,foo]}}, + point_of_no_return, + {load,{foo,brutal_purge,brutal_purge}}, + {load,{new_mod,brutal_purge,brutal_purge}}, + {remove,{old_mod,brutal_purge,brutal_purge}}, + {purge,[old_mod]}] = X3, + + ok. diff --git a/lib/sasl/test/test_lib.hrl b/lib/sasl/test/test_lib.hrl index c8a4e92f24..b16c4ac34c 100644 --- a/lib/sasl/test/test_lib.hrl +++ b/lib/sasl/test/test_lib.hrl @@ -1,3 +1,3 @@ -define(ertsvsn,"4.4"). --define(kernelvsn,"2.16.4"). --define(stdlibvsn,"1.19.4"). +-define(kernelvsn,"3.0"). +-define(stdlibvsn,"2.0"). diff --git a/lib/ssh/src/ssh_cli.erl b/lib/ssh/src/ssh_cli.erl index 18841e3d2d..de6d246403 100644 --- a/lib/ssh/src/ssh_cli.erl +++ b/lib/ssh/src/ssh_cli.erl @@ -98,7 +98,7 @@ handle_ssh_msg({ssh_cm, ConnectionHandler, Pty = Pty0#ssh_pty{width = Width, height = Height, pixel_width = PixWidth, pixel_height = PixHeight}, - {Chars, NewBuf} = io_request({window_change, Pty0}, Buf, Pty), + {Chars, NewBuf} = io_request({window_change, Pty0}, Buf, Pty, undefined), write_chars(ConnectionHandler, ChannelId, Chars), {ok, State#state{pty = Pty, buf = NewBuf}}; @@ -188,7 +188,7 @@ handle_msg({Group, tty_geometry}, #state{group = Group, handle_msg({Group, Req}, #state{group = Group, buf = Buf, pty = Pty, cm = ConnectionHandler, channel = ChannelId} = State) -> - {Chars, NewBuf} = io_request(Req, Buf, Pty), + {Chars, NewBuf} = io_request(Req, Buf, Pty, Group), write_chars(ConnectionHandler, ChannelId, Chars), {ok, State#state{buf = NewBuf}}; @@ -263,40 +263,49 @@ eval(Error) -> %%% displaying device... %%% We are *not* really unicode aware yet, we just filter away characters %%% beyond the latin1 range. We however handle the unicode binaries... -io_request({window_change, OldTty}, Buf, Tty) -> +io_request({window_change, OldTty}, Buf, Tty, _Group) -> window_change(Tty, OldTty, Buf); -io_request({put_chars, Cs}, Buf, Tty) -> +io_request({put_chars, Cs}, Buf, Tty, _Group) -> put_chars(bin_to_list(Cs), Buf, Tty); -io_request({put_chars, unicode, Cs}, Buf, Tty) -> +io_request({put_chars, unicode, Cs}, Buf, Tty, _Group) -> put_chars(unicode:characters_to_list(Cs,unicode), Buf, Tty); -io_request({insert_chars, Cs}, Buf, Tty) -> +io_request({insert_chars, Cs}, Buf, Tty, _Group) -> insert_chars(bin_to_list(Cs), Buf, Tty); -io_request({insert_chars, unicode, Cs}, Buf, Tty) -> +io_request({insert_chars, unicode, Cs}, Buf, Tty, _Group) -> insert_chars(unicode:characters_to_list(Cs,unicode), Buf, Tty); -io_request({move_rel, N}, Buf, Tty) -> +io_request({move_rel, N}, Buf, Tty, _Group) -> move_rel(N, Buf, Tty); -io_request({delete_chars,N}, Buf, Tty) -> +io_request({delete_chars,N}, Buf, Tty, _Group) -> delete_chars(N, Buf, Tty); -io_request(beep, Buf, _Tty) -> +io_request(beep, Buf, _Tty, _Group) -> {[7], Buf}; %% New in R12 -io_request({get_geometry,columns},Buf,Tty) -> +io_request({get_geometry,columns},Buf,Tty, _Group) -> {ok, Tty#ssh_pty.width, Buf}; -io_request({get_geometry,rows},Buf,Tty) -> +io_request({get_geometry,rows},Buf,Tty, _Group) -> {ok, Tty#ssh_pty.height, Buf}; -io_request({requests,Rs}, Buf, Tty) -> - io_requests(Rs, Buf, Tty, []); -io_request(tty_geometry, Buf, Tty) -> - io_requests([{move_rel, 0}, {put_chars, unicode, [10]}], Buf, Tty, []); +io_request({requests,Rs}, Buf, Tty, Group) -> + io_requests(Rs, Buf, Tty, [], Group); +io_request(tty_geometry, Buf, Tty, Group) -> + io_requests([{move_rel, 0}, {put_chars, unicode, [10]}], + Buf, Tty, [], Group); %{[], Buf}; -io_request(_R, Buf, _Tty) -> + +%% New in 18 +io_request({put_chars_sync, Class, Cs, Reply}, Buf, Tty, Group) -> + %% We handle these asynchronous for now, if we need output guarantees + %% we have to handle these synchronously + Group ! {reply, Reply}, + io_request({put_chars, Class, Cs}, Buf, Tty, Group); + +io_request(_R, Buf, _Tty, _Group) -> {[], Buf}. -io_requests([R|Rs], Buf, Tty, Acc) -> - {Chars, NewBuf} = io_request(R, Buf, Tty), - io_requests(Rs, NewBuf, Tty, [Acc|Chars]); -io_requests([], Buf, _Tty, Acc) -> +io_requests([R|Rs], Buf, Tty, Acc, Group) -> + {Chars, NewBuf} = io_request(R, Buf, Tty, Group), + io_requests(Rs, NewBuf, Tty, [Acc|Chars], Group); +io_requests([], Buf, _Tty, Acc, _Group) -> {Acc, Buf}. %%% return commands for cursor navigation, assume everything is ansi diff --git a/lib/ssl/doc/src/ssl.xml b/lib/ssl/doc/src/ssl.xml index b53344e381..83e5ed82bb 100644 --- a/lib/ssl/doc/src/ssl.xml +++ b/lib/ssl/doc/src/ssl.xml @@ -136,7 +136,7 @@ </c></p> <p><c>cipher() = rc4_128 | des_cbc | '3des_ede_cbc' - | aes_128_cbc | aes_256_cbc </c></p> + | aes_128_cbc | aes_256_cbc | aes_128_gcm | aes_256_gcm </c></p> <p> <c>hash() = md5 | sha </c></p> diff --git a/lib/ssl/doc/src/ssl_app.xml b/lib/ssl/doc/src/ssl_app.xml index 43cb3934f7..c8024548b5 100644 --- a/lib/ssl/doc/src/ssl_app.xml +++ b/lib/ssl/doc/src/ssl_app.xml @@ -4,7 +4,7 @@ <appref> <header> <copyright> - <year>1999</year><year>2013</year> + <year>1999</year><year>2014</year> <holder>Ericsson AB. All Rights Reserved.</holder> </copyright> <legalnotice> @@ -75,10 +75,10 @@ </p> </item> - <tag><c><![CDATA[session_cb_init_args = list() <optional>]]></c></tag> + <tag><c><![CDATA[session_cb_init_args = proplist:proplist() <optional>]]></c></tag> <item> <p> - List of arguments to the init function in session cache + List of additional user defined arguments to the init function in session cache callback module, defaults to []. </p> </item> diff --git a/lib/ssl/doc/src/ssl_session_cache_api.xml b/lib/ssl/doc/src/ssl_session_cache_api.xml index 82de1784ca..cb97bbfbb2 100644 --- a/lib/ssl/doc/src/ssl_session_cache_api.xml +++ b/lib/ssl/doc/src/ssl_session_cache_api.xml @@ -4,7 +4,7 @@ <erlref> <header> <copyright> - <year>1999</year><year>2013</year> + <year>1999</year><year>2014</year> <holder>Ericsson AB. All Rights Reserved.</holder> </copyright> <legalnotice> @@ -79,17 +79,25 @@ </func> <func> - <name>init() -> opaque() </name> + <name>init(Args) -> opaque() </name> <fsummary>Return cache reference</fsummary> <type> - <v></v> + <v>Args = proplists:proplist()</v> + <d>Will always include the property {role, client | server}. Currently this + is the only predefined property, there may also be user defined properties. + <seealso marker="ssl_app"> See also application environment variable + session_cb_init_args</seealso> + </d> </type> <desc> <p>Performs possible initializations of the cache and returns a reference to it that will be used as parameter to the other - api functions. Will be called by the cache handling processes - init function, hence putting the same requirements on it as - a normal process init function. + API functions. Will be called by the cache handling processes + init function, hence putting the same requirements on it as a + normal process init function. Note that this function will be + called twice when starting the ssl application, once with the + role client and once with the role server, as the ssl application + must be prepared to take on both roles. </p> </desc> </func> diff --git a/lib/ssl/src/dtls_record.erl b/lib/ssl/src/dtls_record.erl index a7bbb6bc40..c0776e822b 100644 --- a/lib/ssl/src/dtls_record.erl +++ b/lib/ssl/src/dtls_record.erl @@ -120,6 +120,26 @@ get_dtls_records_aux(Data, Acc) -> end. encode_plain_text(Type, Version, Data, + #connection_states{current_write = + #connection_state{ + epoch = Epoch, + sequence_number = Seq, + compression_state=CompS0, + security_parameters= + #security_parameters{ + cipher_type = ?AEAD, + compression_algorithm=CompAlg} + }= WriteState0} = ConnectionStates) -> + {Comp, CompS1} = ssl_record:compress(CompAlg, Data, CompS0), + WriteState1 = WriteState0#connection_state{compression_state = CompS1}, + AAD = calc_aad(Type, Version, Epoch, Seq), + {CipherFragment, WriteState} = ssl_record:cipher_aead(dtls_v1:corresponding_tls_version(Version), + Comp, WriteState1, AAD), + CipherText = encode_tls_cipher_text(Type, Version, Epoch, Seq, CipherFragment), + {CipherText, ConnectionStates#connection_states{current_write = + WriteState#connection_state{sequence_number = Seq +1}}}; + +encode_plain_text(Type, Version, Data, #connection_states{current_write=#connection_state{ epoch = Epoch, sequence_number = Seq, @@ -141,16 +161,44 @@ decode_cipher_text(#ssl_tls{type = Type, version = Version, sequence_number = Seq, fragment = CipherFragment} = CipherText, #connection_states{current_read = - #connection_state{compression_state = CompressionS0, - security_parameters = SecParams} = ReadState0} - = ConnnectionStates0) -> - CompressAlg = SecParams#security_parameters.compression_algorithm, + #connection_state{ + compression_state = CompressionS0, + security_parameters= + #security_parameters{ + cipher_type = ?AEAD, + compression_algorithm=CompAlg} + } = ReadState0}= ConnnectionStates0) -> + AAD = calc_aad(Type, Version, Epoch, Seq), + case ssl_record:decipher_aead(dtls_v1:corresponding_tls_version(Version), + CipherFragment, ReadState0, AAD) of + {PlainFragment, ReadState1} -> + {Plain, CompressionS1} = ssl_record:uncompress(CompAlg, + PlainFragment, CompressionS0), + ConnnectionStates = ConnnectionStates0#connection_states{ + current_read = ReadState1#connection_state{ + compression_state = CompressionS1}}, + {CipherText#ssl_tls{fragment = Plain}, ConnnectionStates}; + #alert{} = Alert -> + Alert + end; + +decode_cipher_text(#ssl_tls{type = Type, version = Version, + epoch = Epoch, + sequence_number = Seq, + fragment = CipherFragment} = CipherText, + #connection_states{current_read = + #connection_state{ + compression_state = CompressionS0, + security_parameters= + #security_parameters{ + compression_algorithm=CompAlg} + } = ReadState0}= ConnnectionStates0) -> {PlainFragment, Mac, ReadState1} = ssl_record:decipher(dtls_v1:corresponding_tls_version(Version), CipherFragment, ReadState0), MacHash = calc_mac_hash(ReadState1, Type, Version, Epoch, Seq, PlainFragment), case ssl_record:is_correct_mac(Mac, MacHash) of true -> - {Plain, CompressionS1} = ssl_record:uncompress(CompressAlg, + {Plain, CompressionS1} = ssl_record:uncompress(CompAlg, PlainFragment, CompressionS0), ConnnectionStates = ConnnectionStates0#connection_states{ current_read = ReadState1#connection_state{ @@ -368,3 +416,7 @@ calc_mac_hash(#connection_state{mac_secret = MacSecret, mac_hash(Version, MacAlg, MacSecret, SeqNo, Type, Length, Fragment) -> dtls_v1:mac_hash(Version, MacAlg, MacSecret, SeqNo, Type, Length, Fragment). + +calc_aad(Type, {MajVer, MinVer}, Epoch, SeqNo) -> + NewSeq = (Epoch bsl 48) + SeqNo, + <<NewSeq:64/integer, ?BYTE(Type), ?BYTE(MajVer), ?BYTE(MinVer)>>. diff --git a/lib/ssl/src/ssl.erl b/lib/ssl/src/ssl.erl index b4bea25942..dcba69a65e 100644 --- a/lib/ssl/src/ssl.erl +++ b/lib/ssl/src/ssl.erl @@ -354,7 +354,7 @@ cipher_suites(openssl) -> cipher_suites(all) -> Version = tls_record:highest_protocol_version([]), Supported = ssl_cipher:all_suites(Version) - ++ ssl_cipher:anonymous_suites() + ++ ssl_cipher:anonymous_suites(Version) ++ ssl_cipher:psk_suites(Version) ++ ssl_cipher:srp_suites(), ssl_cipher:filter_suites([suite_definition(S) || S <- Supported]). @@ -953,7 +953,7 @@ binary_cipher_suites(Version, [{_,_,_}| _] = Ciphers0) -> binary_cipher_suites(Version, [Cipher0 | _] = Ciphers0) when is_binary(Cipher0) -> All = ssl_cipher:suites(Version) - ++ ssl_cipher:anonymous_suites() + ++ ssl_cipher:anonymous_suites(Version) ++ ssl_cipher:psk_suites(Version) ++ ssl_cipher:srp_suites(), case [Cipher || Cipher <- Ciphers0, lists:member(Cipher, All)] of diff --git a/lib/ssl/src/ssl_cipher.erl b/lib/ssl/src/ssl_cipher.erl index 72467ea2a0..e1d89c149e 100644 --- a/lib/ssl/src/ssl_cipher.erl +++ b/lib/ssl/src/ssl_cipher.erl @@ -33,9 +33,9 @@ -include_lib("public_key/include/public_key.hrl"). -export([security_parameters/2, security_parameters/3, suite_definition/1, - decipher/5, cipher/5, + cipher_init/3, decipher/5, cipher/5, decipher_aead/6, cipher_aead/6, suite/1, suites/1, all_suites/1, - ec_keyed_suites/0, anonymous_suites/0, psk_suites/1, srp_suites/0, + ec_keyed_suites/0, anonymous_suites/1, psk_suites/1, srp_suites/0, openssl_suite/1, openssl_suite_name/1, filter/2, filter_suites/1, hash_algorithm/1, sign_algorithm/1, is_acceptable_hash/2]). @@ -44,7 +44,7 @@ key_algo/0]). -type cipher() :: null |rc4_128 | idea_cbc | des40_cbc | des_cbc | '3des_ede_cbc' - | aes_128_cbc | aes_256_cbc. + | aes_128_cbc | aes_256_cbc | aes_128_gcm | aes_256_gcm | chacha20_poly1305. -type hash() :: null | sha | md5 | sha224 | sha256 | sha384 | sha512. -type key_algo() :: null | rsa | dhe_rsa | dhe_dss | ecdhe_ecdsa| ecdh_ecdsa | ecdh_rsa| srp_rsa| srp_dss | psk | dhe_psk | rsa_psk | dh_anon | ecdh_anon | srp_anon. -type erl_cipher_suite() :: {key_algo(), cipher(), hash()}. @@ -88,20 +88,32 @@ security_parameters(Version, CipherSuite, SecParams) -> hash_size = hash_size(Hash)}. %%-------------------------------------------------------------------- +-spec cipher_init(cipher_enum(), binary(), binary()) -> #cipher_state{}. +%% +%% Description: Initializes the #cipher_state according to BCA +%%------------------------------------------------------------------- +cipher_init(?RC4, IV, Key) -> + State = crypto:stream_init(rc4, Key), + #cipher_state{iv = IV, key = Key, state = State}; +cipher_init(?AES_GCM, IV, Key) -> + <<Nonce:64>> = ssl:random_bytes(8), + #cipher_state{iv = IV, key = Key, nonce = Nonce}; +cipher_init(_BCA, IV, Key) -> + #cipher_state{iv = IV, key = Key}. + +%%-------------------------------------------------------------------- -spec cipher(cipher_enum(), #cipher_state{}, binary(), iodata(), ssl_record:ssl_version()) -> {binary(), #cipher_state{}}. %% %% Description: Encrypts the data and the MAC using chipher described %% by cipher_enum() and updating the cipher state +%% Used for "MAC then Cipher" suites where first an HMAC of the +%% data is calculated and the data plus the HMAC is ecncrypted. %%------------------------------------------------------------------- cipher(?NULL, CipherState, <<>>, Fragment, _Version) -> GenStreamCipherList = [Fragment, <<>>], {GenStreamCipherList, CipherState}; -cipher(?RC4, CipherState, Mac, Fragment, _Version) -> - State0 = case CipherState#cipher_state.state of - undefined -> crypto:stream_init(rc4, CipherState#cipher_state.key); - S -> S - end, +cipher(?RC4, CipherState = #cipher_state{state = State0}, Mac, Fragment, _Version) -> GenStreamCipherList = [Fragment, Mac], {State1, T} = crypto:stream_encrypt(State0, GenStreamCipherList), {T, CipherState#cipher_state{state = State1}}; @@ -113,13 +125,40 @@ cipher(?'3DES', CipherState, Mac, Fragment, Version) -> block_cipher(fun(<<K1:8/binary, K2:8/binary, K3:8/binary>>, IV, T) -> crypto:block_encrypt(des3_cbc, [K1, K2, K3], IV, T) end, block_size(des_cbc), CipherState, Mac, Fragment, Version); -cipher(?AES, CipherState, Mac, Fragment, Version) -> +cipher(?AES_CBC, CipherState, Mac, Fragment, Version) -> block_cipher(fun(Key, IV, T) when byte_size(Key) =:= 16 -> crypto:block_encrypt(aes_cbc128, Key, IV, T); (Key, IV, T) when byte_size(Key) =:= 32 -> crypto:block_encrypt(aes_cbc256, Key, IV, T) end, block_size(aes_128_cbc), CipherState, Mac, Fragment, Version). +%%-------------------------------------------------------------------- +-spec cipher_aead(cipher_enum(), #cipher_state{}, integer(), binary(), iodata(), ssl_record:ssl_version()) -> + {binary(), #cipher_state{}}. +%% +%% Description: Encrypts the data and protects associated data (AAD) using chipher +%% described by cipher_enum() and updating the cipher state +%% Use for suites that use authenticated encryption with associated data (AEAD) +%%------------------------------------------------------------------- +cipher_aead(?AES_GCM, CipherState, SeqNo, AAD, Fragment, Version) -> + aead_cipher(aes_gcm, CipherState, SeqNo, AAD, Fragment, Version); +cipher_aead(?CHACHA20_POLY1305, CipherState, SeqNo, AAD, Fragment, Version) -> + aead_cipher(chacha20_poly1305, CipherState, SeqNo, AAD, Fragment, Version). + +aead_cipher(chacha20_poly1305, #cipher_state{key=Key} = CipherState, SeqNo, AAD0, Fragment, _Version) -> + CipherLen = erlang:iolist_size(Fragment), + AAD = <<AAD0/binary, ?UINT16(CipherLen)>>, + Nonce = <<SeqNo:64/integer>>, + {Content, CipherTag} = crypto:block_encrypt(chacha20_poly1305, Key, Nonce, {AAD, Fragment}), + {<<Content/binary, CipherTag/binary>>, CipherState}; +aead_cipher(Type, #cipher_state{key=Key, iv = IV0, nonce = Nonce} = CipherState, _SeqNo, AAD0, Fragment, _Version) -> + CipherLen = erlang:iolist_size(Fragment), + AAD = <<AAD0/binary, ?UINT16(CipherLen)>>, + <<Salt:4/bytes, _/binary>> = IV0, + IV = <<Salt/binary, Nonce:64/integer>>, + {Content, CipherTag} = crypto:block_encrypt(Type, Key, IV, {AAD, Fragment}), + {<<Nonce:64/integer, Content/binary, CipherTag/binary>>, CipherState#cipher_state{nonce = Nonce + 1}}. + build_cipher_block(BlockSz, Mac, Fragment) -> TotSz = byte_size(Mac) + erlang:iolist_size(Fragment) + 1, {PaddingLength, Padding} = get_padding(TotSz, BlockSz), @@ -148,14 +187,12 @@ block_cipher(Fun, BlockSz, #cipher_state{key=Key, iv=IV} = CS0, %% %% Description: Decrypts the data and the MAC using cipher described %% by cipher_enum() and updating the cipher state. +%% Used for "MAC then Cipher" suites where first the data is decrypted +%% and the an HMAC of the decrypted data is checked %%------------------------------------------------------------------- decipher(?NULL, _HashSz, CipherState, Fragment, _) -> {Fragment, <<>>, CipherState}; -decipher(?RC4, HashSz, CipherState, Fragment, _) -> - State0 = case CipherState#cipher_state.state of - undefined -> crypto:stream_init(rc4, CipherState#cipher_state.key); - S -> S - end, +decipher(?RC4, HashSz, CipherState = #cipher_state{state = State0}, Fragment, _) -> try crypto:stream_decrypt(State0, Fragment) of {State, Text} -> GSC = generic_stream_cipher_from_bin(Text, HashSz), @@ -179,13 +216,26 @@ decipher(?'3DES', HashSz, CipherState, Fragment, Version) -> block_decipher(fun(<<K1:8/binary, K2:8/binary, K3:8/binary>>, IV, T) -> crypto:block_decrypt(des3_cbc, [K1, K2, K3], IV, T) end, CipherState, HashSz, Fragment, Version); -decipher(?AES, HashSz, CipherState, Fragment, Version) -> +decipher(?AES_CBC, HashSz, CipherState, Fragment, Version) -> block_decipher(fun(Key, IV, T) when byte_size(Key) =:= 16 -> crypto:block_decrypt(aes_cbc128, Key, IV, T); (Key, IV, T) when byte_size(Key) =:= 32 -> crypto:block_decrypt(aes_cbc256, Key, IV, T) end, CipherState, HashSz, Fragment, Version). +%%-------------------------------------------------------------------- +-spec decipher_aead(cipher_enum(), #cipher_state{}, integer(), binary(), binary(), ssl_record:ssl_version()) -> + {binary(), binary(), #cipher_state{}} | #alert{}. +%% +%% Description: Decrypts the data and checks the associated data (AAD) MAC using +%% cipher described by cipher_enum() and updating the cipher state. +%% Use for suites that use authenticated encryption with associated data (AEAD) +%%------------------------------------------------------------------- +decipher_aead(?AES_GCM, CipherState, SeqNo, AAD, Fragment, Version) -> + aead_decipher(aes_gcm, CipherState, SeqNo, AAD, Fragment, Version); +decipher_aead(?CHACHA20_POLY1305, CipherState, SeqNo, AAD, Fragment, Version) -> + aead_decipher(chacha20_poly1305, CipherState, SeqNo, AAD, Fragment, Version). + block_decipher(Fun, #cipher_state{key=Key, iv=IV} = CipherState0, HashSz, Fragment, Version) -> try @@ -215,6 +265,35 @@ block_decipher(Fun, #cipher_state{key=Key, iv=IV} = CipherState0, %% bad_record_mac alert to hide the specific type of the error." ?ALERT_REC(?FATAL, ?BAD_RECORD_MAC) end. + +aead_ciphertext_to_state(chacha20_poly1305, SeqNo, _IV, AAD0, Fragment, _Version) -> + CipherLen = size(Fragment) - 16, + <<CipherText:CipherLen/bytes, CipherTag:16/bytes>> = Fragment, + AAD = <<AAD0/binary, ?UINT16(CipherLen)>>, + Nonce = <<SeqNo:64/integer>>, + {Nonce, AAD, CipherText, CipherTag}; +aead_ciphertext_to_state(_, _SeqNo, <<Salt:4/bytes, _/binary>>, AAD0, Fragment, _Version) -> + CipherLen = size(Fragment) - 24, + <<ExplicitNonce:8/bytes, CipherText:CipherLen/bytes, CipherTag:16/bytes>> = Fragment, + AAD = <<AAD0/binary, ?UINT16(CipherLen)>>, + Nonce = <<Salt/binary, ExplicitNonce/binary>>, + {Nonce, AAD, CipherText, CipherTag}. + +aead_decipher(Type, #cipher_state{key = Key, iv = IV} = CipherState, + SeqNo, AAD0, Fragment, Version) -> + try + {Nonce, AAD, CipherText, CipherTag} = aead_ciphertext_to_state(Type, SeqNo, IV, AAD0, Fragment, Version), + case crypto:block_decrypt(Type, Key, Nonce, {AAD, CipherText, CipherTag}) of + Content when is_binary(Content) -> + {Content, CipherState}; + _ -> + ?ALERT_REC(?FATAL, ?BAD_RECORD_MAC) + end + catch + _:_ -> + ?ALERT_REC(?FATAL, ?BAD_RECORD_MAC) + end. + %%-------------------------------------------------------------------- -spec suites(ssl_record:ssl_version()) -> [cipher_suite()]. %% @@ -227,16 +306,26 @@ suites({3, N}) -> all_suites(Version) -> suites(Version) - ++ ssl_cipher:anonymous_suites() + ++ ssl_cipher:anonymous_suites(Version) ++ ssl_cipher:psk_suites(Version) ++ ssl_cipher:srp_suites(). %%-------------------------------------------------------------------- --spec anonymous_suites() -> [cipher_suite()]. +-spec anonymous_suites(ssl_record:ssl_version() | integer()) -> [cipher_suite()]. %% %% Description: Returns a list of the anonymous cipher suites, only supported %% if explicitly set by user. Intended only for testing. %%-------------------------------------------------------------------- -anonymous_suites() -> + +anonymous_suites({3, N}) -> + anonymous_suites(N); + +anonymous_suites(N) + when N >= 3 -> + [?TLS_DH_anon_WITH_AES_128_GCM_SHA256, + ?TLS_DH_anon_WITH_AES_256_GCM_SHA384 + ] ++ anonymous_suites(0); + +anonymous_suites(_) -> [?TLS_DH_anon_WITH_RC4_128_MD5, ?TLS_DH_anon_WITH_DES_CBC_SHA, ?TLS_DH_anon_WITH_3DES_EDE_CBC_SHA, @@ -260,13 +349,20 @@ psk_suites({3, N}) -> psk_suites(N) when N >= 3 -> - psk_suites(0) ++ - [?TLS_DHE_PSK_WITH_AES_256_CBC_SHA384, - ?TLS_RSA_PSK_WITH_AES_256_CBC_SHA384, - ?TLS_PSK_WITH_AES_256_CBC_SHA384, - ?TLS_DHE_PSK_WITH_AES_128_CBC_SHA256, - ?TLS_RSA_PSK_WITH_AES_128_CBC_SHA256, - ?TLS_PSK_WITH_AES_128_CBC_SHA256]; + [ + ?TLS_DHE_PSK_WITH_AES_256_GCM_SHA384, + ?TLS_RSA_PSK_WITH_AES_256_GCM_SHA384, + ?TLS_PSK_WITH_AES_256_GCM_SHA384, + ?TLS_DHE_PSK_WITH_AES_256_CBC_SHA384, + ?TLS_RSA_PSK_WITH_AES_256_CBC_SHA384, + ?TLS_PSK_WITH_AES_256_CBC_SHA384, + ?TLS_DHE_PSK_WITH_AES_128_GCM_SHA256, + ?TLS_RSA_PSK_WITH_AES_128_GCM_SHA256, + ?TLS_PSK_WITH_AES_128_GCM_SHA256, + ?TLS_DHE_PSK_WITH_AES_128_CBC_SHA256, + ?TLS_RSA_PSK_WITH_AES_128_CBC_SHA256, + ?TLS_PSK_WITH_AES_128_CBC_SHA256 + ] ++ psk_suites(0); psk_suites(_) -> [?TLS_DHE_PSK_WITH_AES_256_CBC_SHA, @@ -418,6 +514,19 @@ suite_definition(?TLS_RSA_PSK_WITH_AES_256_CBC_SHA) -> %%% TLS 1.2 PSK Cipher Suites RFC 5487 +suite_definition(?TLS_PSK_WITH_AES_128_GCM_SHA256) -> + {psk, aes_128_gcm, null, sha256}; +suite_definition(?TLS_PSK_WITH_AES_256_GCM_SHA384) -> + {psk, aes_256_gcm, null, sha384}; +suite_definition(?TLS_DHE_PSK_WITH_AES_128_GCM_SHA256) -> + {dhe_psk, aes_128_gcm, null, sha256}; +suite_definition(?TLS_DHE_PSK_WITH_AES_256_GCM_SHA384) -> + {dhe_psk, aes_256_gcm, null, sha384}; +suite_definition(?TLS_RSA_PSK_WITH_AES_128_GCM_SHA256) -> + {rsa_psk, aes_128_gcm, null, sha256}; +suite_definition(?TLS_RSA_PSK_WITH_AES_256_GCM_SHA384) -> + {rsa_psk, aes_256_gcm, null, sha384}; + suite_definition(?TLS_PSK_WITH_AES_128_CBC_SHA256) -> {psk, aes_128_cbc, sha256, default_prf}; suite_definition(?TLS_PSK_WITH_AES_256_CBC_SHA384) -> @@ -537,7 +646,59 @@ suite_definition(?TLS_ECDHE_RSA_WITH_AES_256_CBC_SHA384) -> suite_definition(?TLS_ECDH_RSA_WITH_AES_128_CBC_SHA256) -> {ecdh_rsa, aes_128_cbc, sha256, sha256}; suite_definition(?TLS_ECDH_RSA_WITH_AES_256_CBC_SHA384) -> - {ecdh_rsa, aes_256_cbc, sha384, sha384}. + {ecdh_rsa, aes_256_cbc, sha384, sha384}; + +%% RFC 5288 AES-GCM Cipher Suites +suite_definition(?TLS_RSA_WITH_AES_128_GCM_SHA256) -> + {rsa, aes_128_gcm, null, sha256}; +suite_definition(?TLS_RSA_WITH_AES_256_GCM_SHA384) -> + {rsa, aes_256_gcm, null, sha384}; +suite_definition(?TLS_DHE_RSA_WITH_AES_128_GCM_SHA256) -> + {dhe_rsa, aes_128_gcm, null, sha256}; +suite_definition(?TLS_DHE_RSA_WITH_AES_256_GCM_SHA384) -> + {dhe_rsa, aes_256_gcm, null, sha384}; +suite_definition(?TLS_DH_RSA_WITH_AES_128_GCM_SHA256) -> + {dh_rsa, aes_128_gcm, null, sha256}; +suite_definition(?TLS_DH_RSA_WITH_AES_256_GCM_SHA384) -> + {dh_rsa, aes_256_gcm, null, sha384}; +suite_definition(?TLS_DHE_DSS_WITH_AES_128_GCM_SHA256) -> + {dhe_dss, aes_128_gcm, null, sha256}; +suite_definition(?TLS_DHE_DSS_WITH_AES_256_GCM_SHA384) -> + {dhe_dss, aes_256_gcm, null, sha384}; +suite_definition(?TLS_DH_DSS_WITH_AES_128_GCM_SHA256) -> + {dh_dss, aes_128_gcm, null, sha256}; +suite_definition(?TLS_DH_DSS_WITH_AES_256_GCM_SHA384) -> + {dh_dss, aes_256_gcm, null, sha384}; +suite_definition(?TLS_DH_anon_WITH_AES_128_GCM_SHA256) -> + {dh_anon, aes_128_gcm, null, sha256}; +suite_definition(?TLS_DH_anon_WITH_AES_256_GCM_SHA384) -> + {dh_anon, aes_256_gcm, null, sha384}; + +%% RFC 5289 ECC AES-GCM Cipher Suites +suite_definition(?TLS_ECDHE_ECDSA_WITH_AES_128_GCM_SHA256) -> + {ecdhe_ecdsa, aes_128_gcm, null, sha256}; +suite_definition(?TLS_ECDHE_ECDSA_WITH_AES_256_GCM_SHA384) -> + {ecdhe_ecdsa, aes_256_gcm, null, sha384}; +suite_definition(?TLS_ECDH_ECDSA_WITH_AES_128_GCM_SHA256) -> + {ecdh_ecdsa, aes_128_gcm, null, sha256}; +suite_definition(?TLS_ECDH_ECDSA_WITH_AES_256_GCM_SHA384) -> + {ecdh_ecdsa, aes_256_gcm, null, sha384}; +suite_definition(?TLS_ECDHE_RSA_WITH_AES_128_GCM_SHA256) -> + {ecdhe_rsa, aes_128_gcm, null, sha256}; +suite_definition(?TLS_ECDHE_RSA_WITH_AES_256_GCM_SHA384) -> + {ecdhe_rsa, aes_256_gcm, null, sha384}; +suite_definition(?TLS_ECDH_RSA_WITH_AES_128_GCM_SHA256) -> + {ecdh_rsa, aes_128_gcm, null, sha256}; +suite_definition(?TLS_ECDH_RSA_WITH_AES_256_GCM_SHA384) -> + {ecdh_rsa, aes_256_gcm, null, sha384}; + +%% draft-agl-tls-chacha20poly1305-04 Chacha20/Poly1305 Suites +suite_definition(?TLS_ECDHE_RSA_WITH_CHACHA20_POLY1305_SHA256) -> + {ecdhe_rsa, chacha20_poly1305, null, sha256}; +suite_definition(?TLS_ECDHE_ECDSA_WITH_CHACHA20_POLY1305_SHA256) -> + {ecdhe_ecdsa, chacha20_poly1305, null, sha256}; +suite_definition(?TLS_DHE_RSA_WITH_CHACHA20_POLY1305_SHA256) -> + {dhe_rsa, chacha20_poly1305, null, sha256}. %%-------------------------------------------------------------------- -spec suite(erl_cipher_suite()) -> cipher_suite(). @@ -641,6 +802,19 @@ suite({rsa_psk, aes_256_cbc,sha}) -> %%% TLS 1.2 PSK Cipher Suites RFC 5487 +suite({psk, aes_128_gcm, null}) -> + ?TLS_PSK_WITH_AES_128_GCM_SHA256; +suite({psk, aes_256_gcm, null}) -> + ?TLS_PSK_WITH_AES_256_GCM_SHA384; +suite({dhe_psk, aes_128_gcm, null}) -> + ?TLS_DHE_PSK_WITH_AES_128_GCM_SHA256; +suite({dhe_psk, aes_256_gcm, null}) -> + ?TLS_DHE_PSK_WITH_AES_256_GCM_SHA384; +suite({rsa_psk, aes_128_gcm, null}) -> + ?TLS_RSA_PSK_WITH_AES_128_GCM_SHA256; +suite({rsa_psk, aes_256_gcm, null}) -> + ?TLS_RSA_PSK_WITH_AES_256_GCM_SHA384; + suite({psk, aes_128_cbc, sha256}) -> ?TLS_PSK_WITH_AES_128_CBC_SHA256; suite({psk, aes_256_cbc, sha384}) -> @@ -760,7 +934,60 @@ suite({ecdhe_rsa, aes_256_cbc, sha384}) -> suite({ecdh_rsa, aes_128_cbc, sha256}) -> ?TLS_ECDH_RSA_WITH_AES_128_CBC_SHA256; suite({ecdh_rsa, aes_256_cbc, sha384}) -> - ?TLS_ECDH_RSA_WITH_AES_256_CBC_SHA384. + ?TLS_ECDH_RSA_WITH_AES_256_CBC_SHA384; + +%% RFC 5288 AES-GCM Cipher Suites +suite({rsa, aes_128_gcm, null}) -> + ?TLS_RSA_WITH_AES_128_GCM_SHA256; +suite({rsa, aes_256_gcm, null}) -> + ?TLS_RSA_WITH_AES_256_GCM_SHA384; +suite({dhe_rsa, aes_128_gcm, null}) -> + ?TLS_DHE_RSA_WITH_AES_128_GCM_SHA256; +suite({dhe_rsa, aes_256_gcm, null}) -> + ?TLS_DHE_RSA_WITH_AES_256_GCM_SHA384; +suite({dh_rsa, aes_128_gcm, null}) -> + ?TLS_DH_RSA_WITH_AES_128_GCM_SHA256; +suite({dh_rsa, aes_256_gcm, null}) -> + ?TLS_DH_RSA_WITH_AES_256_GCM_SHA384; +suite({dhe_dss, aes_128_gcm, null}) -> + ?TLS_DHE_DSS_WITH_AES_128_GCM_SHA256; +suite({dhe_dss, aes_256_gcm, null}) -> + ?TLS_DHE_DSS_WITH_AES_256_GCM_SHA384; +suite({dh_dss, aes_128_gcm, null}) -> + ?TLS_DH_DSS_WITH_AES_128_GCM_SHA256; +suite({dh_dss, aes_256_gcm, null}) -> + ?TLS_DH_DSS_WITH_AES_256_GCM_SHA384; +suite({dh_anon, aes_128_gcm, null}) -> + ?TLS_DH_anon_WITH_AES_128_GCM_SHA256; +suite({dh_anon, aes_256_gcm, null}) -> + ?TLS_DH_anon_WITH_AES_256_GCM_SHA384; + +%% RFC 5289 ECC AES-GCM Cipher Suites +suite({ecdhe_ecdsa, aes_128_gcm, null}) -> + ?TLS_ECDHE_ECDSA_WITH_AES_128_GCM_SHA256; +suite({ecdhe_ecdsa, aes_256_gcm, null}) -> + ?TLS_ECDHE_ECDSA_WITH_AES_256_GCM_SHA384; +suite({ecdh_ecdsa, aes_128_gcm, null}) -> + ?TLS_ECDH_ECDSA_WITH_AES_128_GCM_SHA256; +suite({ecdh_ecdsa, aes_256_gcm, null}) -> + ?TLS_ECDH_ECDSA_WITH_AES_256_GCM_SHA384; +suite({ecdhe_rsa, aes_128_gcm, null}) -> + ?TLS_ECDHE_RSA_WITH_AES_128_GCM_SHA256; +suite({ecdhe_rsa, aes_256_gcm, null}) -> + ?TLS_ECDHE_RSA_WITH_AES_256_GCM_SHA384; +suite({ecdh_rsa, aes_128_gcm, null}) -> + ?TLS_ECDH_RSA_WITH_AES_128_GCM_SHA256; +suite({ecdh_rsa, aes_256_gcm, null}) -> + ?TLS_ECDH_RSA_WITH_AES_256_GCM_SHA384; + + +%% draft-agl-tls-chacha20poly1305-04 Chacha20/Poly1305 Suites +suite({ecdhe_rsa, chacha20_poly1305, null}) -> + ?TLS_ECDHE_RSA_WITH_CHACHA20_POLY1305_SHA256; +suite({ecdhe_ecdsa, chacha20_poly1305, null}) -> + ?TLS_ECDHE_ECDSA_WITH_CHACHA20_POLY1305_SHA256; +suite({dhe_rsa, chacha20_poly1305, null}) -> + ?TLS_DHE_RSA_WITH_CHACHA20_POLY1305_SHA256. %%-------------------------------------------------------------------- -spec openssl_suite(openssl_cipher_suite()) -> cipher_suite(). @@ -875,7 +1102,47 @@ openssl_suite("ECDHE-RSA-AES256-SHA384") -> openssl_suite("ECDH-RSA-AES128-SHA256") -> ?TLS_ECDH_RSA_WITH_AES_128_CBC_SHA256; openssl_suite("ECDH-RSA-AES256-SHA384") -> - ?TLS_ECDH_RSA_WITH_AES_256_CBC_SHA384. + ?TLS_ECDH_RSA_WITH_AES_256_CBC_SHA384; + +%% RFC 5288 AES-GCM Cipher Suites +openssl_suite("AES128-GCM-SHA256") -> + ?TLS_RSA_WITH_AES_128_GCM_SHA256; +openssl_suite("AES256-GCM-SHA384") -> + ?TLS_RSA_WITH_AES_256_GCM_SHA384; +openssl_suite("DHE-RSA-AES128-GCM-SHA256") -> + ?TLS_DHE_RSA_WITH_AES_128_GCM_SHA256; +openssl_suite("DHE-RSA-AES256-GCM-SHA384") -> + ?TLS_DHE_RSA_WITH_AES_256_GCM_SHA384; +openssl_suite("DH-RSA-AES128-GCM-SHA256") -> + ?TLS_DH_RSA_WITH_AES_128_GCM_SHA256; +openssl_suite("DH-RSA-AES256-GCM-SHA384") -> + ?TLS_DH_RSA_WITH_AES_256_GCM_SHA384; +openssl_suite("DHE-DSS-AES128-GCM-SHA256") -> + ?TLS_DHE_DSS_WITH_AES_128_GCM_SHA256; +openssl_suite("DHE-DSS-AES256-GCM-SHA384") -> + ?TLS_DHE_DSS_WITH_AES_256_GCM_SHA384; +openssl_suite("DH-DSS-AES128-GCM-SHA256") -> + ?TLS_DH_DSS_WITH_AES_128_GCM_SHA256; +openssl_suite("DH-DSS-AES256-GCM-SHA384") -> + ?TLS_DH_DSS_WITH_AES_256_GCM_SHA384; + +%% RFC 5289 ECC AES-GCM Cipher Suites +openssl_suite("ECDHE-ECDSA-AES128-GCM-SHA256") -> + ?TLS_ECDHE_ECDSA_WITH_AES_128_GCM_SHA256; +openssl_suite("ECDHE-ECDSA-AES256-GCM-SHA384") -> + ?TLS_ECDHE_ECDSA_WITH_AES_256_GCM_SHA384; +openssl_suite("ECDH-ECDSA-AES128-GCM-SHA256") -> + ?TLS_ECDH_ECDSA_WITH_AES_128_GCM_SHA256; +openssl_suite("ECDH-ECDSA-AES256-GCM-SHA384") -> + ?TLS_ECDH_ECDSA_WITH_AES_256_GCM_SHA384; +openssl_suite("ECDHE-RSA-AES128-GCM-SHA256") -> + ?TLS_ECDHE_RSA_WITH_AES_128_GCM_SHA256; +openssl_suite("ECDHE-RSA-AES256-GCM-SHA384") -> + ?TLS_ECDHE_RSA_WITH_AES_256_GCM_SHA384; +openssl_suite("ECDH-RSA-AES128-GCM-SHA256") -> + ?TLS_ECDH_RSA_WITH_AES_128_GCM_SHA256; +openssl_suite("ECDH-RSA-AES256-GCM-SHA384") -> + ?TLS_ECDH_RSA_WITH_AES_256_GCM_SHA384. %%-------------------------------------------------------------------- -spec openssl_suite_name(cipher_suite()) -> openssl_cipher_suite(). @@ -1012,6 +1279,46 @@ openssl_suite_name(?TLS_ECDH_RSA_WITH_AES_128_CBC_SHA256) -> openssl_suite_name(?TLS_ECDH_RSA_WITH_AES_256_CBC_SHA384) -> "ECDH-RSA-AES256-SHA384"; +%% RFC 5288 AES-GCM Cipher Suites +openssl_suite_name(?TLS_RSA_WITH_AES_128_GCM_SHA256) -> + "AES128-GCM-SHA256"; +openssl_suite_name(?TLS_RSA_WITH_AES_256_GCM_SHA384) -> + "AES256-GCM-SHA384"; +openssl_suite_name(?TLS_DHE_RSA_WITH_AES_128_GCM_SHA256) -> + "DHE-RSA-AES128-GCM-SHA256"; +openssl_suite_name(?TLS_DHE_RSA_WITH_AES_256_GCM_SHA384) -> + "DHE-RSA-AES256-GCM-SHA384"; +openssl_suite_name(?TLS_DH_RSA_WITH_AES_128_GCM_SHA256) -> + "DH-RSA-AES128-GCM-SHA256"; +openssl_suite_name(?TLS_DH_RSA_WITH_AES_256_GCM_SHA384) -> + "DH-RSA-AES256-GCM-SHA384"; +openssl_suite_name(?TLS_DHE_DSS_WITH_AES_128_GCM_SHA256) -> + "DHE-DSS-AES128-GCM-SHA256"; +openssl_suite_name(?TLS_DHE_DSS_WITH_AES_256_GCM_SHA384) -> + "DHE-DSS-AES256-GCM-SHA384"; +openssl_suite_name(?TLS_DH_DSS_WITH_AES_128_GCM_SHA256) -> + "DH-DSS-AES128-GCM-SHA256"; +openssl_suite_name(?TLS_DH_DSS_WITH_AES_256_GCM_SHA384) -> + "DH-DSS-AES256-GCM-SHA384"; + +%% RFC 5289 ECC AES-GCM Cipher Suites +openssl_suite_name(?TLS_ECDHE_ECDSA_WITH_AES_128_GCM_SHA256) -> + "ECDHE-ECDSA-AES128-GCM-SHA256"; +openssl_suite_name(?TLS_ECDHE_ECDSA_WITH_AES_256_GCM_SHA384) -> + "ECDHE-ECDSA-AES256-GCM-SHA384"; +openssl_suite_name(?TLS_ECDH_ECDSA_WITH_AES_128_GCM_SHA256) -> + "ECDH-ECDSA-AES128-GCM-SHA256"; +openssl_suite_name(?TLS_ECDH_ECDSA_WITH_AES_256_GCM_SHA384) -> + "ECDH-ECDSA-AES256-GCM-SHA384"; +openssl_suite_name(?TLS_ECDHE_RSA_WITH_AES_128_GCM_SHA256) -> + "ECDHE-RSA-AES128-GCM-SHA256"; +openssl_suite_name(?TLS_ECDHE_RSA_WITH_AES_256_GCM_SHA384) -> + "ECDHE-RSA-AES256-GCM-SHA384"; +openssl_suite_name(?TLS_ECDH_RSA_WITH_AES_128_GCM_SHA256) -> + "ECDH-RSA-AES128-GCM-SHA256"; +openssl_suite_name(?TLS_ECDH_RSA_WITH_AES_256_GCM_SHA384) -> + "ECDH-RSA-AES256-GCM-SHA384"; + %% No oppenssl name openssl_suite_name(Cipher) -> suite_definition(Cipher). @@ -1095,6 +1402,13 @@ is_acceptable_keyexchange(KeyExchange, Algos) is_acceptable_keyexchange(_, _) -> true. +is_acceptable_cipher(Cipher, Algos) + when Cipher == aes_128_gcm; + Cipher == aes_256_gcm -> + proplists:get_bool(aes_gcm, Algos); +is_acceptable_cipher(Cipher, Algos) + when Cipher == chacha20_poly1305 -> + proplists:get_bool(Cipher, Algos); is_acceptable_cipher(_, _) -> true. @@ -1122,7 +1436,12 @@ bulk_cipher_algorithm('3des_ede_cbc') -> ?'3DES'; bulk_cipher_algorithm(Cipher) when Cipher == aes_128_cbc; Cipher == aes_256_cbc -> - ?AES. + ?AES_CBC; +bulk_cipher_algorithm(Cipher) when Cipher == aes_128_gcm; + Cipher == aes_256_gcm -> + ?AES_GCM; +bulk_cipher_algorithm(chacha20_poly1305) -> + ?CHACHA20_POLY1305. type(Cipher) when Cipher == null; Cipher == rc4_128 -> @@ -1132,7 +1451,11 @@ type(Cipher) when Cipher == des_cbc; Cipher == '3des_ede_cbc'; Cipher == aes_128_cbc; Cipher == aes_256_cbc -> - ?BLOCK. + ?BLOCK; +type(Cipher) when Cipher == aes_128_gcm; + Cipher == aes_256_gcm; + Cipher == chacha20_poly1305 -> + ?AEAD. key_material(null) -> 0; @@ -1145,6 +1468,12 @@ key_material('3des_ede_cbc') -> key_material(aes_128_cbc) -> 16; key_material(aes_256_cbc) -> + 32; +key_material(aes_128_gcm) -> + 16; +key_material(aes_256_gcm) -> + 32; +key_material(chacha20_poly1305) -> 32. expanded_key_material(null) -> @@ -1156,7 +1485,10 @@ expanded_key_material(Cipher) when Cipher == des_cbc -> expanded_key_material('3des_ede_cbc') -> 24; expanded_key_material(Cipher) when Cipher == aes_128_cbc; - Cipher == aes_256_cbc -> + Cipher == aes_256_cbc; + Cipher == aes_128_gcm; + Cipher == aes_256_gcm; + Cipher == chacha20_poly1305 -> unknown. @@ -1165,16 +1497,25 @@ effective_key_bits(null) -> effective_key_bits(des_cbc) -> 56; effective_key_bits(Cipher) when Cipher == rc4_128; - Cipher == aes_128_cbc -> + Cipher == aes_128_cbc; + Cipher == aes_128_gcm -> 128; effective_key_bits('3des_ede_cbc') -> 168; -effective_key_bits(aes_256_cbc) -> +effective_key_bits(Cipher) when Cipher == aes_256_cbc; + Cipher == aes_256_gcm; + Cipher == chacha20_poly1305 -> 256. iv_size(Cipher) when Cipher == null; - Cipher == rc4_128 -> + Cipher == rc4_128; + Cipher == chacha20_poly1305-> 0; + +iv_size(Cipher) when Cipher == aes_128_gcm; + Cipher == aes_256_gcm -> + 4; + iv_size(Cipher) -> block_size(Cipher). @@ -1183,7 +1524,10 @@ block_size(Cipher) when Cipher == des_cbc; 8; block_size(Cipher) when Cipher == aes_128_cbc; - Cipher == aes_256_cbc -> + Cipher == aes_256_cbc; + Cipher == aes_128_gcm; + Cipher == aes_256_gcm; + Cipher == chacha20_poly1305 -> 16. prf_algorithm(default_prf, {3, N}) when N >= 3 -> @@ -1337,10 +1681,15 @@ dhe_rsa_suites() -> ?TLS_DHE_RSA_WITH_3DES_EDE_CBC_SHA, ?TLS_DHE_RSA_WITH_AES_128_CBC_SHA256, ?TLS_DHE_RSA_WITH_AES_128_CBC_SHA, - ?TLS_DHE_RSA_WITH_DES_CBC_SHA]. + ?TLS_DHE_RSA_WITH_DES_CBC_SHA, + ?TLS_DHE_RSA_WITH_AES_128_GCM_SHA256, + ?TLS_DHE_RSA_WITH_AES_256_GCM_SHA384, + ?TLS_DHE_RSA_WITH_CHACHA20_POLY1305_SHA256]. psk_rsa_suites() -> - [?TLS_RSA_PSK_WITH_AES_256_CBC_SHA384, + [?TLS_RSA_PSK_WITH_AES_256_GCM_SHA384, + ?TLS_RSA_PSK_WITH_AES_128_GCM_SHA256, + ?TLS_RSA_PSK_WITH_AES_256_CBC_SHA384, ?TLS_RSA_PSK_WITH_AES_128_CBC_SHA256, ?TLS_RSA_PSK_WITH_AES_256_CBC_SHA, ?TLS_RSA_PSK_WITH_AES_128_CBC_SHA, @@ -1360,7 +1709,9 @@ rsa_suites() -> ?TLS_RSA_WITH_AES_128_CBC_SHA, ?TLS_RSA_WITH_RC4_128_SHA, ?TLS_RSA_WITH_RC4_128_MD5, - ?TLS_RSA_WITH_DES_CBC_SHA]. + ?TLS_RSA_WITH_DES_CBC_SHA, + ?TLS_RSA_WITH_AES_128_GCM_SHA256, + ?TLS_RSA_WITH_AES_256_GCM_SHA384]. ecdh_rsa_suites() -> [?TLS_ECDH_RSA_WITH_NULL_SHA, @@ -1369,7 +1720,9 @@ ecdh_rsa_suites() -> ?TLS_ECDH_RSA_WITH_AES_128_CBC_SHA, ?TLS_ECDH_RSA_WITH_AES_256_CBC_SHA, ?TLS_ECDH_RSA_WITH_AES_128_CBC_SHA256, - ?TLS_ECDH_RSA_WITH_AES_256_CBC_SHA384]. + ?TLS_ECDH_RSA_WITH_AES_256_CBC_SHA384, + ?TLS_ECDH_RSA_WITH_AES_128_GCM_SHA256, + ?TLS_ECDH_RSA_WITH_AES_256_GCM_SHA384]. ecdhe_rsa_suites() -> [?TLS_ECDHE_RSA_WITH_NULL_SHA, @@ -1378,7 +1731,10 @@ ecdhe_rsa_suites() -> ?TLS_ECDHE_RSA_WITH_AES_128_CBC_SHA, ?TLS_ECDHE_RSA_WITH_AES_256_CBC_SHA, ?TLS_ECDHE_RSA_WITH_AES_128_CBC_SHA256, - ?TLS_ECDHE_RSA_WITH_AES_256_CBC_SHA384]. + ?TLS_ECDHE_RSA_WITH_AES_256_CBC_SHA384, + ?TLS_ECDHE_RSA_WITH_AES_128_GCM_SHA256, + ?TLS_ECDHE_RSA_WITH_AES_256_GCM_SHA384, + ?TLS_ECDHE_RSA_WITH_CHACHA20_POLY1305_SHA256]. dsa_signed_suites() -> dhe_dss_suites() ++ srp_dss_suites(). @@ -1389,7 +1745,9 @@ dhe_dss_suites() -> ?TLS_DHE_DSS_WITH_3DES_EDE_CBC_SHA, ?TLS_DHE_DSS_WITH_AES_128_CBC_SHA256, ?TLS_DHE_DSS_WITH_AES_128_CBC_SHA, - ?TLS_DHE_DSS_WITH_3DES_EDE_CBC_SHA]. + ?TLS_DHE_DSS_WITH_3DES_EDE_CBC_SHA, + ?TLS_DHE_DSS_WITH_AES_128_GCM_SHA256, + ?TLS_DHE_DSS_WITH_AES_256_GCM_SHA384]. srp_dss_suites() -> [?TLS_SRP_SHA_DSS_WITH_3DES_EDE_CBC_SHA, @@ -1413,7 +1771,9 @@ ecdh_ecdsa_suites() -> ?TLS_ECDH_ECDSA_WITH_AES_128_CBC_SHA, ?TLS_ECDH_ECDSA_WITH_AES_256_CBC_SHA, ?TLS_ECDH_ECDSA_WITH_AES_128_CBC_SHA256, - ?TLS_ECDH_ECDSA_WITH_AES_256_CBC_SHA384]. + ?TLS_ECDH_ECDSA_WITH_AES_256_CBC_SHA384, + ?TLS_ECDH_ECDSA_WITH_AES_128_GCM_SHA256, + ?TLS_ECDH_ECDSA_WITH_AES_256_GCM_SHA384]. ecdhe_ecdsa_suites() -> [?TLS_ECDHE_ECDSA_WITH_NULL_SHA, @@ -1422,7 +1782,10 @@ ecdhe_ecdsa_suites() -> ?TLS_ECDHE_ECDSA_WITH_AES_128_CBC_SHA, ?TLS_ECDHE_ECDSA_WITH_AES_256_CBC_SHA, ?TLS_ECDHE_ECDSA_WITH_AES_128_CBC_SHA256, - ?TLS_ECDHE_ECDSA_WITH_AES_256_CBC_SHA384]. + ?TLS_ECDHE_ECDSA_WITH_AES_256_CBC_SHA384, + ?TLS_ECDHE_ECDSA_WITH_AES_128_GCM_SHA256, + ?TLS_ECDHE_ECDSA_WITH_AES_256_GCM_SHA384, + ?TLS_ECDHE_ECDSA_WITH_CHACHA20_POLY1305_SHA256]. filter_keyuse(OtpCert, Ciphers, Suites, SignSuites) -> TBSCert = OtpCert#'OTPCertificate'.tbsCertificate, diff --git a/lib/ssl/src/ssl_cipher.hrl b/lib/ssl/src/ssl_cipher.hrl index 3ce9c19aa9..448c2405aa 100644 --- a/lib/ssl/src/ssl_cipher.hrl +++ b/lib/ssl/src/ssl_cipher.hrl @@ -46,7 +46,8 @@ -record(cipher_state, { iv, key, - state + state, + nonce }). %%% TLS_NULL_WITH_NULL_NULL is specified and is the initial state of a @@ -395,6 +396,24 @@ %%% TLS 1.2 PSK Cipher Suites RFC 5487 +%% TLS_PSK_WITH_AES_128_GCM_SHA256 = {0x00,0xA8}; +-define(TLS_PSK_WITH_AES_128_GCM_SHA256, <<?BYTE(16#00), ?BYTE(16#A8)>>). + +%% TLS_PSK_WITH_AES_256_GCM_SHA384 = {0x00,0xA9}; +-define(TLS_PSK_WITH_AES_256_GCM_SHA384, <<?BYTE(16#00), ?BYTE(16#A9)>>). + +%% TLS_DHE_PSK_WITH_AES_128_GCM_SHA256 = {0x00,0xAA}; +-define(TLS_DHE_PSK_WITH_AES_128_GCM_SHA256, <<?BYTE(16#00), ?BYTE(16#AA)>>). + +%% TLS_DHE_PSK_WITH_AES_256_GCM_SHA384 = {0x00,0xAB}; +-define(TLS_DHE_PSK_WITH_AES_256_GCM_SHA384, <<?BYTE(16#00), ?BYTE(16#AB)>>). + +%% TLS_RSA_PSK_WITH_AES_128_GCM_SHA256 = {0x00,0xAC}; +-define(TLS_RSA_PSK_WITH_AES_128_GCM_SHA256, <<?BYTE(16#00), ?BYTE(16#AC)>>). + +%% TLS_RSA_PSK_WITH_AES_256_GCM_SHA384 = {0x00,0xAD}; +-define(TLS_RSA_PSK_WITH_AES_256_GCM_SHA384, <<?BYTE(16#00), ?BYTE(16#AD)>>). + %% TLS_PSK_WITH_AES_128_CBC_SHA256 = {0x00,0xAE}; -define(TLS_PSK_WITH_AES_128_CBC_SHA256, <<?BYTE(16#00), ?BYTE(16#AE)>>). @@ -460,4 +479,79 @@ %% TLS_SRP_SHA_DSS_WITH_AES_256_CBC_SHA = { 0xC0,0x22 }; -define(TLS_SRP_SHA_DSS_WITH_AES_256_CBC_SHA, <<?BYTE(16#C0), ?BYTE(16#22)>>). +%%% AES-GCM Cipher Suites RFC 5288 + +%% TLS_RSA_WITH_AES_128_GCM_SHA256 = {0x00,0x9C} +-define(TLS_RSA_WITH_AES_128_GCM_SHA256, <<?BYTE(16#00), ?BYTE(16#9C)>>). + +%% TLS_RSA_WITH_AES_256_GCM_SHA384 = {0x00,0x9D} +-define(TLS_RSA_WITH_AES_256_GCM_SHA384, <<?BYTE(16#00), ?BYTE(16#9D)>>). + +%% TLS_DHE_RSA_WITH_AES_128_GCM_SHA256 = {0x00,0x9E} +-define(TLS_DHE_RSA_WITH_AES_128_GCM_SHA256, <<?BYTE(16#00), ?BYTE(16#9E)>>). + +%% TLS_DHE_RSA_WITH_AES_256_GCM_SHA384 = {0x00,0x9F} +-define(TLS_DHE_RSA_WITH_AES_256_GCM_SHA384, <<?BYTE(16#00), ?BYTE(16#9F)>>). + +%% TLS_DH_RSA_WITH_AES_128_GCM_SHA256 = {0x00,0xA0} +-define(TLS_DH_RSA_WITH_AES_128_GCM_SHA256, <<?BYTE(16#00), ?BYTE(16#A0)>>). + +%% TLS_DH_RSA_WITH_AES_256_GCM_SHA384 = {0x00,0xA1} +-define(TLS_DH_RSA_WITH_AES_256_GCM_SHA384, <<?BYTE(16#00), ?BYTE(16#A1)>>). + +%% TLS_DHE_DSS_WITH_AES_128_GCM_SHA256 = {0x00,0xA2} +-define(TLS_DHE_DSS_WITH_AES_128_GCM_SHA256, <<?BYTE(16#00), ?BYTE(16#A2)>>). + +%% TLS_DHE_DSS_WITH_AES_256_GCM_SHA384 = {0x00,0xA3} +-define(TLS_DHE_DSS_WITH_AES_256_GCM_SHA384, <<?BYTE(16#00), ?BYTE(16#A3)>>). + +%% TLS_DH_DSS_WITH_AES_128_GCM_SHA256 = {0x00,0xA4} +-define(TLS_DH_DSS_WITH_AES_128_GCM_SHA256, <<?BYTE(16#00), ?BYTE(16#A4)>>). + +%% TLS_DH_DSS_WITH_AES_256_GCM_SHA384 = {0x00,0xA5} +-define(TLS_DH_DSS_WITH_AES_256_GCM_SHA384, <<?BYTE(16#00), ?BYTE(16#A5)>>). + +%% TLS_DH_anon_WITH_AES_128_GCM_SHA256 = {0x00,0xA6} +-define(TLS_DH_anon_WITH_AES_128_GCM_SHA256, <<?BYTE(16#00), ?BYTE(16#A6)>>). + +%% TLS_DH_anon_WITH_AES_256_GCM_SHA384 = {0x00,0xA7} +-define(TLS_DH_anon_WITH_AES_256_GCM_SHA384, <<?BYTE(16#00), ?BYTE(16#A7)>>). + +%%% ECC AES-GCM Cipher Suites RFC 5289 + +%% TLS_ECDHE_ECDSA_WITH_AES_128_GCM_SHA256 = {0xC0,0x2B}; +-define(TLS_ECDHE_ECDSA_WITH_AES_128_GCM_SHA256, <<?BYTE(16#C0), ?BYTE(16#2B)>>). + +%% TLS_ECDHE_ECDSA_WITH_AES_256_GCM_SHA384 = {0xC0,0x2C}; +-define(TLS_ECDHE_ECDSA_WITH_AES_256_GCM_SHA384, <<?BYTE(16#C0), ?BYTE(16#2C)>>). + +%% TLS_ECDH_ECDSA_WITH_AES_128_GCM_SHA256 = {0xC0,0x2D}; +-define(TLS_ECDH_ECDSA_WITH_AES_128_GCM_SHA256, <<?BYTE(16#C0), ?BYTE(16#2D)>>). + +%% TLS_ECDH_ECDSA_WITH_AES_256_GCM_SHA384 = {0xC0,0x2E}; +-define(TLS_ECDH_ECDSA_WITH_AES_256_GCM_SHA384, <<?BYTE(16#C0), ?BYTE(16#2E)>>). + +%% TLS_ECDHE_RSA_WITH_AES_128_GCM_SHA256 = {0xC0,0x2F}; +-define(TLS_ECDHE_RSA_WITH_AES_128_GCM_SHA256, <<?BYTE(16#C0), ?BYTE(16#2F)>>). + +%% TLS_ECDHE_RSA_WITH_AES_256_GCM_SHA384 = {0xC0,0x30}; +-define(TLS_ECDHE_RSA_WITH_AES_256_GCM_SHA384, <<?BYTE(16#C0), ?BYTE(16#30)>>). + +%% TLS_ECDH_RSA_WITH_AES_128_GCM_SHA256 = {0xC0,0x31}; +-define(TLS_ECDH_RSA_WITH_AES_128_GCM_SHA256, <<?BYTE(16#C0), ?BYTE(16#31)>>). + +%% TLS_ECDH_RSA_WITH_AES_256_GCM_SHA384 = {0xC0,0x32}; +-define(TLS_ECDH_RSA_WITH_AES_256_GCM_SHA384, <<?BYTE(16#C0), ?BYTE(16#32)>>). + +%%% Chacha20/Poly1305 Suites draft-agl-tls-chacha20poly1305-04 + +%% TLS_ECDHE_RSA_WITH_CHACHA20_POLY1305_SHA256 = {0xcc, 0x13} +-define(TLS_ECDHE_RSA_WITH_CHACHA20_POLY1305_SHA256, <<?BYTE(16#CC), ?BYTE(16#13)>>). + +%% TLS_ECDHE_ECDSA_WITH_CHACHA20_POLY1305_SHA256 = {0xcc, 0x14} +-define(TLS_ECDHE_ECDSA_WITH_CHACHA20_POLY1305_SHA256, <<?BYTE(16#CC), ?BYTE(16#14)>>). + +%% TLS_DHE_RSA_WITH_CHACHA20_POLY1305_SHA256 = {0xcc, 0x15} +-define(TLS_DHE_RSA_WITH_CHACHA20_POLY1305_SHA256, <<?BYTE(16#CC), ?BYTE(16#15)>>). + -endif. % -ifdef(ssl_cipher). diff --git a/lib/ssl/src/ssl_handshake.erl b/lib/ssl/src/ssl_handshake.erl index 88ccb94e0b..07535e79b4 100644 --- a/lib/ssl/src/ssl_handshake.erl +++ b/lib/ssl/src/ssl_handshake.erl @@ -1435,6 +1435,7 @@ calc_finished({3, N}, Role, PrfAlgo, MasterSecret, Handshake) -> master_secret(_RecordCB, Version, MasterSecret, #security_parameters{ + bulk_cipher_algorithm = BCA, client_random = ClientRandom, server_random = ServerRandom, hash_size = HashSize, @@ -1453,8 +1454,8 @@ master_secret(_RecordCB, Version, MasterSecret, ssl_record:set_mac_secret(ClientWriteMacSecret, ServerWriteMacSecret, Role, ConnStates1), - ClientCipherState = #cipher_state{iv = ClientIV, key = ClientWriteKey}, - ServerCipherState = #cipher_state{iv = ServerIV, key = ServerWriteKey}, + ClientCipherState = ssl_cipher:cipher_init(BCA, ClientIV, ClientWriteKey), + ServerCipherState = ssl_cipher:cipher_init(BCA, ServerIV, ServerWriteKey), {MasterSecret, ssl_record:set_pending_cipher_state(ConnStates2, ClientCipherState, ServerCipherState, Role)}. diff --git a/lib/ssl/src/ssl_manager.erl b/lib/ssl/src/ssl_manager.erl index d6e5064c39..5553fc9220 100644 --- a/lib/ssl/src/ssl_manager.erl +++ b/lib/ssl/src/ssl_manager.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2007-2013. All Rights Reserved. +%% Copyright Ericsson AB 2007-2014. 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 @@ -44,7 +44,8 @@ -include_lib("kernel/include/file.hrl"). -record(state, { - session_cache, + session_cache_client, + session_cache_server, session_cache_cb, session_lifetime, certificate_db, @@ -209,12 +210,16 @@ init([Name, Opts]) -> SessionLifeTime = proplists:get_value(session_lifetime, Opts, ?'24H_in_sec'), CertDb = ssl_pkix_db:create(), - SessionCache = CacheCb:init(proplists:get_value(session_cb_init_args, Opts, [])), + ClientSessionCache = CacheCb:init([{role, client} | + proplists:get_value(session_cb_init_args, Opts, [])]), + ServerSessionCache = CacheCb:init([{role, server} | + proplists:get_value(session_cb_init_args, Opts, [])]), Timer = erlang:send_after(SessionLifeTime * 1000 + 5000, self(), validate_sessions), erlang:send_after(?CLEAR_PEM_CACHE, self(), clear_pem_cache), {ok, #state{certificate_db = CertDb, - session_cache = SessionCache, + session_cache_client = ClientSessionCache, + session_cache_server = ServerSessionCache, session_cache_cb = CacheCb, session_lifetime = SessionLifeTime, session_validation_timer = Timer}}. @@ -230,15 +235,32 @@ init([Name, Opts]) -> %% %% Description: Handling call messages %%-------------------------------------------------------------------- -handle_call({{connection_init, <<>>, _Role}, _Pid}, _From, +handle_call({{connection_init, <<>>, client}, _Pid}, _From, #state{certificate_db = [CertDb, FileRefDb, PemChace], - session_cache = Cache} = State) -> + session_cache_client = Cache} = State) -> + Result = {ok, make_ref(),CertDb, FileRefDb, PemChace, Cache}, + {reply, Result, State}; +handle_call({{connection_init, <<>>, server}, _Pid}, _From, + #state{certificate_db = [CertDb, FileRefDb, PemChace], + session_cache_server = Cache} = State) -> Result = {ok, make_ref(),CertDb, FileRefDb, PemChace, Cache}, {reply, Result, State}; -handle_call({{connection_init, Trustedcerts, _Role}, Pid}, _From, +handle_call({{connection_init, Trustedcerts, client}, Pid}, _From, + #state{certificate_db = [CertDb, FileRefDb, PemChace] = Db, + session_cache_client = Cache} = State) -> + Result = + try + {ok, Ref} = ssl_pkix_db:add_trusted_certs(Pid, Trustedcerts, Db), + {ok, Ref, CertDb, FileRefDb, PemChace, Cache} + catch + _:Reason -> + {error, Reason} + end, + {reply, Result, State}; +handle_call({{connection_init, Trustedcerts, server}, Pid}, _From, #state{certificate_db = [CertDb, FileRefDb, PemChace] = Db, - session_cache = Cache} = State) -> + session_cache_server = Cache} = State) -> Result = try {ok, Ref} = ssl_pkix_db:add_trusted_certs(Pid, Trustedcerts, Db), @@ -249,9 +271,10 @@ handle_call({{connection_init, Trustedcerts, _Role}, Pid}, _From, end, {reply, Result, State}; + handle_call({{new_session_id,Port}, _}, _, #state{session_cache_cb = CacheCb, - session_cache = Cache} = State) -> + session_cache_server = Cache} = State) -> Id = new_id(Port, ?GEN_UNIQUE_ID_MAX_TRIES, Cache, CacheCb), {reply, Id, State}; @@ -278,16 +301,22 @@ handle_call({unconditionally_clear_pem_cache, _},_, #state{certificate_db = [_,_ %% Description: Handling cast messages %%-------------------------------------------------------------------- handle_cast({register_session, Host, Port, Session}, - #state{session_cache = Cache, + #state{session_cache_client = Cache, session_cache_cb = CacheCb} = State) -> TimeStamp = calendar:datetime_to_gregorian_seconds({date(), time()}), NewSession = Session#session{time_stamp = TimeStamp}, - CacheCb:update(Cache, {{Host, Port}, - NewSession#session.session_id}, NewSession), + + case CacheCb:select_session(Cache, {Host, Port}) of + no_session -> + CacheCb:update(Cache, {{Host, Port}, + NewSession#session.session_id}, NewSession); + Sessions -> + register_unique_session(Sessions, NewSession, CacheCb, Cache, {Host, Port}) + end, {noreply, State}; handle_cast({register_session, Port, Session}, - #state{session_cache = Cache, + #state{session_cache_server = Cache, session_cache_cb = CacheCb} = State) -> TimeStamp = calendar:datetime_to_gregorian_seconds({date(), time()}), NewSession = Session#session{time_stamp = TimeStamp}, @@ -296,12 +325,12 @@ handle_cast({register_session, Port, Session}, handle_cast({invalidate_session, Host, Port, #session{session_id = ID} = Session}, - #state{session_cache = Cache, + #state{session_cache_client = Cache, session_cache_cb = CacheCb} = State) -> invalidate_session(Cache, CacheCb, {{Host, Port}, ID}, Session, State); handle_cast({invalidate_session, Port, #session{session_id = ID} = Session}, - #state{session_cache = Cache, + #state{session_cache_server = Cache, session_cache_cb = CacheCb} = State) -> invalidate_session(Cache, CacheCb, {Port, ID}, Session, State). @@ -314,17 +343,18 @@ handle_cast({invalidate_session, Port, #session{session_id = ID} = Session}, %% Description: Handling all non call/cast messages %%------------------------------------------------------------------- handle_info(validate_sessions, #state{session_cache_cb = CacheCb, - session_cache = Cache, + session_cache_client = ClientCache, + session_cache_server = ServerCache, session_lifetime = LifeTime } = State) -> Timer = erlang:send_after(?SESSION_VALIDATION_INTERVAL, self(), validate_sessions), - start_session_validator(Cache, CacheCb, LifeTime), + start_session_validator(ClientCache, CacheCb, LifeTime), + start_session_validator(ServerCache, CacheCb, LifeTime), {noreply, State#state{session_validation_timer = Timer}}; -handle_info({delayed_clean_session, Key}, #state{session_cache = Cache, - session_cache_cb = CacheCb - } = State) -> +handle_info({delayed_clean_session, Key, Cache}, #state{session_cache_cb = CacheCb + } = State) -> CacheCb:delete(Cache, Key), {noreply, State}; @@ -367,12 +397,14 @@ handle_info(_Info, State) -> %% The return value is ignored. %%-------------------------------------------------------------------- terminate(_Reason, #state{certificate_db = Db, - session_cache = SessionCache, + session_cache_client = ClientSessionCache, + session_cache_server = ServerSessionCache, session_cache_cb = CacheCb, session_validation_timer = Timer}) -> erlang:cancel_timer(Timer), ssl_pkix_db:remove(Db), - CacheCb:terminate(SessionCache), + catch CacheCb:terminate(ClientSessionCache), + catch CacheCb:terminate(ServerSessionCache), ok. %%-------------------------------------------------------------------- @@ -445,7 +477,7 @@ invalidate_session(Cache, CacheCb, Key, Session, #state{last_delay_timer = LastT %% up the session data but new connections should not get to use this session. CacheCb:update(Cache, Key, Session#session{is_resumable = false}), TRef = - erlang:send_after(delay_time(), self(), {delayed_clean_session, Key}), + erlang:send_after(delay_time(), self(), {delayed_clean_session, Key, Cache}), {noreply, State#state{last_delay_timer = last_delay_timer(Key, TRef, LastTimer)}} end. @@ -494,3 +526,34 @@ clean_cert_db(Ref, CertDb, RefDb, PemCache, File) -> _ -> ok end. + +%% Do not let dumb clients create a gigantic session table +%% for itself creating big delays at connection time. +register_unique_session(Sessions, Session, CacheCb, Cache, PartialKey) -> + case exists_equivalent(Session , Sessions) of + true -> + ok; + false -> + CacheCb:update(Cache, {PartialKey, + Session#session.session_id}, Session) + end. + +exists_equivalent(_, []) -> + false; +exists_equivalent(#session{ + peer_certificate = PeerCert, + own_certificate = OwnCert, + compression_method = Compress, + cipher_suite = CipherSuite, + srp_username = SRP, + ecc = ECC} , + [#session{ + peer_certificate = PeerCert, + own_certificate = OwnCert, + compression_method = Compress, + cipher_suite = CipherSuite, + srp_username = SRP, + ecc = ECC} | _]) -> + true; +exists_equivalent(Session, [ _ | Rest]) -> + exists_equivalent(Session, Rest). diff --git a/lib/ssl/src/ssl_record.erl b/lib/ssl/src/ssl_record.erl index 7337225bc4..63fc57edad 100644 --- a/lib/ssl/src/ssl_record.erl +++ b/lib/ssl/src/ssl_record.erl @@ -48,7 +48,8 @@ -export([compress/3, uncompress/3, compressions/0]). %% Payload encryption/decryption --export([cipher/4, decipher/3, is_correct_mac/2]). +-export([cipher/4, decipher/3, is_correct_mac/2, + cipher_aead/4, decipher_aead/4]). -export_type([ssl_version/0, ssl_atom_version/0]). @@ -377,6 +378,24 @@ cipher(Version, Fragment, ssl_cipher:cipher(BulkCipherAlgo, CipherS0, MacHash, Fragment, Version), {CipherFragment, WriteState0#connection_state{cipher_state = CipherS1}}. %%-------------------------------------------------------------------- +-spec cipher_aead(ssl_version(), iodata(), #connection_state{}, MacHash::binary()) -> + {CipherFragment::binary(), #connection_state{}}. +%% +%% Description: Payload encryption +%%-------------------------------------------------------------------- +cipher_aead(Version, Fragment, + #connection_state{cipher_state = CipherS0, + sequence_number = SeqNo, + security_parameters= + #security_parameters{bulk_cipher_algorithm = + BulkCipherAlgo} + } = WriteState0, AAD) -> + + {CipherFragment, CipherS1} = + ssl_cipher:cipher_aead(BulkCipherAlgo, CipherS0, SeqNo, AAD, Fragment, Version), + {CipherFragment, WriteState0#connection_state{cipher_state = CipherS1}}. + +%%-------------------------------------------------------------------- -spec decipher(ssl_version(), binary(), #connection_state{}) -> {binary(), binary(), #connection_state{}} | #alert{}. %% %% Description: Payload decryption @@ -396,6 +415,25 @@ decipher(Version, CipherFragment, Alert end. %%-------------------------------------------------------------------- +-spec decipher_aead(ssl_version(), binary(), #connection_state{}, binary()) -> {binary(), binary(), #connection_state{}} | #alert{}. +%% +%% Description: Payload decryption +%%-------------------------------------------------------------------- +decipher_aead(Version, CipherFragment, + #connection_state{sequence_number = SeqNo, + security_parameters = + #security_parameters{bulk_cipher_algorithm = + BulkCipherAlgo}, + cipher_state = CipherS0 + } = ReadState, AAD) -> + case ssl_cipher:decipher_aead(BulkCipherAlgo, CipherS0, SeqNo, AAD, CipherFragment, Version) of + {PlainFragment, CipherS1} -> + CS1 = ReadState#connection_state{cipher_state = CipherS1}, + {PlainFragment, CS1}; + #alert{} = Alert -> + Alert + end. +%%-------------------------------------------------------------------- %%% Internal functions %%-------------------------------------------------------------------- empty_connection_state(ConnectionEnd) -> diff --git a/lib/ssl/src/ssl_record.hrl b/lib/ssl/src/ssl_record.hrl index 6aab35d6da..53b5f2399b 100644 --- a/lib/ssl/src/ssl_record.hrl +++ b/lib/ssl/src/ssl_record.hrl @@ -90,11 +90,14 @@ -define('3DES', 4). -define(DES40, 5). -define(IDEA, 6). --define(AES, 7). +-define(AES_CBC, 7). +-define(AES_GCM, 8). +-define(CHACHA20_POLY1305, 9). %% CipherType -define(STREAM, 0). -define(BLOCK, 1). +-define(AEAD, 2). %% IsExportable %-define(TRUE, 0). %% Already defined by ssl_internal.hrl diff --git a/lib/ssl/src/ssl_session_cache.erl b/lib/ssl/src/ssl_session_cache.erl index 5c6ee3c54c..b011732f2c 100644 --- a/lib/ssl/src/ssl_session_cache.erl +++ b/lib/ssl/src/ssl_session_cache.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2008-2012. All Rights Reserved. +%% Copyright Ericsson AB 2008-2014. 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 @@ -31,8 +31,8 @@ %%-------------------------------------------------------------------- %% Description: Return table reference. Called by ssl_manager process. %%-------------------------------------------------------------------- -init(_) -> - ets:new(cache_name(), [ordered_set, protected]). +init(Options) -> + ets:new(cache_name(proplists:get_value(role, Options)), [ordered_set, protected]). %%-------------------------------------------------------------------- %% Description: Handles cache table at termination of ssl manager. @@ -87,5 +87,5 @@ select_session(Cache, PartialKey) -> %%-------------------------------------------------------------------- %%% Internal functions %%-------------------------------------------------------------------- -cache_name() -> - ssl_otp_session_cache. +cache_name(Name) -> + list_to_atom(atom_to_list(Name) ++ "_ssl_otp_session_cache"). diff --git a/lib/ssl/src/tls_record.erl b/lib/ssl/src/tls_record.erl index f50ea22f39..544d200f70 100644 --- a/lib/ssl/src/tls_record.erl +++ b/lib/ssl/src/tls_record.erl @@ -132,6 +132,23 @@ encode_plain_text(Type, Version, Data, sequence_number = Seq, compression_state=CompS0, security_parameters= + #security_parameters{ + cipher_type = ?AEAD, + compression_algorithm=CompAlg} + }= WriteState0} = ConnectionStates) -> + {Comp, CompS1} = ssl_record:compress(CompAlg, Data, CompS0), + WriteState1 = WriteState0#connection_state{compression_state = CompS1}, + AAD = calc_aad(Type, Version, WriteState1), + {CipherFragment, WriteState} = ssl_record:cipher_aead(Version, Comp, WriteState1, AAD), + CipherText = encode_tls_cipher_text(Type, Version, CipherFragment), + {CipherText, ConnectionStates#connection_states{current_write = WriteState#connection_state{sequence_number = Seq +1}}}; + +encode_plain_text(Type, Version, Data, + #connection_states{current_write = + #connection_state{ + sequence_number = Seq, + compression_state=CompS0, + security_parameters= #security_parameters{compression_algorithm=CompAlg} }= WriteState0} = ConnectionStates) -> {Comp, CompS1} = ssl_record:compress(CompAlg, Data, CompS0), @@ -148,18 +165,45 @@ encode_plain_text(Type, Version, Data, %% Description: Decode cipher text %%-------------------------------------------------------------------- decode_cipher_text(#ssl_tls{type = Type, version = Version, - fragment = CipherFragment} = CipherText, ConnnectionStates0) -> - ReadState0 = ConnnectionStates0#connection_states.current_read, - #connection_state{compression_state = CompressionS0, - sequence_number = Seq, - security_parameters = SecParams} = ReadState0, - CompressAlg = SecParams#security_parameters.compression_algorithm, + fragment = CipherFragment} = CipherText, + #connection_states{current_read = + #connection_state{ + compression_state = CompressionS0, + sequence_number = Seq, + security_parameters= + #security_parameters{ + cipher_type = ?AEAD, + compression_algorithm=CompAlg} + } = ReadState0} = ConnnectionStates0) -> + AAD = calc_aad(Type, Version, ReadState0), + case ssl_record:decipher_aead(Version, CipherFragment, ReadState0, AAD) of + {PlainFragment, ReadState1} -> + {Plain, CompressionS1} = ssl_record:uncompress(CompAlg, + PlainFragment, CompressionS0), + ConnnectionStates = ConnnectionStates0#connection_states{ + current_read = ReadState1#connection_state{ + sequence_number = Seq + 1, + compression_state = CompressionS1}}, + {CipherText#ssl_tls{fragment = Plain}, ConnnectionStates}; + #alert{} = Alert -> + Alert + end; + +decode_cipher_text(#ssl_tls{type = Type, version = Version, + fragment = CipherFragment} = CipherText, + #connection_states{current_read = + #connection_state{ + compression_state = CompressionS0, + sequence_number = Seq, + security_parameters= + #security_parameters{compression_algorithm=CompAlg} + } = ReadState0} = ConnnectionStates0) -> case ssl_record:decipher(Version, CipherFragment, ReadState0) of {PlainFragment, Mac, ReadState1} -> MacHash = calc_mac_hash(Type, Version, PlainFragment, ReadState1), case ssl_record:is_correct_mac(Mac, MacHash) of true -> - {Plain, CompressionS1} = ssl_record:uncompress(CompressAlg, + {Plain, CompressionS1} = ssl_record:uncompress(CompAlg, PlainFragment, CompressionS0), ConnnectionStates = ConnnectionStates0#connection_states{ current_read = ReadState1#connection_state{ @@ -322,3 +366,7 @@ calc_mac_hash(Type, Version, mac_hash(Version, SecPars#security_parameters.mac_algorithm, MacSecret, SeqNo, Type, Length, PlainFragment). + +calc_aad(Type, {MajVer, MinVer}, + #connection_state{sequence_number = SeqNo}) -> + <<SeqNo:64/integer, ?BYTE(Type), ?BYTE(MajVer), ?BYTE(MinVer)>>. diff --git a/lib/ssl/src/tls_v1.erl b/lib/ssl/src/tls_v1.erl index 7a5f9c1b38..c4114278a4 100644 --- a/lib/ssl/src/tls_v1.erl +++ b/lib/ssl/src/tls_v1.erl @@ -221,25 +221,50 @@ suites(Minor) when Minor == 1; Minor == 2 -> ]; suites(3) -> [ + ?TLS_ECDHE_ECDSA_WITH_CHACHA20_POLY1305_SHA256, + ?TLS_ECDHE_RSA_WITH_CHACHA20_POLY1305_SHA256, + + ?TLS_ECDHE_ECDSA_WITH_AES_256_GCM_SHA384, + ?TLS_ECDHE_RSA_WITH_AES_256_GCM_SHA384, ?TLS_ECDHE_ECDSA_WITH_AES_256_CBC_SHA384, ?TLS_ECDHE_RSA_WITH_AES_256_CBC_SHA384, + ?TLS_ECDH_ECDSA_WITH_AES_256_GCM_SHA384, + ?TLS_ECDH_RSA_WITH_AES_256_GCM_SHA384, ?TLS_ECDH_ECDSA_WITH_AES_256_CBC_SHA384, ?TLS_ECDH_RSA_WITH_AES_256_CBC_SHA384, + ?TLS_DHE_RSA_WITH_CHACHA20_POLY1305_SHA256, + ?TLS_DHE_RSA_WITH_AES_256_GCM_SHA384, + ?TLS_DHE_DSS_WITH_AES_256_GCM_SHA384, ?TLS_DHE_RSA_WITH_AES_256_CBC_SHA256, ?TLS_DHE_DSS_WITH_AES_256_CBC_SHA256, + ?TLS_RSA_WITH_AES_256_GCM_SHA384, ?TLS_RSA_WITH_AES_256_CBC_SHA256, + ?TLS_ECDHE_ECDSA_WITH_AES_128_GCM_SHA256, + ?TLS_ECDHE_RSA_WITH_AES_128_GCM_SHA256, ?TLS_ECDHE_ECDSA_WITH_AES_128_CBC_SHA256, ?TLS_ECDHE_RSA_WITH_AES_128_CBC_SHA256, + ?TLS_ECDH_ECDSA_WITH_AES_128_GCM_SHA256, + ?TLS_ECDH_RSA_WITH_AES_128_GCM_SHA256, ?TLS_ECDH_ECDSA_WITH_AES_128_CBC_SHA256, ?TLS_ECDH_RSA_WITH_AES_128_CBC_SHA256, + ?TLS_DHE_RSA_WITH_AES_128_GCM_SHA256, + ?TLS_DHE_DSS_WITH_AES_128_GCM_SHA256, ?TLS_DHE_RSA_WITH_AES_128_CBC_SHA256, ?TLS_DHE_DSS_WITH_AES_128_CBC_SHA256, + ?TLS_RSA_WITH_AES_128_GCM_SHA256, ?TLS_RSA_WITH_AES_128_CBC_SHA256 + + %% not supported + %% ?TLS_DH_RSA_WITH_AES_256_GCM_SHA384, + %% ?TLS_DH_DSS_WITH_AES_256_GCM_SHA384, + %% ?TLS_DH_RSA_WITH_AES_128_GCM_SHA256, + %% ?TLS_DH_DSS_WITH_AES_128_GCM_SHA256 ] ++ suites(2). + %%-------------------------------------------------------------------- %%% Internal functions %%-------------------------------------------------------------------- diff --git a/lib/ssl/test/Makefile b/lib/ssl/test/Makefile index 2f8ff6f04e..3639c2b2da 100644 --- a/lib/ssl/test/Makefile +++ b/lib/ssl/test/Makefile @@ -37,6 +37,7 @@ VSN=$(GS_VSN) MODULES = \ ssl_test_lib \ ssl_basic_SUITE \ + ssl_bench_SUITE \ ssl_cipher_SUITE \ ssl_certificate_verify_SUITE\ ssl_crl_SUITE\ @@ -130,7 +131,7 @@ release_spec: opt release_tests_spec: opt $(INSTALL_DIR) "$(RELSYSDIR)" $(INSTALL_DATA) $(ERL_FILES) $(HRL_FILES) $(HRL_FILES_NEEDED_IN_TEST) $(COVER_FILE) "$(RELSYSDIR)" - $(INSTALL_DATA) ssl.spec ssl.cover "$(RELSYSDIR)" + $(INSTALL_DATA) ssl.spec ssl_bench.spec ssl.cover "$(RELSYSDIR)" chmod -R u+w "$(RELSYSDIR)" @tar cf - *_SUITE_data | (cd "$(RELSYSDIR)"; tar xf -) diff --git a/lib/ssl/test/ssl.spec b/lib/ssl/test/ssl.spec index fc7c1bbb82..86e14c033e 100644 --- a/lib/ssl/test/ssl.spec +++ b/lib/ssl/test/ssl.spec @@ -1 +1,4 @@ {suites,"../ssl_test",all}. +{skip_cases, "../ssl_test", + ssl_bench_SUITE, [setup_sequential, setup_concurrent, payload_simple], + "Benchmarks run separately"}. diff --git a/lib/ssl/test/ssl_basic_SUITE.erl b/lib/ssl/test/ssl_basic_SUITE.erl index 1da4e88077..dc9e8934e6 100644 --- a/lib/ssl/test/ssl_basic_SUITE.erl +++ b/lib/ssl/test/ssl_basic_SUITE.erl @@ -629,7 +629,7 @@ clear_pem_cache(Config) when is_list(Config) -> {status, _, _, StatusInfo} = sys:get_status(whereis(ssl_manager)), [_, _,_, _, Prop] = StatusInfo, State = ssl_test_lib:state(Prop), - [_,FilRefDb, _] = element(5, State), + [_,FilRefDb, _] = element(6, State), {Server, Client} = basic_verify_test_no_close(Config), 2 = ets:info(FilRefDb, size), ssl:clear_pem_cache(), @@ -2339,7 +2339,7 @@ der_input(Config) when is_list(Config) -> {status, _, _, StatusInfo} = sys:get_status(whereis(ssl_manager)), [_, _,_, _, Prop] = StatusInfo, State = ssl_test_lib:state(Prop), - [CADb | _] = element(5, State), + [CADb | _] = element(6, State), [] = ets:tab2list(CADb). %%-------------------------------------------------------------------- diff --git a/lib/ssl/test/ssl_bench.spec b/lib/ssl/test/ssl_bench.spec new file mode 100644 index 0000000000..d2f75b4203 --- /dev/null +++ b/lib/ssl/test/ssl_bench.spec @@ -0,0 +1 @@ +{suites,"../ssl_test",[ssl_bench_SUITE]}. diff --git a/lib/ssl/test/ssl_bench_SUITE.erl b/lib/ssl/test/ssl_bench_SUITE.erl new file mode 100644 index 0000000000..b6b3769922 --- /dev/null +++ b/lib/ssl/test/ssl_bench_SUITE.erl @@ -0,0 +1,366 @@ +%%%------------------------------------------------------------------- +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2014. All Rights Reserved. +%% +%% The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved online at http://www.erlang.org/.2 +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% %CopyrightEnd% +%% +-module(ssl_bench_SUITE). +-compile(export_all). +-include_lib("common_test/include/ct_event.hrl"). + +-define(remote_host, "NETMARKS_REMOTE_HOST"). + +suite() -> [{ct_hooks,[{ts_install_cth,[{nodenames,2}]}]}]. + +all() -> [{group, setup}, {group, payload}]. + +groups() -> + [{setup, [{repeat, 3}], [setup_sequential, setup_concurrent]}, + {payload, [{repeat, 3}], [payload_simple]} + ]. + +init_per_group(_GroupName, Config) -> + Config. + +end_per_group(_GroupName, _Config) -> + ok. + +init_per_suite(Config) -> + try + Server = setup(ssl, node()), + [{server_node, Server}|Config] + catch _:_ -> + {skipped, "Benchmark machines only"} + end. + +end_per_suite(_Config) -> + ok. + +init_per_testcase(_Func, Conf) -> + Conf. + +end_per_testcase(_Func, _Conf) -> + ok. + + +-define(COUNT, 400). +-define(TC(Cmd), tc(fun() -> Cmd end, ?MODULE, ?LINE)). + +-define(FPROF_CLIENT, false). +-define(FPROF_SERVER, false). +-define(EPROF_CLIENT, false). +-define(EPROF_SERVER, false). +-define(PERCEPT_SERVER, false). + +%% Current numbers gives roughly a testcase per minute on todays hardware.. + +setup_sequential(Config) -> + Server = proplists:get_value(server_node, Config), + Server =/= undefined orelse error(no_server), + {ok, Result} = do_test(ssl, setup_connection, ?COUNT * 20, 1, Server), + ct_event:notify(#event{name = benchmark_data, + data=[{value, Result}, + {suite, "ssl"}, {name, "Sequential setup"}]}), + ok. + +setup_concurrent(Config) -> + Server = proplists:get_value(server_node, Config), + Server =/= undefined orelse error(no_server), + {ok, Result} = do_test(ssl, setup_connection, ?COUNT, 100, Server), + ct_event:notify(#event{name = benchmark_data, + data=[{value, Result}, + {suite, "ssl"}, {name, "Concurrent setup"}]}), + ok. + +payload_simple(Config) -> + Server = proplists:get_value(server_node, Config), + Server =/= undefined orelse error(no_server), + {ok, Result} = do_test(ssl, payload, ?COUNT*300, 10, Server), + ct_event:notify(#event{name = benchmark_data, + data=[{value, Result}, + {suite, "ssl"}, {name, "Payload simple"}]}), + ok. + + +ssl() -> + test(ssl, ?COUNT, node()). + +test(Type, Count, Host) -> + Server = setup(Type, Host), + (do_test(Type, setup_connection, Count * 20, 1, Server)), + (do_test(Type, setup_connection, Count, 100, Server)), + (do_test(Type, payload, Count*300, 10, Server)), + ok. + +do_test(Type, TC, Loop, ParallellConnections, Server) -> + _ = ssl:stop(), + {ok, _} = ensure_all_started(ssl, []), + + {ok, {SPid, Host, Port}} = rpc:call(Server, ?MODULE, setup_server_init, + [Type, TC, Loop, ParallellConnections]), + link(SPid), + Me = self(), + Test = fun(Id) -> + CData = client_init(Me, Type, TC, Host, Port), + receive + go -> + ?FPROF_CLIENT andalso Id =:= 1 andalso + start_profile(fprof, [self(),new]), + ?EPROF_CLIENT andalso Id =:= 1 andalso + start_profile(eprof, [ssl_connection_sup, ssl_manager]), + ok = ?MODULE:TC(Loop, Type, CData), + ?FPROF_CLIENT andalso Id =:= 1 andalso + stop_profile(fprof, "test_connection_client_res.fprof"), + ?EPROF_CLIENT andalso Id =:= 1 andalso + stop_profile(eprof, "test_connection_client_res.eprof"), + Me ! self() + end + end, + Spawn = fun(Id) -> + Pid = spawn(fun() -> Test(Id) end), + receive {Pid, init} -> Pid end + end, + Pids = [Spawn(Id) || Id <- lists:seq(ParallellConnections, 1, -1)], + Run = fun() -> + [Pid ! go || Pid <- Pids], + [receive Pid -> ok end || Pid <- Pids] + end, + {TimeInMicro, _} = timer:tc(Run), + TotalTests = ParallellConnections * Loop, + TestPerSecond = 1000000 * TotalTests div TimeInMicro, + io:format("TC ~p ~p ~p ~p 1/s~n", [TC, Type, ParallellConnections, TestPerSecond]), + unlink(SPid), + SPid ! quit, + {ok, TestPerSecond}. + +server_init(ssl, setup_connection, _, _, Server) -> + {ok, Socket} = ssl:listen(0, ssl_opts(listen)), + {ok, {_Host, Port}} = ssl:sockname(Socket), + {ok, Host} = inet:gethostname(), + ?FPROF_SERVER andalso start_profile(fprof, [whereis(ssl_manager), new]), + %%?EPROF_SERVER andalso start_profile(eprof, [ssl_connection_sup, ssl_manager]), + ?EPROF_SERVER andalso start_profile(eprof, [ssl_manager]), + ?PERCEPT_SERVER andalso percept:profile("/tmp/ssl_server.percept"), + Server ! {self(), {init, Host, Port}}, + Test = fun(TSocket) -> + ok = ssl:ssl_accept(TSocket), + ssl:close(TSocket) + end, + setup_server_connection(Socket, Test); +server_init(ssl, payload, Loop, _, Server) -> + {ok, Socket} = ssl:listen(0, ssl_opts(listen)), + {ok, {_Host, Port}} = ssl:sockname(Socket), + {ok, Host} = inet:gethostname(), + Server ! {self(), {init, Host, Port}}, + Test = fun(TSocket) -> + ok = ssl:ssl_accept(TSocket), + Size = byte_size(msg()), + server_echo(TSocket, Size, Loop), + ssl:close(TSocket) + end, + setup_server_connection(Socket, Test); + +server_init(Type, Tc, _, _, Server) -> + io:format("No server init code for ~p ~p~n",[Type, Tc]), + Server ! {self(), no_init}. + +client_init(Master, ssl, setup_connection, Host, Port) -> + Master ! {self(), init}, + {Host, Port, ssl_opts(connect)}; +client_init(Master, ssl, payload, Host, Port) -> + {ok, Sock} = ssl:connect(Host, Port, ssl_opts(connect)), + Master ! {self(), init}, + Size = byte_size(msg()), + {Sock, Size}; +client_init(_Me, Type, Tc, Host, Port) -> + io:format("No client init code for ~p ~p~n",[Type, Tc]), + {Host, Port}. + +setup_server_connection(LSocket, Test) -> + receive quit -> + ?FPROF_SERVER andalso stop_profile(fprof, "test_server_res.fprof"), + ?EPROF_SERVER andalso stop_profile(eprof, "test_server_res.eprof"), + ?PERCEPT_SERVER andalso stop_profile(percept, "/tmp/ssl_server.percept"), + ok + after 0 -> + case ssl:transport_accept(LSocket, 2000) of + {ok, TSocket} -> spawn_link(fun() -> Test(TSocket) end); + {error, timeout} -> ok + end, + setup_server_connection(LSocket, Test) + end. + +server_echo(Socket, Size, Loop) when Loop > 0 -> + {ok, Msg} = ssl:recv(Socket, Size), + ok = ssl:send(Socket, Msg), + server_echo(Socket, Size, Loop-1); +server_echo(_, _, _) -> ok. + +setup_connection(N, ssl, Env = {Host, Port, Opts}) when N > 0 -> + case ssl:connect(Host, Port, Opts) of + {ok, Sock} -> + ssl:close(Sock), + setup_connection(N-1, ssl, Env); + {error, Error} -> + io:format("Error: ~p (~p)~n",[Error, length(erlang:ports())]), + setup_connection(N, ssl, Env) + end; +setup_connection(_, _, _) -> + ok. + +payload(Loop, ssl, D = {Socket, Size}) when Loop > 0 -> + ok = ssl:send(Socket, msg()), + {ok, _} = ssl:recv(Socket, Size), + payload(Loop-1, ssl, D); +payload(_, _, {Socket, _}) -> + ssl:close(Socket). + +msg() -> + <<"Hello", + 0:(512*8), + "asdlkjsafsdfoierwlejsdlkfjsdf", + 1:(512*8), + "asdlkjsafsdfoierwlejsdlkfjsdf">>. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +setup(_Type, nonode@nohost) -> + exit(dist_not_enabled); +setup(Type, _This) -> + Host = case os:getenv(?remote_host) of + false -> + {ok, This} = inet:gethostname(), + This; + RemHost -> + RemHost + end, + Node = list_to_atom("perf_server@" ++ Host), + SlaveArgs = case init:get_argument(pa) of + {ok, PaPaths} -> + lists:append([" -pa " ++ P || [P] <- PaPaths]); + _ -> [] + end, + %% io:format("Slave args: ~p~n",[SlaveArgs]), + Prog = + case os:find_executable("erl") of + false -> "erl"; + P -> P + end, + io:format("Prog = ~p~n", [Prog]), + + case net_adm:ping(Node) of + pong -> ok; + pang -> + {ok, Node} = slave:start(Host, perf_server, SlaveArgs, no_link, Prog) + end, + Path = code:get_path(), + true = rpc:call(Node, code, set_path, [Path]), + ok = rpc:call(Node, ?MODULE, setup_server, [Type, node()]), + io:format("Client (~p) using ~s~n",[node(), code:which(ssl)]), + (Node =:= node()) andalso restrict_schedulers(client), + Node. + +setup_server(_Type, ClientNode) -> + (ClientNode =:= node()) andalso restrict_schedulers(server), + io:format("Server (~p) using ~s~n",[node(), code:which(ssl)]), + ok. + + +ensure_all_started(App, Ack) -> + case application:start(App) of + ok -> {ok, [App|Ack]}; + {error, {not_started, Dep}} -> + {ok, Ack1} = ensure_all_started(Dep, Ack), + ensure_all_started(App, Ack1); + {error, {already_started, _}} -> + {ok, Ack} + end. + +setup_server_init(Type, Tc, Loop, PC) -> + _ = ssl:stop(), + {ok, _} = ensure_all_started(ssl, []), + Me = self(), + Pid = spawn_link(fun() -> server_init(Type, Tc, Loop, PC, Me) end), + Res = receive + {Pid, {init, Host, Port}} -> {ok, {Pid, Host, Port}}; + {Pid, Error} -> {error, Error} + end, + unlink(Pid), + Res. + +restrict_schedulers(Type) -> + %% We expect this to run on 8 core machine + Extra0 = 1, + Extra = if (Type =:= server) -> -Extra0; true -> Extra0 end, + Scheds = erlang:system_info(schedulers), + erlang:system_flag(schedulers_online, (Scheds div 2) + Extra). + +tc(Fun, Mod, Line) -> + case timer:tc(Fun) of + {_,{'EXIT',Reason}} -> + io:format("Process EXITED ~p:~p \n", [Mod, Line]), + exit(Reason); + {_T,R={error,_}} -> + io:format("Process Error ~p:~p \n", [Mod, Line]), + R; + {T,R} -> + io:format("~p:~p: Time: ~p\n", [Mod, Line, T]), + R + end. + +start_profile(eprof, Procs) -> + profiling = eprof:start_profiling(Procs), + io:format("(E)Profiling ...",[]); +start_profile(fprof, Procs) -> + fprof:trace([start, {procs, Procs}]), + io:format("(F)Profiling ...",[]). + +stop_profile(percept, File) -> + percept:stop_profile(), + percept:analyze(File), + {started, _Host, Port} = percept:start_webserver(), + wx:new(), + wx_misc:launchDefaultBrowser("http://" ++ net_adm:localhost() ++ ":" ++ integer_to_list(Port)), + ok; +stop_profile(eprof, File) -> + profiling_stopped = eprof:stop_profiling(), + eprof:log(File), + io:format(".analysed => ~s ~n",[File]), + eprof:analyze(total), + eprof:stop(); +stop_profile(fprof, File) -> + fprof:trace(stop), + io:format("..collect..",[]), + fprof:profile(), + fprof:analyse([{dest, File},{totals, true}]), + io:format(".analysed => ~s ~n",[File]), + fprof:stop(), + ok. + +ssl_opts(listen) -> + [{backlog, 500} | ssl_opts("server")]; +ssl_opts(connect) -> + [{verify, verify_peer} + | ssl_opts("client")]; +ssl_opts(Role) -> + Dir = filename:join([code:lib_dir(ssl), "examples", "certs", "etc"]), + [{active, false}, + {depth, 2}, + {reuseaddr, true}, + {mode,binary}, + {nodelay, true}, + {ciphers, [{dhe_rsa,aes_256_cbc,sha}]}, + {cacertfile, filename:join([Dir, Role, "cacerts.pem"])}, + {certfile, filename:join([Dir, Role, "cert.pem"])}, + {keyfile, filename:join([Dir, Role, "key.pem"])}]. diff --git a/lib/ssl/test/ssl_cipher_SUITE.erl b/lib/ssl/test/ssl_cipher_SUITE.erl index 45e91786d4..f2dc1b52c1 100644 --- a/lib/ssl/test/ssl_cipher_SUITE.erl +++ b/lib/ssl/test/ssl_cipher_SUITE.erl @@ -86,9 +86,9 @@ aes_decipher_good(Config) when is_list(Config) -> Content = <<183,139,16,132,10,209,67,86,168,100,61,217,145,57,36,56, "HELLO\n">>, Mac = <<71,136,212,107,223,200,70,232,127,116,148,205,232,35,158,113,237,174,15,217,192,168,35,8,6,107,107,233,25,174,90,111>>, Version = {3,0}, - {Content, Mac, _} = ssl_cipher:decipher(?AES, HashSz, CipherState, Fragment, Version), + {Content, Mac, _} = ssl_cipher:decipher(?AES_CBC, HashSz, CipherState, Fragment, Version), Version1 = {3,1}, - {Content, Mac, _} = ssl_cipher:decipher(?AES, HashSz, CipherState, Fragment, Version1), + {Content, Mac, _} = ssl_cipher:decipher(?AES_CBC, HashSz, CipherState, Fragment, Version1), ok. %%-------------------------------------------------------------------- @@ -110,9 +110,9 @@ aes_decipher_good_tls11(Config) when is_list(Config) -> NextIV = <<183,139,16,132,10,209,67,86,168,100,61,217,145,57,36,56>>, Mac = <<71,136,212,107,223,200,70,232,127,116,148,205,232,35,158,113,237,174,15,217,192,168,35,8,6,107,107,233,25,174,90,111>>, Version = {3,2}, - {Content, Mac, #cipher_state{iv = NextIV}} = ssl_cipher:decipher(?AES, HashSz, CipherState, Fragment, Version), + {Content, Mac, #cipher_state{iv = NextIV}} = ssl_cipher:decipher(?AES_CBC, HashSz, CipherState, Fragment, Version), Version1 = {3,2}, - {Content, Mac, #cipher_state{iv = NextIV}} = ssl_cipher:decipher(?AES, HashSz, CipherState, Fragment, Version1), + {Content, Mac, #cipher_state{iv = NextIV}} = ssl_cipher:decipher(?AES_CBC, HashSz, CipherState, Fragment, Version1), ok. %%-------------------------------------------------------------------- @@ -130,11 +130,11 @@ aes_decipher_fail(Config) when is_list(Config) -> 198,181,81,19,98,162,213,228,74,224,253,168,156,59,195,122, 108,101,107,242,20,15,169,150,163,107,101,94,93,104,241,165>>, Version = {3,0}, - {Content, Mac, _} = ssl_cipher:decipher(?AES, HashSz, CipherState, Fragment, Version), + {Content, Mac, _} = ssl_cipher:decipher(?AES_CBC, HashSz, CipherState, Fragment, Version), 32 = byte_size(Content), 32 = byte_size(Mac), Version1 = {3,1}, - {Content1, Mac1, _} = ssl_cipher:decipher(?AES, HashSz, CipherState, Fragment, Version1), + {Content1, Mac1, _} = ssl_cipher:decipher(?AES_CBC, HashSz, CipherState, Fragment, Version1), 32 = byte_size(Content1), 32 = byte_size(Mac1), ok. @@ -156,10 +156,10 @@ aes_decipher_fail_tls11(Config) when is_list(Config) -> 108,101,107,242,20,15,169,150,163,107,101,94,93,104,241,165>>, Version = {3,2}, #alert{level = ?FATAL, description = ?BAD_RECORD_MAC} = - ssl_cipher:decipher(?AES, HashSz, CipherState, Fragment, Version), + ssl_cipher:decipher(?AES_CBC, HashSz, CipherState, Fragment, Version), Version1 = {3,3}, #alert{level = ?FATAL, description = ?BAD_RECORD_MAC} = - ssl_cipher:decipher(?AES, HashSz, CipherState, Fragment, Version1), + ssl_cipher:decipher(?AES_CBC, HashSz, CipherState, Fragment, Version1), ok. %%-------------------------------------------------------------------- diff --git a/lib/ssl/test/ssl_session_cache_SUITE.erl b/lib/ssl/test/ssl_session_cache_SUITE.erl index c31f6c2d7d..06a41f1260 100644 --- a/lib/ssl/test/ssl_session_cache_SUITE.erl +++ b/lib/ssl/test/ssl_session_cache_SUITE.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2010-2013. All Rights Reserved. +%% Copyright Ericsson AB 2010-2014. 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 @@ -108,8 +108,12 @@ init_customized_session_cache(Type, Config0) -> ssl:stop(), application:load(ssl), application:set_env(ssl, session_cb, ?MODULE), - application:set_env(ssl, session_cb_init_args, [Type]), + application:set_env(ssl, session_cb_init_args, [{type, Type}]), ssl:start(), + catch (end_per_testcase(list_to_atom("session_cache_process" ++ atom_to_list(Type)), + Config)), + ets:new(ssl_test, [named_table, public, set]), + ets:insert(ssl_test, {type, Type}), [{watchdog, Dog} | Config]. end_per_testcase(session_cache_process_list, Config) -> @@ -126,7 +130,11 @@ end_per_testcase(session_cleanup, Config) -> application:unset_env(ssl, session_delay_cleanup_time), application:unset_env(ssl, session_lifetime), end_per_testcase(default_action, Config); -end_per_testcase(_TestCase, Config) -> +end_per_testcase(Case, Config) when Case == session_cache_process_list; + Case == session_cache_process_mnesia -> + ets:delete(ssl_test), + Config; +end_per_testcase(_, Config) -> Config. %%-------------------------------------------------------------------- @@ -164,12 +172,13 @@ session_cleanup(Config)when is_list(Config) -> {status, _, _, StatusInfo} = sys:get_status(whereis(ssl_manager)), [_, _,_, _, Prop] = StatusInfo, State = ssl_test_lib:state(Prop), - Cache = element(2, State), - SessionTimer = element(6, State), + ClientCache = element(2, State), + ServerCache = element(3, State), + SessionTimer = element(7, State), Id = proplists:get_value(session_id, SessionInfo), - CSession = ssl_session_cache:lookup(Cache, {{Hostname, Port}, Id}), - SSession = ssl_session_cache:lookup(Cache, {Port, Id}), + CSession = ssl_session_cache:lookup(ClientCache, {{Hostname, Port}, Id}), + SSession = ssl_session_cache:lookup(ServerCache, {Port, Id}), true = CSession =/= undefined, true = SSession =/= undefined, @@ -185,8 +194,8 @@ session_cleanup(Config)when is_list(Config) -> ct:sleep(?SLEEP), %% Make sure clean has had time to run - undefined = ssl_session_cache:lookup(Cache, {{Hostname, Port}, Id}), - undefined = ssl_session_cache:lookup(Cache, {Port, Id}), + undefined = ssl_session_cache:lookup(ClientCache, {{Hostname, Port}, Id}), + undefined = ssl_session_cache:lookup(ServerCache, {Port, Id}), process_flag(trap_exit, false), ssl_test_lib:close(Server), @@ -208,7 +217,7 @@ get_delay_timers() -> {status, _, _, StatusInfo} = sys:get_status(whereis(ssl_manager)), [_, _,_, _, Prop] = StatusInfo, State = ssl_test_lib:state(Prop), - case element(7, State) of + case element(8, State) of {undefined, undefined} -> ct:sleep(?SLEEP), get_delay_timers(); @@ -236,16 +245,16 @@ session_cache_process_mnesia(Config) when is_list(Config) -> %%% Session cache API callbacks %%-------------------------------------------------------------------- -init([Type]) -> - ets:new(ssl_test, [named_table, public, set]), - ets:insert(ssl_test, {type, Type}), - case Type of +init(Opts) -> + case proplists:get_value(type, Opts) of list -> spawn(fun() -> session_loop([]) end); mnesia -> mnesia:start(), - {atomic,ok} = mnesia:create_table(sess_cache, []), - sess_cache + Name = atom_to_list(proplists:get_value(role, Opts)), + TabName = list_to_atom(Name ++ "sess_cache"), + {atomic,ok} = mnesia:create_table(TabName, []), + TabName end. session_cb() -> @@ -258,7 +267,7 @@ terminate(Cache) -> Cache ! terminate; mnesia -> catch {atomic,ok} = - mnesia:delete_table(sess_cache) + mnesia:delete_table(Cache) end. lookup(Cache, Key) -> @@ -268,10 +277,10 @@ lookup(Cache, Key) -> receive {Cache, Res} -> Res end; mnesia -> case mnesia:transaction(fun() -> - mnesia:read(sess_cache, + mnesia:read(Cache, Key, read) end) of - {atomic, [{sess_cache, Key, Value}]} -> + {atomic, [{Cache, Key, Value}]} -> Value; _ -> undefined @@ -285,8 +294,8 @@ update(Cache, Key, Value) -> mnesia -> {atomic, ok} = mnesia:transaction(fun() -> - mnesia:write(sess_cache, - {sess_cache, Key, Value}, write) + mnesia:write(Cache, + {Cache, Key, Value}, write) end) end. @@ -297,7 +306,7 @@ delete(Cache, Key) -> mnesia -> {atomic, ok} = mnesia:transaction(fun() -> - mnesia:delete(sess_cache, Key) + mnesia:delete(Cache, Key) end) end. @@ -308,7 +317,7 @@ foldl(Fun, Acc, Cache) -> receive {Cache, Res} -> Res end; mnesia -> Foldl = fun() -> - mnesia:foldl(Fun, Acc, sess_cache) + mnesia:foldl(Fun, Acc, Cache) end, {atomic, Res} = mnesia:transaction(Foldl), Res @@ -325,7 +334,7 @@ select_session(Cache, PartialKey) -> mnesia -> Sel = fun() -> mnesia:select(Cache, - [{{sess_cache,{PartialKey,'$1'}, '$2'}, + [{{Cache,{PartialKey,'$1'}, '$2'}, [],['$$']}]) end, {atomic, Res} = mnesia:transaction(Sel), diff --git a/lib/ssl/test/ssl_test_lib.erl b/lib/ssl/test/ssl_test_lib.erl index 74d71263de..d2e6e41482 100644 --- a/lib/ssl/test/ssl_test_lib.erl +++ b/lib/ssl/test/ssl_test_lib.erl @@ -811,48 +811,34 @@ openssl_rsa_suites(CounterPart) -> false -> "DSS | ECDHE | ECDH" end, - lists:filter(fun(Str) -> - case re:run(Str, Names,[]) of - nomatch -> - false; - _ -> - true - end - end, Ciphers). + lists:filter(fun(Str) -> string_regex_filter(Str, Names) + end, Ciphers). openssl_dsa_suites() -> Ciphers = ssl:cipher_suites(openssl), - lists:filter(fun(Str) -> - case re:run(Str,"DSS",[]) of - nomatch -> - false; - _ -> - true - end + lists:filter(fun(Str) -> string_regex_filter(Str, "DSS") end, Ciphers). openssl_ecdsa_suites() -> Ciphers = ssl:cipher_suites(openssl), - lists:filter(fun(Str) -> - case re:run(Str,"ECDHE-ECDSA",[]) of - nomatch -> - false; - _ -> - true - end + lists:filter(fun(Str) -> string_regex_filter(Str, "ECDHE-ECDSA") end, Ciphers). openssl_ecdh_rsa_suites() -> Ciphers = ssl:cipher_suites(openssl), - lists:filter(fun(Str) -> - case re:run(Str,"ECDH-RSA",[]) of - nomatch -> - false; - _ -> - true - end + lists:filter(fun(Str) -> string_regex_filter(Str, "ECDH-RSA") end, Ciphers). +string_regex_filter(Str, Search) when is_list(Str) -> + case re:run(Str, Search, []) of + nomatch -> + false; + _ -> + true + end; +string_regex_filter(Str, _Search) -> + false. + anonymous_suites() -> Suites = [{dh_anon, rc4_128, md5}, @@ -860,6 +846,8 @@ anonymous_suites() -> {dh_anon, '3des_ede_cbc', sha}, {dh_anon, aes_128_cbc, sha}, {dh_anon, aes_256_cbc, sha}, + {dh_anon, aes_128_gcm, null}, + {dh_anon, aes_256_gcm, null}, {ecdh_anon,rc4_128,sha}, {ecdh_anon,'3des_ede_cbc',sha}, {ecdh_anon,aes_128_cbc,sha}, @@ -885,8 +873,13 @@ psk_suites() -> {rsa_psk, aes_128_cbc, sha}, {rsa_psk, aes_256_cbc, sha}, {rsa_psk, aes_128_cbc, sha256}, - {rsa_psk, aes_256_cbc, sha384} -], + {rsa_psk, aes_256_cbc, sha384}, + {psk, aes_128_gcm, null}, + {psk, aes_256_gcm, null}, + {dhe_psk, aes_128_gcm, null}, + {dhe_psk, aes_256_gcm, null}, + {rsa_psk, aes_128_gcm, null}, + {rsa_psk, aes_256_gcm, null}], ssl_cipher:filter_suites(Suites). psk_anon_suites() -> @@ -1130,7 +1123,7 @@ version_flag(sslv3) -> filter_suites(Ciphers0) -> Version = tls_record:highest_protocol_version([]), Supported0 = ssl_cipher:suites(Version) - ++ ssl_cipher:anonymous_suites() + ++ ssl_cipher:anonymous_suites(Version) ++ ssl_cipher:psk_suites(Version) ++ ssl_cipher:srp_suites(), Supported1 = ssl_cipher:filter_suites(Supported0), diff --git a/lib/stdlib/doc/src/Makefile b/lib/stdlib/doc/src/Makefile index ff77c3eea0..f5d8b2072a 100644 --- a/lib/stdlib/doc/src/Makefile +++ b/lib/stdlib/doc/src/Makefile @@ -76,7 +76,6 @@ XML_REF3_FILES = \ ms_transform.xml \ orddict.xml \ ordsets.xml \ - pg.xml \ pool.xml \ proc_lib.xml \ proplists.xml \ diff --git a/lib/stdlib/doc/src/binary.xml b/lib/stdlib/doc/src/binary.xml index 2410f1f9b8..6c0968d242 100644 --- a/lib/stdlib/doc/src/binary.xml +++ b/lib/stdlib/doc/src/binary.xml @@ -5,7 +5,7 @@ <header> <copyright> <year>2009</year> - <year>2013</year> + <year>2014</year> <holder>Ericsson AB, All Rights Reserved</holder> </copyright> <legalnotice> @@ -450,7 +450,7 @@ store(Binary, GBSet) -> </code> <p>In this example, we chose to copy the binary content before - inserting it in the <c>gb_set()</c> if it references a binary more than + inserting it in the <c>gb_sets:set()</c> if it references a binary more than twice the size of the data we're going to keep. Of course different rules for when copying will apply to different programs.</p> @@ -578,6 +578,10 @@ store(Binary, GBSet) -> <item><p>Removes trailing empty parts of the result (as does trim in <c>re:split/3</c>)</p></item> + <tag>trim_all</tag> + + <item><p>Removes all empty parts of the result.</p></item> + <tag>global</tag> <item><p>Repeats the split until the <c><anno>Subject</anno></c> is diff --git a/lib/stdlib/doc/src/gen_event.xml b/lib/stdlib/doc/src/gen_event.xml index b9dfff833e..5c96d6e576 100644 --- a/lib/stdlib/doc/src/gen_event.xml +++ b/lib/stdlib/doc/src/gen_event.xml @@ -4,7 +4,7 @@ <erlref> <header> <copyright> - <year>1996</year><year>2013</year> + <year>1996</year><year>2014</year> <holder>Ericsson AB. All Rights Reserved.</holder> </copyright> <legalnotice> @@ -44,6 +44,7 @@ <pre> gen_event module Callback module ---------------- --------------- +gen_event:start gen_event:start_link -----> - gen_event:add_handler @@ -177,7 +178,7 @@ gen_event:stop -----> Module:terminate/2 <name>add_handler(EventMgrRef, Handler, Args) -> Result</name> <fsummary>Add an event handler to a generic event manager.</fsummary> <type> - <v>EventMgr = Name | {Name,Node} | {global,GlobalName} + <v>EventMgrRef = Name | {Name,Node} | {global,GlobalName} | {via,Module,ViaName} | pid()</v> <v> Name = Node = atom()</v> <v> GlobalName = ViaName = term()</v> @@ -223,7 +224,7 @@ gen_event:stop -----> Module:terminate/2 <name>add_sup_handler(EventMgrRef, Handler, Args) -> Result</name> <fsummary>Add a supervised event handler to a generic event manager.</fsummary> <type> - <v>EventMgr = Name | {Name,Node} | {global,GlobalName} + <v>EventMgrRef = Name | {Name,Node} | {global,GlobalName} | {via,Module,ViaName} | pid()</v> <v> Name = Node = atom()</v> <v> GlobalName = ViaName = term()</v> @@ -456,19 +457,37 @@ gen_event:stop -----> Module:terminate/2 </func> <func> <name>stop(EventMgrRef) -> ok</name> + <name>stop(EventMgrRef, Reason, Timeout) -> ok</name> <fsummary>Terminate a generic event manager.</fsummary> <type> <v>EventMgrRef = Name | {Name,Node} | {global,GlobalName} | {via,Module,ViaName} | pid()</v> <v>Name = Node = atom()</v> <v>GlobalName = ViaName = term()</v> + <v>Reason = term()</v> + <v>Timeout = int()>0 | infinity</v> </type> <desc> - <p>Terminates the event manager <c>EventMgrRef</c>. Before - terminating, the event manager will call - <c>Module:terminate(stop,...)</c> for each installed event - handler.</p> - <p>See <c>add_handler/3</c> for a description of the argument.</p> + <p>Orders the event manager <c>EventMgrRef</c> to exit with + the given <c>Reason</c> and waits for it to + terminate. Before terminating, the gen_event will call + <seealso marker="#Module:terminate/2">Module:terminate(stop,...)</seealso> + for each installed event handler.</p> + <p>The function returns <c>ok</c> if the event manager terminates + with the expected reason. Any other reason than <c>normal</c>, + <c>shutdown</c>, or <c>{shutdown,Term}</c> will cause an + error report to be issued using + <seealso marker="kernel:error_logger#format/2">error_logger:format/2</seealso>. + The default <c>Reason</c> is <c>normal</c>.</p> + <p><c>Timeout</c> is an integer greater than zero which + specifies how many milliseconds to wait for the event manager to + terminate, or the atom <c>infinity</c> to wait + indefinitely. The default value is <c>infinity</c>. If the + event manager has not terminated within the specified time, a + <c>timeout</c> exception is raised.</p> + <p>If the process does not exist, a <c>noproc</c> exception + is raised.</p> + <p>See <c>add_handler/3</c> for a description of <c>EventMgrRef</c>.</p> </desc> </func> </funcs> diff --git a/lib/stdlib/doc/src/gen_fsm.xml b/lib/stdlib/doc/src/gen_fsm.xml index 848d57f3e6..b1bba3eff0 100644 --- a/lib/stdlib/doc/src/gen_fsm.xml +++ b/lib/stdlib/doc/src/gen_fsm.xml @@ -4,7 +4,7 @@ <erlref> <header> <copyright> - <year>1996</year><year>2013</year> + <year>1996</year><year>2014</year> <holder>Ericsson AB. All Rights Reserved.</holder> </copyright> <legalnotice> @@ -43,8 +43,11 @@ <pre> gen_fsm module Callback module -------------- --------------- +gen_fsm:start gen_fsm:start_link -----> Module:init/1 +gen_fsm:stop -----> Module:terminate/3 + gen_fsm:send_event -----> Module:StateName/2 gen_fsm:send_all_state_event -----> Module:handle_event/3 @@ -187,6 +190,39 @@ gen_fsm:sync_send_all_state_event -----> Module:handle_sync_event/4 </desc> </func> <func> + <name>stop(FsmRef) -> ok</name> + <name>stop(FsmRef, Reason, Timeout) -> ok</name> + <fsummary>Synchronously stop a generic FSM.</fsummary> + <type> + <v>FsmRef = Name | {Name,Node} | {global,GlobalName} + | {via,Module,ViaName} | pid()</v> + <v> Node = atom()</v> + <v> GlobalName = ViaName = term()</v> + <v>Reason = term()</v> + <v>Timeout = int()>0 | infinity</v> + </type> + <desc> + <p>Orders a generic FSM to exit with the given <c>Reason</c> + and waits for it to terminate. The gen_fsm will call + <seealso marker="#Module:terminate/3">Module:terminate/3</seealso> + before exiting.</p> + <p>The function returns <c>ok</c> if the generic FSM terminates + with the expected reason. Any other reason than <c>normal</c>, + <c>shutdown</c>, or <c>{shutdown,Term}</c> will cause an + error report to be issued using + <seealso marker="kernel:error_logger#format/2">error_logger:format/2</seealso>. + The default <c>Reason</c> is <c>normal</c>.</p> + <p><c>Timeout</c> is an integer greater than zero which + specifies how many milliseconds to wait for the generic FSM + to terminate, or the atom <c>infinity</c> to wait + indefinitely. The default value is <c>infinity</c>. If the + generic FSM has not terminated within the specified time, a + <c>timeout</c> exception is raised.</p> + <p>If the process does not exist, a <c>noproc</c> exception + is raised.</p> + </desc> + </func> + <func> <name>send_event(FsmRef, Event) -> ok</name> <fsummary>Send an event asynchronously to a generic FSM.</fsummary> <type> @@ -528,7 +564,8 @@ gen_fsm:sync_send_all_state_event -----> Module:handle_sync_event/4 <c>Module:init/1</c> for a description of <c>Timeout</c> and <c>hibernate</c>.</p> <p>If the function returns <c>{stop,Reason,NewStateData}</c>, the gen_fsm will call - <c>Module:terminate(Reason,NewStateData)</c> and terminate.</p> + <c>Module:terminate(Reason,StateName,NewStateData)</c> and + terminate.</p> </desc> </func> <func> @@ -614,7 +651,8 @@ gen_fsm:sync_send_all_state_event -----> Module:handle_sync_event/4 <c>{stop,Reason,NewStateData}</c>, any reply to <c>From</c> must be given explicitly using <c>gen_fsm:reply/2</c>. The gen_fsm will then call - <c>Module:terminate(Reason,NewStateData)</c> and terminate.</p> + <c>Module:terminate(Reason,StateName,NewStateData)</c> and + terminate.</p> </desc> </func> <func> diff --git a/lib/stdlib/doc/src/gen_server.xml b/lib/stdlib/doc/src/gen_server.xml index 62c0394479..a915e567a5 100644 --- a/lib/stdlib/doc/src/gen_server.xml +++ b/lib/stdlib/doc/src/gen_server.xml @@ -4,7 +4,7 @@ <erlref> <header> <copyright> - <year>1996</year><year>2013</year> + <year>1996</year><year>2014</year> <holder>Ericsson AB. All Rights Reserved.</holder> </copyright> <legalnotice> @@ -43,8 +43,11 @@ <pre> gen_server module Callback module ----------------- --------------- +gen_server:start gen_server:start_link -----> Module:init/1 +gen_server:stop -----> Module:terminate/2 + gen_server:call gen_server:multi_call -----> Module:handle_call/3 @@ -184,6 +187,40 @@ gen_server:abcast -----> Module:handle_cast/2 </desc> </func> <func> + <name>stop(ServerRef) -> ok</name> + <name>stop(ServerRef, Reason, Timeout) -> ok</name> + <fsummary>Synchronously stop a generic server.</fsummary> + <type> + <v>ServerRef = Name | {Name,Node} | {global,GlobalName} + | {via,Module,ViaName} | pid()</v> + <v> Node = atom()</v> + <v> GlobalName = ViaName = term()</v> + <v>Reason = term()</v> + <v>Timeout = int()>0 | infinity</v> + </type> + <desc> + <p>Orders a generic server to exit with the + given <c>Reason</c> and waits for it to terminate. The + gen_server will call + <seealso marker="#Module:terminate/2">Module:terminate/2</seealso> + before exiting.</p> + <p>The function returns <c>ok</c> if the server terminates + with the expected reason. Any other reason than <c>normal</c>, + <c>shutdown</c>, or <c>{shutdown,Term}</c> will cause an + error report to be issued using + <seealso marker="kernel:error_logger#format/2">error_logger:format/2</seealso>. + The default <c>Reason</c> is <c>normal</c>.</p> + <p><c>Timeout</c> is an integer greater than zero which + specifies how many milliseconds to wait for the server to + terminate, or the atom <c>infinity</c> to wait + indefinitely. The default value is <c>infinity</c>. If the + server has not terminated within the specified time, a + <c>timeout</c> exception is raised.</p> + <p>If the process does not exist, a <c>noproc</c> exception + is raised.</p> + </desc> + </func> + <func> <name>call(ServerRef, Request) -> Reply</name> <name>call(ServerRef, Request, Timeout) -> Reply</name> <fsummary>Make a synchronous call to a generic server.</fsummary> diff --git a/lib/stdlib/doc/src/pg.xml b/lib/stdlib/doc/src/pg.xml deleted file mode 100644 index a3b69884b6..0000000000 --- a/lib/stdlib/doc/src/pg.xml +++ /dev/null @@ -1,114 +0,0 @@ -<?xml version="1.0" encoding="utf-8" ?> -<!DOCTYPE erlref SYSTEM "erlref.dtd"> - -<erlref> - <header> - <copyright> - <year>1996</year> - <year>2014</year> - <holder>Ericsson AB, All Rights Reserved</holder> - </copyright> - <legalnotice> - The contents of this file are subject to the Erlang Public License, - Version 1.1, (the "License"); you may not use this file except in - compliance with the License. You should have received a copy of the - Erlang Public License along with this software. If not, it can be - retrieved online at http://www.erlang.org/. - - Software distributed under the License is distributed on an "AS IS" - basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See - the License for the specific language governing rights and limitations - under the License. - - The Initial Developer of the Original Code is Ericsson AB. - </legalnotice> - - <title>pg</title> - <prepared></prepared> - <docno></docno> - <date></date> - <rev></rev> - </header> - <module>pg</module> - <modulesummary>Distributed, Named Process Groups</modulesummary> - <description> - <warning> - <p>This module is deprecated and will be removed in Erlang/OTP 18.</p> - </warning> - <p>This (experimental) module implements process groups. A process - group is a group of processes that can be accessed by a common - name. For example, a group named <c>foobar</c> can include a set - of processes as members of this group and they can be located on - different nodes.</p> - <p>When messages are sent to the named group, all members of - the group receive the message. The messages are serialized. If - the process <c>P1</c> sends the message <c>M1</c> to the group, - and process <c>P2</c> simultaneously sends message <c>M2</c>, then - all members of the group receive the two messages in the same - order. If members of a group terminate, they are automatically - removed from the group.</p> - <p>This module is not complete. The module is inspired by the ISIS - system and the causal order protocol of the ISIS system should - also be implemented. At the moment, all messages are serialized - by sending them through a group master process.</p> - </description> - <funcs> - <func> - <name name="create" arity="1"/> - <fsummary>Create an empty group</fsummary> - <desc> - <p>Creates an empty group named <c><anno>PgName</anno></c> on the current - node.</p> - </desc> - </func> - <func> - <name name="create" arity="2"/> - <fsummary>Create an empty group on another node</fsummary> - <desc> - <p>Creates an empty group named <c><anno>PgName</anno></c> on the node - <c><anno>Node</anno></c>.</p> - </desc> - </func> - <func> - <name name="join" arity="2"/> - <fsummary>Join a pid to a process group</fsummary> - <desc> - <p>Joins the pid <c><anno>Pid</anno></c> to the process group - <c><anno>PgName</anno></c>. - Returns a list of all old members of the group.</p> - </desc> - </func> - <func> - <name name="send" arity="2"/> - <fsummary>Send a message to all members of a process group</fsummary> - <desc> - <p>Sends the tuple <c>{pg_message, From, PgName, Msg}</c> to - all members of the process group <c><anno>PgName</anno></c>.</p> - <p>Failure: <c>{badarg, {<anno>PgName</anno>, <anno>Msg</anno>}}</c> - if <c><anno>PgName</anno></c> is - not a process group (a globally registered name).</p> - </desc> - </func> - <func> - <name name="esend" arity="2"/> - <fsummary>Send a message to all members of a process group, except ourselves</fsummary> - <desc> - <p>Sends the tuple <c>{pg_message, From, PgName, Msg}</c> to - all members of the process group <c><anno>PgName</anno></c>, except - ourselves.</p> - <p>Failure: <c>{badarg, {<anno>PgName</anno>, <anno>Msg</anno>}}</c> - if <c><anno>PgName</anno></c> is - not a process group (a globally registered name).</p> - </desc> - </func> - <func> - <name name="members" arity="1"/> - <fsummary>Return a list of all members of a process group</fsummary> - <desc> - <p>Returns a list of all members of the process group - <c>PgName</c>.</p> - </desc> - </func> - </funcs> -</erlref> - diff --git a/lib/stdlib/doc/src/proc_lib.xml b/lib/stdlib/doc/src/proc_lib.xml index 5bf5744622..f27a974242 100644 --- a/lib/stdlib/doc/src/proc_lib.xml +++ b/lib/stdlib/doc/src/proc_lib.xml @@ -4,7 +4,7 @@ <erlref> <header> <copyright> - <year>1996</year><year>2013</year> + <year>1996</year><year>2014</year> <holder>Ericsson AB. All Rights Reserved.</holder> </copyright> <legalnotice> @@ -298,6 +298,40 @@ init(Parent) -> <c>proc_lib</c> functions.</p> </desc> </func> + <func> + <name name="stop" arity="1"/> + <fsummary>Terminate a process synchronously.</fsummary> + <type variable="Process"/> + <desc> + <p>Equivalent to <seealso marker="#stop/3">stop(Process, + normal, infinity)</seealso>.</p> + </desc> + </func> + <func> + <name name="stop" arity="3"/> + <fsummary>Terminate a process synchronously.</fsummary> + <type variable="Process"/> + <type variable="Reason"/> + <type variable="Timeout"/> + <desc> + <p>Orders the process to exit with the given <c>Reason</c> and + waits for it to terminate.</p> + <p>The function returns <c>ok</c> if the process exits with + the given <c>Reason</c> within <c>Timeout</c> + milliseconds.</p> + <p>If the call times out, a <c>timeout</c> exception is + raised.</p> + <p>If the process does not exist, a <c>noproc</c> + exception is raised.</p> + <p>The implementation of this function is based on the + <c>terminate</c> system message, and requires that the + process handles system messages correctly. + See <seealso marker="sys">sys(3)</seealso> + and <seealso marker="doc/design_principles:spec_proc">OTP + Design Principles</seealso> for information about system + messages.</p> + </desc> + </func> </funcs> <section> diff --git a/lib/stdlib/doc/src/ref_man.xml b/lib/stdlib/doc/src/ref_man.xml index 6c35578bdf..ea4009dc3e 100644 --- a/lib/stdlib/doc/src/ref_man.xml +++ b/lib/stdlib/doc/src/ref_man.xml @@ -73,7 +73,6 @@ <xi:include href="ms_transform.xml"/> <xi:include href="orddict.xml"/> <xi:include href="ordsets.xml"/> - <xi:include href="pg.xml"/> <xi:include href="pool.xml"/> <xi:include href="proc_lib.xml"/> <xi:include href="proplists.xml"/> diff --git a/lib/stdlib/doc/src/specs.xml b/lib/stdlib/doc/src/specs.xml index 60a04ed5e7..fd77b52da6 100644 --- a/lib/stdlib/doc/src/specs.xml +++ b/lib/stdlib/doc/src/specs.xml @@ -39,7 +39,6 @@ <xi:include href="../specs/specs_ms_transform.xml"/> <xi:include href="../specs/specs_orddict.xml"/> <xi:include href="../specs/specs_ordsets.xml"/> - <xi:include href="../specs/specs_pg.xml"/> <xi:include href="../specs/specs_pool.xml"/> <xi:include href="../specs/specs_proc_lib.xml"/> <xi:include href="../specs/specs_proplists.xml"/> diff --git a/lib/stdlib/doc/src/supervisor.xml b/lib/stdlib/doc/src/supervisor.xml index 3a5027d595..ffac1c0bd7 100644 --- a/lib/stdlib/doc/src/supervisor.xml +++ b/lib/stdlib/doc/src/supervisor.xml @@ -37,12 +37,12 @@ the <c>gen_event</c>, <c>gen_fsm</c>, or <c>gen_server</c> behaviours. A supervisor implemented using this module will have a standard set of interface functions and include functionality - for tracing and error reporting. Supervisors are used to build an + for tracing and error reporting. Supervisors are used to build a hierarchical process structure called a supervision tree, a nice way to structure a fault tolerant application. Refer to <em>OTP Design Principles</em> for more information.</p> - <p>A supervisor assumes the definition of which child processes to - supervise to be located in a callback module exporting a + <p>A supervisor expects the definition of which child processes to + supervise to be specified in a callback module exporting a pre-defined set of functions.</p> <p>Unless otherwise stated, all functions in this module will fail if the specified supervisor does not exist or if bad arguments @@ -53,18 +53,30 @@ <title>Supervision Principles</title> <p>The supervisor is responsible for starting, stopping and monitoring its child processes. The basic idea of a supervisor is - that it should keep its child processes alive by restarting them + that it shall keep its child processes alive by restarting them when necessary.</p> - <p>The children of a supervisor is defined as a list of + <p>The children of a supervisor are defined as a list of <em>child specifications</em>. When the supervisor is started, the child processes are started in order from left to right according to this list. When the supervisor terminates, it first terminates its child processes in reversed start order, from right to left.</p> - <p>A supervisor can have one of the following <em>restart strategies</em>:</p> + <marker id="sup_flags"/> + <p>The properties of a supervisor are defined by the supervisor + flags. This is the type definition for the supervisor flags: + </p> + <pre>sup_flags() = #{strategy => strategy(), % optional + intensity => non_neg_integer(), % optional + period => pos_integer()} % optional + </pre> + <p>A supervisor can have one of the following <em>restart + strategies</em>, specified with the <c>strategy</c> key in the + above map: + </p> <list type="bulleted"> <item> <p><c>one_for_one</c> - if one child process terminates and - should be restarted, only that child process is affected.</p> + should be restarted, only that child process is + affected. This is the default restart strategy.</p> </item> <item> <p><c>one_for_all</c> - if one child process terminates and @@ -94,43 +106,53 @@ instead the child specification identifier is used, <c>terminate_child/2</c> will return <c>{error,simple_one_for_one}</c>.</p> - <p>Because a <c>simple_one_for_one</c> supervisor could have many - children, it shuts them all down at same time. So, order in which they - are stopped is not defined. For the same reason, it could have an - overhead with regards to the <c>Shutdown</c> strategy.</p> + <p>Because a <c>simple_one_for_one</c> supervisor could have + many children, it shuts them all down asynchronously. This + means that the children will do their cleanup in parallel, + and therefore the order in which they are stopped is not + defined.</p> </item> </list> <p>To prevent a supervisor from getting into an infinite loop of - child process terminations and restarts, a <em>maximum restart frequency</em> - is defined using two integer values <c>MaxR</c> - and <c>MaxT</c>. If more than <c>MaxR</c> restarts occur within - <c>MaxT</c> seconds, the supervisor terminates all child - processes and then itself. + child process terminations and restarts, a <em>maximum restart + intensity</em> is defined using two integer values specified + with the <c>intensity</c> and <c>period</c> keys in the above + map. Assuming the values <c>MaxR</c> for <c>intensity</c> + and <c>MaxT</c> for <c>period</c>, then if more than <c>MaxR</c> + restarts occur within <c>MaxT</c> seconds, the supervisor will + terminate all child processes and then itself. The default value + for <c>intensity</c> is <c>1</c>, and the default value + for <c>period</c> is <c>5</c>. </p> <marker id="child_spec"/> <p>This is the type definition of a child specification:</p> - <pre> -child_spec() = {Id,StartFunc,Restart,Shutdown,Type,Modules} - Id = term() - StartFunc = {M,F,A} - M = F = atom() - A = [term()] - Restart = permanent | transient | temporary - Shutdown = brutal_kill | int()>0 | infinity - Type = worker | supervisor - Modules = [Module] | dynamic - Module = atom()</pre> + <pre>child_spec() = #{id => child_id(), % mandatory + start => mfargs(), % mandatory + restart => restart(), % optional + shutdown => shutdown(), % optional + type => worker(), % optional + modules => modules()} % optional</pre> + <p>The old tuple format is kept for backwards compatibility, + see <seealso marker="#type-child_spec">child_spec()</seealso>, + but the map is preferred. + </p> <list type="bulleted"> <item> - <p><c>Id</c> is a name that is used to identify the child + <p><c>id</c> is used to identify the child specification internally by the supervisor.</p> + <p>The <c>id</c> key is mandatory.</p> + <p>Note that this identifier on occations has been called + "name". As far as possible, the terms "identifier" or "id" + are now used but in order to keep backwards compatibility, + some occurences of "name" can still be found, for example + in error messages.</p> </item> <item> - <p><c>StartFunc</c> defines the function call used to start - the child process. It should be a module-function-arguments + <p><c>start</c> defines the function call used to start the + child process. It must be a module-function-arguments tuple <c>{M,F,A}</c> used as <c>apply(M,F,A)</c>.</p> <p>The start function <em>must create and link to</em> the child - process, and should return <c>{ok,Child}</c> or + process, and must return <c>{ok,Child}</c> or <c>{ok,Child,Info}</c> where <c>Child</c> is the pid of the child process and <c>Info</c> an arbitrary term which is ignored by the supervisor.</p> @@ -143,20 +165,23 @@ child_spec() = {Id,StartFunc,Restart,Shutdown,Type,Modules} error tuple <c>{error,Error}</c>.</p> <p>Note that the <c>start_link</c> functions of the different behaviour modules fulfill the above requirements.</p> + <p>The <c>start</c> key is mandatory.</p> </item> <item> - <p><c>Restart</c> defines when a terminated child process - should be restarted. A <c>permanent</c> child process should - always be restarted, a <c>temporary</c> child process should + <p><c>restart</c> defines when a terminated child process + shall be restarted. A <c>permanent</c> child process will + always be restarted, a <c>temporary</c> child process will never be restarted (even when the supervisor's restart strategy is <c>rest_for_one</c> or <c>one_for_all</c> and a sibling's death causes the temporary process to be terminated) and a - <c>transient</c> child process should be restarted only if + <c>transient</c> child process will be restarted only if it terminates abnormally, i.e. with another exit reason than <c>normal</c>, <c>shutdown</c> or <c>{shutdown,Term}</c>.</p> + <p>The <c>restart</c> key is optional. If it is not given, the + default value <c>permanent</c> will be used.</p> </item> <item> - <p><c>Shutdown</c> defines how a child process should be + <p><c>shutdown</c> defines how a child process shall be terminated. <c>brutal_kill</c> means the child process will be unconditionally terminated using <c>exit(Child,kill)</c>. An integer timeout value means that the supervisor will tell @@ -166,35 +191,45 @@ child_spec() = {Id,StartFunc,Restart,Shutdown,Type,Modules} no exit signal is received within the specified number of milliseconds, the child process is unconditionally terminated using <c>exit(Child,kill)</c>.</p> - <p>If the child process is another supervisor, <c>Shutdown</c> + <p>If the child process is another supervisor, the shutdown time should be set to <c>infinity</c> to give the subtree ample - time to shutdown. It is also allowed to set it to <c>infinity</c>, + time to shut down. It is also allowed to set it to <c>infinity</c>, if the child process is a worker.</p> <warning> - <p>Be careful by setting the <c>Shutdown</c> strategy to + <p>Be careful when setting the shutdown time to <c>infinity</c> when the child process is a worker. Because, in this situation, the termination of the supervision tree depends on the child process, it must be implemented in a safe way and its cleanup procedure must always return.</p> </warning> <p>Note that all child processes implemented using the standard - OTP behavior modules automatically adhere to the shutdown + OTP behaviour modules automatically adhere to the shutdown protocol.</p> + <p>The <c>shutdown</c> key is optional. If it is not given, + the default value <c>5000</c> will be used if the child is + of type <c>worker</c>; and <c>infinity</c> will be used if + the child is of type <c>supervisor</c>.</p> </item> <item> - <p><c>Type</c> specifies if the child process is a supervisor or + <p><c>type</c> specifies if the child process is a supervisor or a worker.</p> + <p>The <c>type</c> key is optional. If it is not given, the + default value <c>worker</c> will be used.</p> </item> <item> - <p><c>Modules</c> is used by the release handler during code + <p><c>modules</c> is used by the release handler during code replacement to determine which processes are using a certain - module. As a rule of thumb <c>Modules</c> should be a list - with one element <c>[Module]</c>, where <c>Module</c> is - the callback module, if the child process is a supervisor, - gen_server or gen_fsm. If the child process is an event - manager (gen_event) with a dynamic set of callback modules, - <c>Modules</c> should be <c>dynamic</c>. See <em>OTP Design Principles</em> - for more information about release handling.</p> + module. As a rule of thumb, if the child process is a + <c>supervisor</c>, <c>gen_server</c>, or <c>gen_fsm</c>, + this should be a list with one element <c>[Module]</c>, + where <c>Module</c> is the callback module. If the child + process is an event manager (<c>gen_event</c>) with a + dynamic set of callback modules, the value <c>dynamic</c> + shall be used. See <em>OTP Design Principles</em> for more + information about release handling.</p> + <p>The <c>modules</c> key is optional. If it is not given, it + defaults to <c>[M]</c>, where <c>M</c> comes from the + child's start <c>{M,F,A}</c></p> </item> <item> <p>Internally, the supervisor also keeps track of the pid @@ -213,11 +248,20 @@ child_spec() = {Id,StartFunc,Restart,Shutdown,Type,Modules} </datatype> <datatype> <name name="child_spec"/> + <desc><p>The tuple format is kept for backwards compatibility + only. A map is preferred; see more details + <seealso marker="#child_spec">above</seealso>.</p></desc> </datatype> <datatype> <name name="mfargs"/> - <desc><p><c>A</c> (the argument list) has the value - <c>undefined</c> if <c>Restart</c> is <c>temporary</c>.</p> + <desc> + <p>The value <c>undefined</c> for <c><anno>A</anno></c> (the + argument list) is only to be used internally + in <c>supervisor</c>. If the restart type of the child + is <c>temporary</c>, then the process is never to be + restarted and therefore there is no need to store the real + argument list. The value <c>undefined</c> will then be + stored instead.</p> </desc> </datatype> <datatype> @@ -233,6 +277,12 @@ child_spec() = {Id,StartFunc,Restart,Shutdown,Type,Modules} <name name="strategy"/> </datatype> <datatype> + <name name="sup_flags"/> + <desc><p>The tuple format is kept for backwards compatibility + only. A map is preferred; see more details + <seealso marker="#sup_flags">above</seealso>.</p></desc> + </datatype> + <datatype> <name name="sup_ref"/> </datatype> <datatype> @@ -253,20 +303,20 @@ child_spec() = {Id,StartFunc,Restart,Shutdown,Type,Modules} the supervisor is linked to the calling process (its supervisor).</p> <p>The created supervisor process calls <c><anno>Module</anno>:init/1</c> to - find out about restart strategy, maximum restart frequency + find out about restart strategy, maximum restart intensity and child processes. To ensure a synchronized start-up procedure, <c>start_link/2,3</c> does not return until <c><anno>Module</anno>:init/1</c> has returned and all child processes have been started.</p> - <p>If <c><anno>SupName</anno>={local,Name}</c> the supervisor is registered + <p>If <c><anno>SupName</anno>={local,Name}</c>, the supervisor is registered locally as <c>Name</c> using <c>register/2</c>. If <c><anno>SupName</anno>={global,Name}</c> the supervisor is registered globally as <c>Name</c> using <c>global:register_name/2</c>. If <c><anno>SupName</anno>={via,<anno>Module</anno>,<anno>Name</anno>}</c> the supervisor is registered as <c>Name</c> using the registry represented by - <c>Module</c>. The <c>Module</c> callback should export the functions + <c>Module</c>. The <c>Module</c> callback must export the functions <c>register_name/2</c>, <c>unregister_name/1</c> and <c>send/2</c>, - which should behave like the corresponding functions in <c>global</c>. + which shall behave like the corresponding functions in <c>global</c>. Thus, <c>{via,global,<anno>Name</anno>}</c> is a valid reference.</p> <p>If no name is provided, the supervisor is not registered.</p> <p><c><anno>Module</anno></c> is the name of the callback module.</p> @@ -274,14 +324,14 @@ child_spec() = {Id,StartFunc,Restart,Shutdown,Type,Modules} the argument to <c><anno>Module</anno>:init/1</c>.</p> <p>If the supervisor and its child processes are successfully created (i.e. if all child process start functions return - <c>{ok,Child}</c>, <c>{ok,Child,Info}</c>, or <c>ignore</c>) + <c>{ok,Child}</c>, <c>{ok,Child,Info}</c>, or <c>ignore</c>), the function returns <c>{ok,Pid}</c>, where <c>Pid</c> is the pid of the supervisor. If there already exists a process - with the specified <c><anno>SupName</anno></c> the function returns + with the specified <c><anno>SupName</anno></c>, the function returns <c>{error,{already_started,Pid}}</c>, where <c>Pid</c> is the pid of that process.</p> <p>If <c><anno>Module</anno>:init/1</c> returns <c>ignore</c>, this function - returns <c>ignore</c> as well and the supervisor terminates + returns <c>ignore</c> as well, and the supervisor terminates with reason <c>normal</c>. If <c><anno>Module</anno>:init/1</c> fails or returns an incorrect value, this function returns <c>{error,Term}</c> where <c>Term</c> @@ -297,7 +347,6 @@ child_spec() = {Id,StartFunc,Restart,Shutdown,Type,Modules} <func> <name name="start_child" arity="2"/> <fsummary>Dynamically add a child process to a supervisor.</fsummary> - <type name="child_spec"/> <type name="startchild_ret"/> <type name="startchild_err"/> <desc> @@ -314,35 +363,35 @@ child_spec() = {Id,StartFunc,Restart,Shutdown,Type,Modules} <item><c>{via,Module,Name}</c>, if the supervisor is registered through an alternative process registry.</item> </list> - <p><c><anno>ChildSpec</anno></c> should be a valid child specification + <p><c><anno>ChildSpec</anno></c> must be a valid child specification (unless the supervisor is a <c>simple_one_for_one</c> - supervisor, see below). The child process will be started by + supervisor; see below). The child process will be started by using the start function as defined in the child specification.</p> - <p>If the case of a <c>simple_one_for_one</c> supervisor, + <p>In the case of a <c>simple_one_for_one</c> supervisor, the child specification defined in <c>Module:init/1</c> will - be used and <c><anno>ChildSpec</anno></c> should instead be an arbitrary + be used, and <c><anno>ChildSpec</anno></c> shall instead be an arbitrary list of terms <c><anno>List</anno></c>. The child process will then be started by appending <c><anno>List</anno></c> to the existing start function arguments, i.e. by calling <c>apply(M, F, A++<anno>List</anno>)</c> where <c>{M,F,A}</c> is the start function defined in the child specification.</p> <p>If there already exists a child specification with - the specified <c><anno>Id</anno></c>, <c><anno>ChildSpec</anno></c> is discarded and + the specified identifier, <c><anno>ChildSpec</anno></c> is discarded, and the function returns <c>{error,already_present}</c> or <c>{error,{already_started,<anno>Child</anno>}}</c>, depending on if the corresponding child process is running or not.</p> <p>If the child process start function returns <c>{ok,<anno>Child</anno>}</c> - or <c>{ok,<anno>Child</anno>,<anno>Info</anno>}</c>, the child specification and pid is + or <c>{ok,<anno>Child</anno>,<anno>Info</anno>}</c>, the child specification and pid are added to the supervisor and the function returns the same value.</p> <p>If the child process start function returns <c>ignore</c>, the child specification is added to the supervisor, the pid - is set to <c>undefined</c> and the function returns + is set to <c>undefined</c>, and the function returns <c>{ok,undefined}</c>.</p> <p>If the child process start function returns an error tuple or an erroneous value, or if it fails, the child specification is - discarded and the function returns <c>{error,Error}</c> where + discarded, and the function returns <c>{error,Error}</c> where <c>Error</c> is a term containing information about the error and child specification.</p> </desc> @@ -366,7 +415,7 @@ child_spec() = {Id,StartFunc,Restart,Shutdown,Type,Modules} <p>If the child is temporary, the child specification is deleted as soon as the process terminates. This means - that <c>delete_child/2</c> has no meaning + that <c>delete_child/2</c> has no meaning, and <c>restart_child/2</c> can not be used for these children.</p> @@ -375,13 +424,13 @@ child_spec() = {Id,StartFunc,Restart,Shutdown,Type,Modules} process is alive, but is not a child of the given supervisor, the function will return <c>{error,not_found}</c>. If the child specification - identifier is given instead instead of a <c>pid()</c>, the + identifier is given instead of a <c>pid()</c>, the function will return <c>{error,simple_one_for_one}</c>.</p> <p>If successful, the function returns <c>ok</c>. If there is no child specification with the specified <c><anno>Id</anno></c>, the function returns <c>{error,not_found}</c>.</p> - <p>See <c>start_child/2</c> for a description of - <c><anno>SupRef</anno></c>.</p> + <p>See <seealso marker="#SupRef"><c>start_child/2</c></seealso> + for a description of <c><anno>SupRef</anno></c>.</p> </desc> </func> <func> @@ -390,15 +439,15 @@ child_spec() = {Id,StartFunc,Restart,Shutdown,Type,Modules} <desc> <p>Tells the supervisor <c><anno>SupRef</anno></c> to delete the child specification identified by <c><anno>Id</anno></c>. The corresponding child - process must not be running, use <c>terminate_child/2</c> to + process must not be running. Use <c>terminate_child/2</c> to terminate it.</p> - <p>See <seealso marker="#SupRef"><c>start_child/2</c></seealso> for a description of - <c>SupRef</c>.</p> + <p>See <seealso marker="#SupRef"><c>start_child/2</c></seealso> + for a description of <c><anno>SupRef</anno></c>.</p> <p>If successful, the function returns <c>ok</c>. If the child specification identified by <c><anno>Id</anno></c> exists but the corresponding child process is running or about to be restarted, the function returns <c>{error,running}</c> or - <c>{error,restarting}</c> respectively. If the child specification + <c>{error,restarting}</c>, respectively. If the child specification identified by <c><anno>Id</anno></c> does not exist, the function returns <c>{error,not_found}</c>.</p> </desc> @@ -410,10 +459,10 @@ child_spec() = {Id,StartFunc,Restart,Shutdown,Type,Modules} <p>Tells the supervisor <c><anno>SupRef</anno></c> to restart a child process corresponding to the child specification identified by <c><anno>Id</anno></c>. The child - specification must exist and the corresponding child process + specification must exist, and the corresponding child process must not be running.</p> <p>Note that for temporary children, the child specification - is automatically deleted when the child terminates, and thus + is automatically deleted when the child terminates; thus it is not possible to restart such children.</p> <p>See <seealso marker="#SupRef"><c>start_child/2</c></seealso> for a description of <c>SupRef</c>.</p> @@ -429,7 +478,7 @@ child_spec() = {Id,StartFunc,Restart,Shutdown,Type,Modules} is added to the supervisor and the function returns the same value.</p> <p>If the child process start function returns <c>ignore</c>, - the pid remains set to <c>undefined</c> and the function + the pid remains set to <c>undefined</c>, and the function returns <c>{ok,undefined}</c>.</p> <p>If the child process start function returns an error tuple or an erroneous value, or if it fails, the function returns @@ -462,7 +511,7 @@ child_spec() = {Id,StartFunc,Restart,Shutdown,Type,Modules} <item> <p><c><anno>Child</anno></c> - the pid of the corresponding child process, the atom <c>restarting</c> if the process is about to be - restarted or <c>undefined</c> if there is no such process.</p> + restarted, or <c>undefined</c> if there is no such process.</p> </item> <item> <p><c><anno>Type</anno></c> - as defined in the child specification.</p> @@ -475,8 +524,8 @@ child_spec() = {Id,StartFunc,Restart,Shutdown,Type,Modules} </func> <func> <name name="count_children" arity="1"/> - <fsummary>Return counts for the number of childspecs, active children, - supervisors and workers.</fsummary> + <fsummary>Return counts for the number of child specifications, + active children, supervisors, and workers.</fsummary> <desc> <p>Returns a property list (see <c>proplists</c>) containing the counts for each of the following elements of the supervisor's @@ -500,6 +549,8 @@ child_spec() = {Id,StartFunc,Restart,Shutdown,Type,Modules} process is still alive.</p> </item> </list> + <p>See <seealso marker="#SupRef"><c>start_child/2</c></seealso> + for a description of <c><anno>SupRef</anno></c>.</p> </desc> </func> <func> @@ -511,11 +562,23 @@ child_spec() = {Id,StartFunc,Restart,Shutdown,Type,Modules} correct, or <c>{error,<anno>Error</anno>}</c> otherwise.</p> </desc> </func> + <func> + <name name="get_childspec" arity="2"/> + <fsummary>Return the child specification map for the given + child.</fsummary> + <desc> + <p>Returns the child specification map for the child identified + by <c>Id</c> under supervisor <c>SupRef</c>. The returned + map contains all keys, both mandatory and optional.</p> + <p>See <seealso marker="#SupRef"><c>start_child/2</c></seealso> + for a description of <c><anno>SupRef</anno></c>.</p> + </desc> + </func> </funcs> <section> <title>CALLBACK FUNCTIONS</title> - <p>The following functions should be exported from a + <p>The following functions must be exported from a <c>supervisor</c> callback module.</p> </section> <funcs> @@ -524,33 +587,37 @@ child_spec() = {Id,StartFunc,Restart,Shutdown,Type,Modules} <fsummary>Return a supervisor specification.</fsummary> <type> <v>Args = term()</v> - <v>Result = {ok,{{RestartStrategy,MaxR,MaxT},[ChildSpec]}} | ignore</v> - <v> RestartStrategy = <seealso marker="#type-strategy">strategy()</seealso></v> - <v> MaxR = integer()>=0</v> - <v> MaxT = integer()>0</v> + <v>Result = {ok,{SupFlags,[ChildSpec]}} | ignore</v> + <v> SupFlags = <seealso marker="#type-sup_flags">sup_flags()</seealso></v> <v> ChildSpec = <seealso marker="#type-child_spec">child_spec()</seealso></v> </type> <desc> <p>Whenever a supervisor is started using <c>supervisor:start_link/2,3</c>, this function is called by the new process to find out about restart strategy, maximum - restart frequency and child specifications.</p> + restart intensity, and child specifications.</p> <p><c>Args</c> is the <c>Args</c> argument provided to the start function.</p> - <p><c>RestartStrategy</c> is the restart strategy and - <c>MaxR</c> and <c>MaxT</c> defines the maximum restart - frequency of the supervisor. <c>[ChildSpec]</c> is a list of - valid child specifications defining which child processes - the supervisor should start and monitor. See the discussion - about Supervision Principles above.</p> + <p><c>SupFlags</c> is the supervisor flags defining the + restart strategy and max restart intensity for the + supervisor. <c>[ChildSpec]</c> is a list of valid child + specifications defining which child processes the supervisor + shall start and monitor. See the discussion about + Supervision Principles above.</p> <p>Note that when the restart strategy is <c>simple_one_for_one</c>, the list of child specifications must be a list with one child specification only. - (The <c>Id</c> is ignored). No child process is then started + (The child specification identifier is ignored.) No child process is then started during the initialization phase, but all children are assumed to be started dynamically using <c>supervisor:start_child/2</c>.</p> <p>The function may also return <c>ignore</c>.</p> + <p>Note that this function might also be called as a part of a + code upgrade procedure. For this reason, the function should + not have any side effects. See + <seealso marker="doc/design_principles:appup_cookbook#sup">Design + Principles</seealso> for more information about code upgrade + of supervisors.</p> </desc> </func> </funcs> diff --git a/lib/stdlib/doc/src/sys.xml b/lib/stdlib/doc/src/sys.xml index 19605f325b..cf7df54d1d 100644 --- a/lib/stdlib/doc/src/sys.xml +++ b/lib/stdlib/doc/src/sys.xml @@ -359,6 +359,17 @@ installed.</p> </desc> </func> + <func> + <name name="terminate" arity="2"/> + <name name="terminate" arity="3"/> + <fsummary>Terminate the process</fsummary> + <desc> + <p>This function orders the process to terminate with the + given <c><anno>Reason</anno></c>. The termination is done + asynchronously, so there is no guarantee that the process is + actually terminated when the function returns.</p> + </desc> + </func> </funcs> <section> diff --git a/lib/stdlib/src/Makefile b/lib/stdlib/src/Makefile index 9ab2cd4134..1b3744b6fb 100644 --- a/lib/stdlib/src/Makefile +++ b/lib/stdlib/src/Makefile @@ -97,7 +97,6 @@ MODULES= \ otp_internal \ orddict \ ordsets \ - pg \ re \ pool \ proc_lib \ diff --git a/lib/stdlib/src/binary.erl b/lib/stdlib/src/binary.erl index 4850a59eb6..b94829892d 100644 --- a/lib/stdlib/src/binary.erl +++ b/lib/stdlib/src/binary.erl @@ -215,12 +215,13 @@ split(H,N) -> Subject :: binary(), Pattern :: binary() | [binary()] | cp(), Options :: [Option], - Option :: {scope, part()} | trim | global, + Option :: {scope, part()} | trim | global | trim_all, Parts :: [binary()]. split(Haystack,Needles,Options) -> try - {Part,Global,Trim} = get_opts_split(Options,{no,false,false}), + {Part,Global,Trim,TrimAll} = + get_opts_split(Options,{no,false,false,false}), Moptlist = case Part of no -> []; @@ -236,20 +237,24 @@ split(Haystack,Needles,Options) -> Match -> [Match] end end, - do_split(Haystack,MList,0,Trim) + do_split(Haystack,MList,0,Trim,TrimAll) catch _:_ -> erlang:error(badarg) end. -do_split(H,[],N,true) when N >= byte_size(H) -> +do_split(H,[],N,true,_) when N >= byte_size(H) -> []; -do_split(H,[],N,_) -> +do_split(H,[],N,_,true) when N >= byte_size(H) -> + []; +do_split(H,[],N,_,_) -> [binary:part(H,{N,byte_size(H)-N})]; -do_split(H,[{A,B}|T],N,Trim) -> +do_split(H,[{A,B}|T],N,Trim,TrimAll) -> case binary:part(H,{N,A-N}) of + <<>> when TrimAll == true -> + do_split(H,T,A+B,Trim,TrimAll); <<>> -> - Rest = do_split(H,T,A+B,Trim), + Rest = do_split(H,T,A+B,Trim,TrimAll), case {Trim, Rest} of {true,[]} -> []; @@ -257,7 +262,7 @@ do_split(H,[{A,B}|T],N,Trim) -> [<<>> | Rest] end; Oth -> - [Oth | do_split(H,T,A+B,Trim)] + [Oth | do_split(H,T,A+B,Trim,TrimAll)] end. @@ -346,14 +351,16 @@ splitat(H,N,[I|T]) -> %% Simple helper functions %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -get_opts_split([],{Part,Global,Trim}) -> - {Part,Global,Trim}; -get_opts_split([{scope,{A,B}} | T],{_Part,Global,Trim}) -> - get_opts_split(T,{{A,B},Global,Trim}); -get_opts_split([global | T],{Part,_Global,Trim}) -> - get_opts_split(T,{Part,true,Trim}); -get_opts_split([trim | T],{Part,Global,_Trim}) -> - get_opts_split(T,{Part,Global,true}); +get_opts_split([],{Part,Global,Trim,TrimAll}) -> + {Part,Global,Trim,TrimAll}; +get_opts_split([{scope,{A,B}} | T],{_Part,Global,Trim,TrimAll}) -> + get_opts_split(T,{{A,B},Global,Trim,TrimAll}); +get_opts_split([global | T],{Part,_Global,Trim,TrimAll}) -> + get_opts_split(T,{Part,true,Trim,TrimAll}); +get_opts_split([trim | T],{Part,Global,_Trim,TrimAll}) -> + get_opts_split(T,{Part,Global,true,TrimAll}); +get_opts_split([trim_all | T],{Part,Global,Trim,_TrimAll}) -> + get_opts_split(T,{Part,Global,Trim,true}); get_opts_split(_,_) -> throw(badopt). diff --git a/lib/stdlib/src/erl_eval.erl b/lib/stdlib/src/erl_eval.erl index 639ddfc214..371573dc23 100644 --- a/lib/stdlib/src/erl_eval.erl +++ b/lib/stdlib/src/erl_eval.erl @@ -1172,7 +1172,7 @@ match_tuple([], _, _, Bs, _BBs) -> match_map([{map_field_exact, _, K, V}|Fs], Map, Bs0, BBs) -> Vm = try - {value, Ke, _} = expr(K, new_bindings()), + {value, Ke, _} = expr(K, Bs0), maps:get(Ke,Map) catch error:_ -> throw(nomatch) diff --git a/lib/stdlib/src/erl_internal.erl b/lib/stdlib/src/erl_internal.erl index edfb097de0..2bf8b86c23 100644 --- a/lib/stdlib/src/erl_internal.erl +++ b/lib/stdlib/src/erl_internal.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1998-2013. All Rights Reserved. +%% Copyright Ericsson AB 1998-2014. 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 @@ -51,6 +51,8 @@ type_test/2,new_type_test/2,old_type_test/2,old_bif/2]). -export([arith_op/2,bool_op/2,comp_op/2,list_op/2,send_op/2,op_type/2]). +-export([is_type/2]). + %%--------------------------------------------------------------------------- %% Erlang builtin functions allowed in guards. @@ -293,6 +295,7 @@ bif(garbage_collect, 1) -> true; bif(garbage_collect, 2) -> true; bif(get, 0) -> true; bif(get, 1) -> true; +bif(get_keys, 0) -> true; bif(get_keys, 1) -> true; bif(group_leader, 0) -> true; bif(group_leader, 2) -> true; @@ -530,3 +533,53 @@ old_bif(unlink, 1) -> true; old_bif(unregister, 1) -> true; old_bif(whereis, 1) -> true; old_bif(Name, A) when is_atom(Name), is_integer(A) -> false. + +-spec is_type(Name, NumberOfTypeVariables) -> boolean() when + Name :: atom(), + NumberOfTypeVariables :: non_neg_integer(). +%% Returns true if Name/NumberOfTypeVariables is a predefined type. + +is_type(any, 0) -> true; +is_type(arity, 0) -> true; +is_type(atom, 0) -> true; +is_type(binary, 0) -> true; +is_type(bitstring, 0) -> true; +is_type(bool, 0) -> true; +is_type(boolean, 0) -> true; +is_type(byte, 0) -> true; +is_type(char, 0) -> true; +is_type(float, 0) -> true; +is_type(function, 0) -> true; +is_type(identifier, 0) -> true; +is_type(integer, 0) -> true; +is_type(iodata, 0) -> true; +is_type(iolist, 0) -> true; +is_type(list, 0) -> true; +is_type(list, 1) -> true; +is_type(map, 0) -> true; +is_type(maybe_improper_list, 0) -> true; +is_type(maybe_improper_list, 2) -> true; +is_type(mfa, 0) -> true; +is_type(module, 0) -> true; +is_type(neg_integer, 0) -> true; +is_type(nil, 0) -> true; +is_type(no_return, 0) -> true; +is_type(node, 0) -> true; +is_type(non_neg_integer, 0) -> true; +is_type(none, 0) -> true; +is_type(nonempty_improper_list, 2) -> true; +is_type(nonempty_list, 0) -> true; +is_type(nonempty_list, 1) -> true; +is_type(nonempty_maybe_improper_list, 0) -> true; +is_type(nonempty_maybe_improper_list, 2) -> true; +is_type(nonempty_string, 0) -> true; +is_type(number, 0) -> true; +is_type(pid, 0) -> true; +is_type(port, 0) -> true; +is_type(pos_integer, 0) -> true; +is_type(reference, 0) -> true; +is_type(string, 0) -> true; +is_type(term, 0) -> true; +is_type(timeout, 0) -> true; +is_type(tuple, 0) -> true; +is_type(_, _) -> false. diff --git a/lib/stdlib/src/erl_lint.erl b/lib/stdlib/src/erl_lint.erl index 39cc03cf7a..26d8454731 100644 --- a/lib/stdlib/src/erl_lint.erl +++ b/lib/stdlib/src/erl_lint.erl @@ -130,6 +130,8 @@ value_option(Flag, Default, On, OnVal, Off, OffVal, Opts) -> :: dict:dict(mfa(), line()), callbacks = dict:new() %Callback types :: dict:dict(mfa(), line()), + optional_callbacks = dict:new() %Optional callbacks + :: dict:dict(mfa(), line()), types = dict:new() %Type definitions :: dict:dict(ta(), #typeinfo{}), exp_types=gb_sets:empty() %Exported types @@ -237,10 +239,7 @@ format_error({too_many_arguments,Arity}) -> "maximum allowed is ~w", [Arity,?MAX_ARGUMENTS]); %% --- patterns and guards --- format_error(illegal_pattern) -> "illegal pattern"; -format_error(illegal_map_key) -> - "illegal map key"; -format_error({illegal_map_key_variable,K}) -> - io_lib:format("illegal use of variable ~w in map",[K]); +format_error(illegal_map_key) -> "illegal map key in pattern"; format_error(illegal_bin_pattern) -> "binary patterns cannot be matched in parallel using '='"; format_error(illegal_expr) -> "illegal expression"; @@ -313,13 +312,20 @@ format_error({undefined_behaviour,Behaviour}) -> io_lib:format("behaviour ~w undefined", [Behaviour]); format_error({undefined_behaviour_callbacks,Behaviour}) -> io_lib:format("behaviour ~w callback functions are undefined", - [Behaviour]); + [Behaviour]); format_error({ill_defined_behaviour_callbacks,Behaviour}) -> io_lib:format("behaviour ~w callback functions erroneously defined", [Behaviour]); +format_error({ill_defined_optional_callbacks,Behaviour}) -> + io_lib:format("behaviour ~w optional callback functions erroneously defined", + [Behaviour]); format_error({behaviour_info, {_M,F,A}}) -> io_lib:format("cannot define callback attibute for ~w/~w when " "behaviour_info is defined",[F,A]); +format_error({redefine_optional_callback, {F, A}}) -> + io_lib:format("optional callback ~w/~w duplicated", [F, A]); +format_error({undefined_callback, {_M, F, A}}) -> + io_lib:format("callback ~w/~w is undefined", [F, A]); %% --- types and specs --- format_error({singleton_typevar, Name}) -> io_lib:format("type variable ~w is only used once (is unbound)", [Name]); @@ -331,14 +337,10 @@ format_error({undefined_type, {TypeName, Arity}}) -> io_lib:format("type ~w~s undefined", [TypeName, gen_type_paren(Arity)]); format_error({unused_type, {TypeName, Arity}}) -> io_lib:format("type ~w~s is unused", [TypeName, gen_type_paren(Arity)]); -%% format_error({new_builtin_type, {TypeName, Arity}}) -> -%% io_lib:format("type ~w~s is a new builtin type; " -%% "its (re)definition is allowed only until the next release", -%% [TypeName, gen_type_paren(Arity)]); -format_error({new_var_arity_type, TypeName}) -> - io_lib:format("type ~w is a new builtin type; " +format_error({new_builtin_type, {TypeName, Arity}}) -> + io_lib:format("type ~w~s is a new builtin type; " "its (re)definition is allowed only until the next release", - [TypeName]); + [TypeName, gen_type_paren(Arity)]); format_error({builtin_type, {TypeName, Arity}}) -> io_lib:format("type ~w~s is a builtin type; it cannot be redefined", [TypeName, gen_type_paren(Arity)]); @@ -352,10 +354,14 @@ format_error({type_syntax, Constr}) -> io_lib:format("bad ~w type", [Constr]); format_error({redefine_spec, {M, F, A}}) -> io_lib:format("spec for ~w:~w/~w already defined", [M, F, A]); -format_error({redefine_callback, {M, F, A}}) -> - io_lib:format("callback ~w:~w/~w already defined", [M, F, A]); -format_error({spec_fun_undefined, {M, F, A}}) -> - io_lib:format("spec for undefined function ~w:~w/~w", [M, F, A]); +format_error({redefine_spec, {F, A}}) -> + io_lib:format("spec for ~w/~w already defined", [F, A]); +format_error({redefine_callback, {F, A}}) -> + io_lib:format("callback ~w/~w already defined", [F, A]); +format_error({bad_callback, {M, F, A}}) -> + io_lib:format("explicit module not allowed for callback ~w:~w/~w ", [M, F, A]); +format_error({spec_fun_undefined, {F, A}}) -> + io_lib:format("spec for undefined function ~w/~w", [F, A]); format_error({missing_spec, {F,A}}) -> io_lib:format("missing specification for function ~w/~w", [F, A]); format_error(spec_wrong_arity) -> @@ -383,9 +389,7 @@ format_error({underspecified_opaque, {TypeName, Arity}}) -> [TypeName, gen_type_paren(Arity)]); %% --- obsolete? unused? --- format_error({format_error, {Fmt, Args}}) -> - io_lib:format(Fmt, Args); -format_error({mnemosyne, What}) -> - "mnemosyne " ++ What ++ ", missing transformation". + io_lib:format(Fmt, Args). gen_type_paren(Arity) when is_integer(Arity), Arity >= 0 -> gen_type_paren_1(Arity, ")"). @@ -727,6 +731,8 @@ attribute_state({attribute,L,spec,{Fun,Types}}, St) -> spec_decl(L, Fun, Types, St); attribute_state({attribute,L,callback,{Fun,Types}}, St) -> callback_decl(L, Fun, Types, St); +attribute_state({attribute,L,optional_callbacks,Es}, St) -> + optional_callbacks(L, Es, St); attribute_state({attribute,L,on_load,Val}, St) -> on_load(L, Val, St); attribute_state({attribute,_L,_Other,_Val}, St) -> % Ignore others @@ -751,8 +757,6 @@ function_state({attribute,La,Attr,_Val}, St) -> add_error(La, {attribute,Attr}, St); function_state({function,L,N,A,Cs}, St) -> function(L, N, A, Cs, St); -function_state({rule,L,_N,_A,_Cs}, St) -> - add_error(L, {mnemosyne,"rule"}, St); function_state({eof,L}, St) -> eof(L, St). %% eof(LastLine, State) -> @@ -834,57 +838,73 @@ check_behaviour(St0) -> %% Check behaviours for existence and defined functions. behaviour_check(Bs, St0) -> - {AllBfs,St1} = all_behaviour_callbacks(Bs, [], St0), - St = behaviour_missing_callbacks(AllBfs, St1), + {AllBfs0, St1} = all_behaviour_callbacks(Bs, [], St0), + St = behaviour_missing_callbacks(AllBfs0, St1), + Exports = exports(St0), + F = fun(Bfs, OBfs) -> + [B || B <- Bfs, + not lists:member(B, OBfs) + orelse gb_sets:is_member(B, Exports)] + end, + %% After fixing missing callbacks new warnings may be emitted. + AllBfs = [{Item,F(Bfs0, OBfs0)} || {Item,Bfs0,OBfs0} <- AllBfs0], behaviour_conflicting(AllBfs, St). all_behaviour_callbacks([{Line,B}|Bs], Acc, St0) -> - {Bfs0,St} = behaviour_callbacks(Line, B, St0), - all_behaviour_callbacks(Bs, [{{Line,B},Bfs0}|Acc], St); + {Bfs0,OBfs0,St} = behaviour_callbacks(Line, B, St0), + all_behaviour_callbacks(Bs, [{{Line,B},Bfs0,OBfs0}|Acc], St); all_behaviour_callbacks([], Acc, St) -> {reverse(Acc),St}. behaviour_callbacks(Line, B, St0) -> try B:behaviour_info(callbacks) of - Funcs when is_list(Funcs) -> - All = all(fun({FuncName, Arity}) -> - is_atom(FuncName) andalso is_integer(Arity); - ({FuncName, Arity, Spec}) -> - is_atom(FuncName) andalso is_integer(Arity) - andalso is_list(Spec); - (_Other) -> - false - end, - Funcs), - MaybeRemoveSpec = fun({_F,_A}=FA) -> FA; - ({F,A,_S}) -> {F,A}; - (Other) -> Other - end, - if - All =:= true -> - {[MaybeRemoveSpec(F) || F <- Funcs], St0}; + undefined -> + St1 = add_warning(Line, {undefined_behaviour_callbacks, B}, St0), + {[], [], St1}; + Funcs -> + case is_fa_list(Funcs) of true -> + try B:behaviour_info(optional_callbacks) of + undefined -> + {Funcs, [], St0}; + OptFuncs -> + %% OptFuncs should always be OK thanks to + %% sys_pre_expand. + case is_fa_list(OptFuncs) of + true -> + {Funcs, OptFuncs, St0}; + false -> + W = {ill_defined_optional_callbacks, B}, + St1 = add_warning(Line, W, St0), + {Funcs, [], St1} + end + catch + _:_ -> + {Funcs, [], St0} + end; + false -> St1 = add_warning(Line, - {ill_defined_behaviour_callbacks,B}, + {ill_defined_behaviour_callbacks, B}, St0), - {[], St1} - end; - undefined -> - St1 = add_warning(Line, {undefined_behaviour_callbacks,B}, St0), - {[], St1}; - _Other -> - St1 = add_warning(Line, {ill_defined_behaviour_callbacks,B}, St0), - {[], St1} + {[], [], St1} + end catch _:_ -> - St1 = add_warning(Line, {undefined_behaviour,B}, St0), - {[], St1} + St1 = add_warning(Line, {undefined_behaviour, B}, St0), + {[], [], St1} end. -behaviour_missing_callbacks([{{Line,B},Bfs}|T], St0) -> +behaviour_missing_callbacks([{{Line,B},Bfs0,OBfs}|T], St0) -> + Bfs = ordsets:subtract(ordsets:from_list(Bfs0), ordsets:from_list(OBfs)), Exports = gb_sets:to_list(exports(St0)), - Missing = ordsets:subtract(ordsets:from_list(Bfs), Exports), + Missing = ordsets:subtract(Bfs, Exports), St = foldl(fun (F, S0) -> - add_warning(Line, {undefined_behaviour_func,F,B}, S0) + case is_fa(F) of + true -> + M = {undefined_behaviour_func,F,B}, + add_warning(Line, M, S0); + false -> + S0 % ill_defined_behaviour_callbacks + end end, St0, Missing), behaviour_missing_callbacks(T, St); behaviour_missing_callbacks([], St) -> St. @@ -1046,10 +1066,9 @@ check_undefined_types(#lint{usage=Usage,types=Def}=St0) -> Used = Usage#usage.used_types, UTAs = dict:fetch_keys(Used), Undef = [{TA,dict:fetch(TA, Used)} || - {T,_}=TA <- UTAs, + TA <- UTAs, not dict:is_key(TA, Def), - not is_default_type(TA), - not is_newly_introduced_var_arity_type(T)], + not is_default_type(TA)], foldl(fun ({TA,L}, St) -> add_error(L, {undefined_type,TA}, St) end, St0, Undef). @@ -1127,19 +1146,29 @@ check_unused_records(Forms, St0) -> end. check_callback_information(#lint{callbacks = Callbacks, - defined = Defined} = State) -> - case gb_sets:is_member({behaviour_info,1}, Defined) of - false -> State; + optional_callbacks = OptionalCbs, + defined = Defined} = St0) -> + OptFun = fun({MFA, Line}, St) -> + case dict:is_key(MFA, Callbacks) of + true -> + St; + false -> + add_error(Line, {undefined_callback, MFA}, St) + end + end, + St1 = lists:foldl(OptFun, St0, dict:to_list(OptionalCbs)), + case gb_sets:is_member({behaviour_info, 1}, Defined) of + false -> St1; true -> case dict:size(Callbacks) of - 0 -> State; + 0 -> St1; _ -> CallbacksList = dict:to_list(Callbacks), FoldL = - fun({Fa,Line},St) -> + fun({Fa, Line}, St) -> add_error(Line, {behaviour_info, Fa}, St) end, - lists:foldl(FoldL, State, CallbacksList) + lists:foldl(FoldL, St1, CallbacksList) end end. @@ -1404,20 +1433,7 @@ pattern({cons,_Line,H,T}, Vt, Old, Bvt, St0) -> pattern({tuple,_Line,Ps}, Vt, Old, Bvt, St) -> pattern_list(Ps, Vt, Old, Bvt, St); pattern({map,_Line,Ps}, Vt, Old, Bvt, St) -> - foldl(fun - ({map_field_assoc,L,_,_}, {Psvt,Bvt0,St0}) -> - {Psvt,Bvt0,add_error(L, illegal_pattern, St0)}; - ({map_field_exact,L,KP,VP}, {Psvt,Bvt0,St0}) -> - case is_valid_map_key(KP, pattern, St0) of - true -> - {Pvt,Bvt1,St1} = pattern(VP, Vt, Old, Bvt, St0), - {vtmerge_pat(Pvt, Psvt),vtmerge_pat(Bvt0, Bvt1), St1}; - false -> - {Psvt,Bvt0,add_error(L, illegal_map_key, St0)}; - {false,variable,Var} -> - {Psvt,Bvt0,add_error(L, {illegal_map_key_variable,Var}, St0)} - end - end, {[],[],St}, Ps); + pattern_map(Ps, Vt, Old, Bvt, St); %%pattern({struct,_Line,_Tag,Ps}, Vt, Old, Bvt, St) -> %% pattern_list(Ps, Vt, Old, Bvt, St); pattern({record_index,Line,Name,Field}, _Vt, _Old, _Bvt, St) -> @@ -1571,6 +1587,21 @@ is_pattern_expr_1({op,_Line,Op,A1,A2}) -> erl_internal:arith_op(Op, 2) andalso all(fun is_pattern_expr/1, [A1,A2]); is_pattern_expr_1(_Other) -> false. +pattern_map(Ps, Vt, Old, Bvt, St) -> + foldl(fun + ({map_field_assoc,L,_,_}, {Psvt,Bvt0,St0}) -> + {Psvt,Bvt0,add_error(L, illegal_pattern, St0)}; + ({map_field_exact,L,K,V}, {Psvt,Bvt0,St0}) -> + case is_valid_map_key(K) of + true -> + {Kvt,St1} = expr(K, Vt, St0), + {Vvt,Bvt2,St2} = pattern(V, Vt, Old, Bvt, St1), + {vtmerge_pat(vtmerge_pat(Kvt, Vvt), Psvt), vtmerge_pat(Bvt0, Bvt2), St2}; + false -> + {Psvt,Bvt0,add_error(L, illegal_map_key, St0)} + end + end, {[],[],St}, Ps). + %% pattern_bin([Element], VarTable, Old, BinVarTable, State) -> %% {UpdVarTable,UpdBinVarTable,State}. %% Check a pattern group. BinVarTable are used binsize variables. @@ -2085,8 +2116,8 @@ 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,St4} = icrt_export(Csvts, Vt, {'receive',Line}, St3), - {vtmerge([Tvt,Tevt,Rvt]),St4}; + Rvt = icrt_export(Csvts, Vt, {'receive',Line}), + {vtmerge([Tvt,Tevt,Rvt]),St3}; expr({'fun',Line,Body}, Vt, St) -> %%No one can think funs export! case Body of @@ -2197,21 +2228,20 @@ expr({'try',Line,Es,Scs,Ccs,As}, Vt, St0) -> %% passes cannot handle exports in combination with 'after'. {Evt0,St1} = exprs(Es, Vt, St0), TryLine = {'try',Line}, - Uvt = vtunsafe(vtnames(vtnew(Evt0, Vt)), TryLine, []), - Evt1 = vtupdate(Uvt, vtsubtract(Evt0, Uvt)), + Uvt = vtunsafe(TryLine, Evt0, Vt), + Evt1 = vtupdate(Uvt, Evt0), {Sccs,St2} = icrt_clauses(Scs++Ccs, TryLine, vtupdate(Evt1, Vt), St1), Rvt0 = Sccs, - Rvt1 = vtupdate(vtunsafe(vtnames(vtnew(Rvt0, Vt)), TryLine, []), Rvt0), + Rvt1 = vtupdate(vtunsafe(TryLine, Rvt0, Vt), Rvt0), Evt2 = vtmerge(Evt1, Rvt1), {Avt0,St} = exprs(As, vtupdate(Evt2, Vt), St2), - Avt1 = vtupdate(vtunsafe(vtnames(vtnew(Avt0, Vt)), TryLine, []), Avt0), + Avt1 = vtupdate(vtunsafe(TryLine, Avt0, Vt), Avt0), Avt = vtmerge(Evt2, Avt1), {Avt,St}; expr({'catch',Line,E}, Vt, St0) -> %% No new variables added, flag new variables as unsafe. - {Evt,St1} = expr(E, Vt, St0), - Uvt = vtunsafe(vtnames(vtnew(Evt, Vt)), {'catch',Line}, []), - {vtupdate(Uvt,vtupdate(Evt, Vt)),St1}; + {Evt,St} = expr(E, Vt, St0), + {vtupdate(vtunsafe({'catch',Line}, Evt, Vt), Evt),St}; expr({match,_Line,P,E}, Vt, St0) -> {Evt,St1} = expr(E, Vt, St0), {Pvt,Bvt,St2} = pattern(P, vtupdate(Evt, Vt), St1), @@ -2224,9 +2254,8 @@ expr({op,Line,Op,L,R}, Vt, St0) when Op =:= 'orelse'; Op =:= 'andalso' -> {Evt1,St1} = expr(L, Vt, St0), Vt1 = vtupdate(Evt1, Vt), {Evt2,St2} = expr(R, Vt1, St1), - Vt2 = vtmerge(Evt2, Vt1), - {Vt3,St3} = icrt_export([Vt1,Vt2], Vt1, {Op,Line}, St2), - {vtmerge(Evt1, Vt3),St3}; + Evt3 = vtupdate(vtunsafe({Op,Line}, Evt2, Vt1), Evt2), + {vtmerge(Evt1, Evt3),St2}; expr({op,_Line,_Op,L,R}, Vt, St) -> expr_list([L,R], Vt, St); %They see the same variables %% The following are not allowed to occur anywhere! @@ -2254,14 +2283,9 @@ check_assoc_fields([{map_field_assoc,_,_,_}|Fs], St) -> check_assoc_fields([], St) -> St. -map_fields([{Tag,Line,K,V}|Fs], Vt, St, F) when Tag =:= map_field_assoc; - Tag =:= map_field_exact -> - St1 = case is_valid_map_key(K, St) of - true -> St; - false -> add_error(Line, illegal_map_key, St); - {false,variable,Var} -> add_error(Line, {illegal_map_key_variable,Var}, St) - end, - {Pvt,St2} = F([K,V], Vt, St1), +map_fields([{Tag,_,K,V}|Fs], Vt, St, F) when Tag =:= map_field_assoc; + Tag =:= map_field_exact -> + {Pvt,St2} = F([K,V], Vt, St), {Vts,St3} = map_fields(Fs, Vt, St2, F), {vtupdate(Pvt, Vts),St3}; map_fields([], Vt, St, _) -> @@ -2319,21 +2343,14 @@ is_valid_call(Call) -> _ -> true end. -%% is_valid_map_key(K,St) -> true | false | {false, Var::atom()} -%% check for value expression without variables - -is_valid_map_key(K,St) -> - is_valid_map_key(K,expr,St). -is_valid_map_key(K,Ctx,St) -> - case expr(K,[],St) of - {[],_} -> - is_valid_map_key_value(K,Ctx); - {[Var|_],_} -> - {false,variable,element(1,Var)} - end. +%% is_valid_map_key(K,St) -> true | false +%% variables are allowed for patterns only at the top of the tree -is_valid_map_key_value(K,Ctx) -> +is_valid_map_key({var,_,_}) -> true; +is_valid_map_key(K) -> is_valid_map_key_value(K). +is_valid_map_key_value(K) -> case K of + {var,_,_} -> false; {char,_,_} -> true; {integer,_,_} -> true; {float,_,_} -> true; @@ -2341,36 +2358,36 @@ is_valid_map_key_value(K,Ctx) -> {nil,_} -> true; {atom,_,_} -> true; {cons,_,H,T} -> - is_valid_map_key_value(H,Ctx) andalso - is_valid_map_key_value(T,Ctx); + is_valid_map_key_value(H) andalso + is_valid_map_key_value(T); {tuple,_,Es} -> foldl(fun(E,B) -> - B andalso is_valid_map_key_value(E,Ctx) + B andalso is_valid_map_key_value(E) end,true,Es); {map,_,Arg,Ps} -> % only check for value expressions to be valid % invalid map expressions are later checked in % core and kernel - is_valid_map_key_value(Arg,Ctx) andalso foldl(fun + is_valid_map_key_value(Arg) andalso foldl(fun ({Tag,_,Ke,Ve},B) when Tag =:= map_field_assoc; - Tag =:= map_field_exact, Ctx =:= expr -> - B andalso is_valid_map_key_value(Ke,Ctx) - andalso is_valid_map_key_value(Ve,Ctx); + Tag =:= map_field_exact -> + B andalso is_valid_map_key_value(Ke) + andalso is_valid_map_key_value(Ve); (_,_) -> false end,true,Ps); {map,_,Ps} -> foldl(fun ({Tag,_,Ke,Ve},B) when Tag =:= map_field_assoc; - Tag =:= map_field_exact, Ctx =:= expr -> - B andalso is_valid_map_key_value(Ke,Ctx) - andalso is_valid_map_key_value(Ve,Ctx); + Tag =:= map_field_exact -> + B andalso is_valid_map_key_value(Ke) + andalso is_valid_map_key_value(Ve); (_,_) -> false end, true, Ps); {record,_,_,Fs} -> foldl(fun ({record_field,_,Ke,Ve},B) -> - B andalso is_valid_map_key_value(Ke,Ctx) - andalso is_valid_map_key_value(Ve,Ctx) + B andalso is_valid_map_key_value(Ke) + andalso is_valid_map_key_value(Ve) end,true,Fs); {bin,_,Es} -> % only check for value expressions to be valid @@ -2378,9 +2395,9 @@ is_valid_map_key_value(K,Ctx) -> % core and kernel foldl(fun ({bin_element,_,E,_,_},B) -> - B andalso is_valid_map_key_value(E,Ctx) + B andalso is_valid_map_key_value(E) end,true,Es); - _ -> false + Val -> is_pattern_expr(Val) end. %% record_def(Line, RecordName, [RecField], State) -> State. @@ -2615,30 +2632,21 @@ type_def(Attr, Line, TypeName, ProtoType, Args, St0) -> true -> case is_obsolete_builtin_type(TypePair) of true -> StoreType(St0); - false -> add_error(Line, {builtin_type, TypePair}, St0) -%% case is_newly_introduced_builtin_type(TypePair) of -%% %% allow some types just for bootstrapping -%% true -> -%% Warn = {new_builtin_type, TypePair}, -%% St1 = add_warning(Line, Warn, St0), -%% StoreType(St1); -%% false -> -%% add_error(Line, {builtin_type, TypePair}, St0) -%% end + false -> + case is_newly_introduced_builtin_type(TypePair) of + %% allow some types just for bootstrapping + true -> + Warn = {new_builtin_type, TypePair}, + St1 = add_warning(Line, Warn, St0), + StoreType(St1); + false -> + add_error(Line, {builtin_type, TypePair}, St0) + end end; false -> - case - dict:is_key(TypePair, TypeDefs) orelse - is_var_arity_type(TypeName) - of + case dict:is_key(TypePair, TypeDefs) of true -> - case is_newly_introduced_var_arity_type(TypeName) of - true -> - Warn = {new_var_arity_type, TypeName}, - add_warning(Line, Warn, St0); - false -> - add_error(Line, {redefine_type, TypePair}, St0) - end; + add_error(Line, {redefine_type, TypePair}, St0); false -> St1 = case Attr =:= opaque andalso @@ -2675,7 +2683,7 @@ check_type({paren_type, _L, [Type]}, SeenVars, St) -> check_type({remote_type, L, [{atom, _, Mod}, {atom, _, Name}, Args]}, SeenVars, #lint{module=CurrentMod} = St) -> case Mod =:= CurrentMod of - true -> check_type({type, L, Name, Args}, SeenVars, St); + true -> check_type({user_type, L, Name, Args}, SeenVars, St); false -> lists:foldl(fun(T, {AccSeenVars, AccSt}) -> check_type(T, AccSeenVars, AccSt) @@ -2709,12 +2717,15 @@ check_type({type, L, range, [From, To]}, SeenVars, St) -> _ -> add_error(L, {type_syntax, range}, St) end, {SeenVars, St1}; -check_type({type, _L, map, any}, SeenVars, St) -> {SeenVars, St}; +check_type({type, L, map, any}, SeenVars, St) -> + %% To get usage right while map/0 is a newly_introduced_builtin_type. + St1 = used_type({map, 0}, L, St), + {SeenVars, St1}; check_type({type, _L, map, Pairs}, SeenVars, St) -> lists:foldl(fun(Pair, {AccSeenVars, AccSt}) -> check_type(Pair, AccSeenVars, AccSt) end, {SeenVars, St}, Pairs); -check_type({type, _L, map_field_assoc, Dom, Range}, SeenVars, St) -> +check_type({type, _L, map_field_assoc, [Dom, Range]}, SeenVars, St) -> check_type({type, -1, product, [Dom, Range]}, SeenVars, St); check_type({type, _L, tuple, any}, SeenVars, St) -> {SeenVars, St}; check_type({type, _L, any}, SeenVars, St) -> {SeenVars, St}; @@ -2733,41 +2744,39 @@ check_type({type, L, record, [Name|Fields]}, SeenVars, St) -> check_record_types(L, Atom, Fields, SeenVars, St1); _ -> {SeenVars, add_error(L, {type_syntax, record}, St)} end; -check_type({type, _L, product, Args}, SeenVars, St) -> +check_type({type, _L, Tag, Args}, SeenVars, St) when Tag =:= product; + Tag =:= union; + Tag =:= tuple -> lists:foldl(fun(T, {AccSeenVars, AccSt}) -> check_type(T, AccSeenVars, AccSt) end, {SeenVars, St}, Args); check_type({type, La, TypeName, Args}, SeenVars, St) -> - #lint{usage=Usage, module = Module, types=Types} = St, + #lint{module = Module, types=Types} = St, Arity = length(Args), TypePair = {TypeName, Arity}, - St1 = case is_var_arity_type(TypeName) of - true -> St; - false -> - Obsolete = (is_warn_enabled(deprecated_type, St) - andalso obsolete_builtin_type(TypePair)), - IsObsolete = - case Obsolete of - {deprecated, Repl, _} when element(1, Repl) =/= Module -> - case dict:find(TypePair, Types) of - {ok, _} -> false; - error -> true - end; - _ -> false - end, - case IsObsolete of - true -> + Obsolete = (is_warn_enabled(deprecated_type, St) + andalso obsolete_builtin_type(TypePair)), + St1 = case Obsolete of + {deprecated, Repl, _} when element(1, Repl) =/= Module -> + case dict:find(TypePair, Types) of + {ok, _} -> + used_type(TypePair, La, St); + error -> {deprecated, Replacement, Rel} = Obsolete, Tag = deprecated_builtin_type, W = {Tag, TypePair, Replacement, Rel}, - add_warning(La, W, St); - false -> - OldUsed = Usage#usage.used_types, - UsedTypes = dict:store(TypePair, La, OldUsed), - St#lint{usage=Usage#usage{used_types=UsedTypes}} - end - end, + add_warning(La, W, St) + end; + _ -> St + end, check_type({type, -1, product, Args}, SeenVars, St1); +check_type({user_type, L, TypeName, Args}, SeenVars, St) -> + Arity = length(Args), + TypePair = {TypeName, Arity}, + St1 = used_type(TypePair, L, St), + lists:foldl(fun(T, {AccSeenVars, AccSt}) -> + check_type(T, AccSeenVars, AccSt) + end, {SeenVars, St1}, Args); check_type(I, SeenVars, St) -> case erl_eval:partial_eval(I) of {integer,_ILn,_Integer} -> {SeenVars, St}; @@ -2809,95 +2818,24 @@ check_record_types([{type, _, field_type, [{atom, AL, FName}, Type]}|Left], check_record_types([], _Name, _DefFields, SeenVars, St, _SeenFields) -> {SeenVars, St}. -is_var_arity_type(tuple) -> true; -is_var_arity_type(map) -> true; -is_var_arity_type(product) -> true; -is_var_arity_type(union) -> true; -is_var_arity_type(record) -> true; -is_var_arity_type(_) -> false. - -is_default_type({any, 0}) -> true; -is_default_type({arity, 0}) -> true; -is_default_type({array, 0}) -> true; -is_default_type({atom, 0}) -> true; -is_default_type({atom, 1}) -> true; -is_default_type({binary, 0}) -> true; -is_default_type({binary, 2}) -> true; -is_default_type({bitstring, 0}) -> true; -is_default_type({bool, 0}) -> true; -is_default_type({boolean, 0}) -> true; -is_default_type({byte, 0}) -> true; -is_default_type({char, 0}) -> true; -is_default_type({dict, 0}) -> true; -is_default_type({digraph, 0}) -> true; -is_default_type({float, 0}) -> true; -is_default_type({'fun', 0}) -> true; -is_default_type({'fun', 2}) -> true; -is_default_type({function, 0}) -> true; -is_default_type({gb_set, 0}) -> true; -is_default_type({gb_tree, 0}) -> true; -is_default_type({identifier, 0}) -> true; -is_default_type({integer, 0}) -> true; -is_default_type({integer, 1}) -> true; -is_default_type({iodata, 0}) -> true; -is_default_type({iolist, 0}) -> true; -is_default_type({list, 0}) -> true; -is_default_type({list, 1}) -> true; -is_default_type({maybe_improper_list, 0}) -> true; -is_default_type({maybe_improper_list, 2}) -> true; -is_default_type({mfa, 0}) -> true; -is_default_type({module, 0}) -> true; -is_default_type({neg_integer, 0}) -> true; -is_default_type({nil, 0}) -> true; -is_default_type({no_return, 0}) -> true; -is_default_type({node, 0}) -> true; -is_default_type({non_neg_integer, 0}) -> true; -is_default_type({none, 0}) -> true; -is_default_type({nonempty_list, 0}) -> true; -is_default_type({nonempty_list, 1}) -> true; -is_default_type({nonempty_improper_list, 2}) -> true; -is_default_type({nonempty_maybe_improper_list, 0}) -> true; -is_default_type({nonempty_maybe_improper_list, 2}) -> true; -is_default_type({nonempty_string, 0}) -> true; -is_default_type({number, 0}) -> true; -is_default_type({pid, 0}) -> true; -is_default_type({port, 0}) -> true; -is_default_type({pos_integer, 0}) -> true; -is_default_type({queue, 0}) -> true; -is_default_type({range, 2}) -> true; -is_default_type({reference, 0}) -> true; -is_default_type({set, 0}) -> true; -is_default_type({string, 0}) -> true; -is_default_type({term, 0}) -> true; -is_default_type({timeout, 0}) -> true; -is_default_type({var, 1}) -> true; -is_default_type(_) -> false. - -is_newly_introduced_var_arity_type(map) -> true; -is_newly_introduced_var_arity_type(_) -> false. - -%% is_newly_introduced_builtin_type({Name, _}) when is_atom(Name) -> false. +used_type(TypePair, L, St) -> + Usage = St#lint.usage, + OldUsed = Usage#usage.used_types, + UsedTypes = dict:store(TypePair, L, OldUsed), + St#lint{usage=Usage#usage{used_types=UsedTypes}}. + +is_default_type({Name, NumberOfTypeVariables}) -> + erl_internal:is_type(Name, NumberOfTypeVariables). + +is_newly_introduced_builtin_type({map, 0}) -> true; +is_newly_introduced_builtin_type({Name, _}) when is_atom(Name) -> false. is_obsolete_builtin_type(TypePair) -> obsolete_builtin_type(TypePair) =/= no. -%% Obsolete in OTP 17.0. -obsolete_builtin_type({array, 0}) -> - {deprecated, {array, array, 1}, "OTP 18.0"}; -obsolete_builtin_type({dict, 0}) -> - {deprecated, {dict, dict, 2}, "OTP 18.0"}; -obsolete_builtin_type({digraph, 0}) -> - {deprecated, {digraph, graph}, "OTP 18.0"}; -obsolete_builtin_type({gb_set, 0}) -> - {deprecated, {gb_sets, set, 1}, "OTP 18.0"}; -obsolete_builtin_type({gb_tree, 0}) -> - {deprecated, {gb_trees, tree, 2}, "OTP 18.0"}; -obsolete_builtin_type({queue, 0}) -> - {deprecated, {queue, queue, 1}, "OTP 18.0"}; -obsolete_builtin_type({set, 0}) -> - {deprecated, {sets, set, 1}, "OTP 18.0"}; -obsolete_builtin_type({tid, 0}) -> - {deprecated, {ets, tid}, "OTP 18.0"}; +%% To keep Dialyzer silent... +obsolete_builtin_type({1, 255}) -> + {deprecated, {2, 255}, ""}; obsolete_builtin_type({Name, A}) when is_atom(Name), is_integer(A) -> no. %% spec_decl(Line, Fun, Types, State) -> State. @@ -2909,7 +2847,7 @@ spec_decl(Line, MFA0, TypeSpecs, St0 = #lint{specs = Specs, module = Mod}) -> end, St1 = St0#lint{specs = dict:store(MFA, Line, Specs)}, case dict:is_key(MFA, Specs) of - true -> add_error(Line, {redefine_spec, MFA}, St1); + true -> add_error(Line, {redefine_spec, MFA0}, St1); false -> check_specs(TypeSpecs, Arity, St1) end. @@ -2917,16 +2855,50 @@ spec_decl(Line, MFA0, TypeSpecs, St0 = #lint{specs = Specs, module = Mod}) -> callback_decl(Line, MFA0, TypeSpecs, St0 = #lint{callbacks = Callbacks, module = Mod}) -> - MFA = case MFA0 of - {F, Arity} -> {Mod, F, Arity}; - {_M, _F, Arity} -> MFA0 - end, - St1 = St0#lint{callbacks = dict:store(MFA, Line, Callbacks)}, - case dict:is_key(MFA, Callbacks) of - true -> add_error(Line, {redefine_callback, MFA}, St1); - false -> check_specs(TypeSpecs, Arity, St1) + case MFA0 of + {_M, _F, _A} -> add_error(Line, {bad_callback, MFA0}, St0); + {F, Arity} -> + MFA = {Mod, F, Arity}, + St1 = St0#lint{callbacks = dict:store(MFA, Line, Callbacks)}, + case dict:is_key(MFA, Callbacks) of + true -> add_error(Line, {redefine_callback, MFA0}, St1); + false -> check_specs(TypeSpecs, Arity, St1) + end + end. + +%% optional_callbacks(Line, FAs, State) -> State. + +optional_callbacks(Line, Term, St0) -> + try true = is_fa_list(Term), Term of + FAs -> + optional_cbs(Line, FAs, St0) + catch + _:_ -> + St0 % ignore others end. +optional_cbs(_Line, [], St) -> + St; +optional_cbs(Line, [{F,A}|FAs], St0) -> + #lint{optional_callbacks = OptionalCbs, module = Mod} = St0, + MFA = {Mod, F, A}, + St1 = St0#lint{optional_callbacks = dict:store(MFA, Line, OptionalCbs)}, + St2 = case dict:is_key(MFA, OptionalCbs) of + true -> + add_error(Line, {redefine_optional_callback, {F,A}}, St1); + false -> + St1 + end, + optional_cbs(Line, FAs, St2). + +is_fa_list([E|L]) -> is_fa(E) andalso is_fa_list(L); +is_fa_list([]) -> true; +is_fa_list(_) -> false. + +is_fa({FuncName, Arity}) + when is_atom(FuncName), is_integer(Arity), Arity >= 0 -> true; +is_fa(_) -> false. + check_specs([FunType|Left], Arity, St0) -> {FunType1, CTypes} = case FunType of @@ -2950,10 +2922,11 @@ check_specs([], _Arity, St) -> St. check_specs_without_function(#lint{module=Mod,defined=Funcs,specs=Specs}=St) -> - Fun = fun({M, F, A} = MFA, Line, AccSt) when M =:= Mod -> - case gb_sets:is_element({F, A}, Funcs) of + Fun = fun({M, F, A}, Line, AccSt) when M =:= Mod -> + FA = {F, A}, + case gb_sets:is_element(FA, Funcs) of true -> AccSt; - false -> add_error(Line, {spec_fun_undefined, MFA}, AccSt) + false -> add_error(Line, {spec_fun_undefined, FA}, AccSt) end; ({_M, _F, _A}, _Line, AccSt) -> AccSt end, @@ -3032,11 +3005,12 @@ check_local_opaque_types(St) -> dict:fold(FoldFun, St, Ts). %% icrt_clauses(Clauses, In, ImportVarTable, State) -> -%% {NewVts,State}. +%% {UpdVt,State}. icrt_clauses(Cs, In, Vt, St0) -> {Csvt,St1} = icrt_clauses(Cs, Vt, St0), - icrt_export(Csvt, Vt, In, St1). + UpdVt = icrt_export(Csvt, Vt, In), + {UpdVt,St1}. %% icrt_clauses(Clauses, ImportVarTable, State) -> %% {NewVts,State}. @@ -3046,26 +3020,73 @@ icrt_clauses(Cs, Vt, St) -> icrt_clause({clause,_Line,H,G,B}, Vt0, St0) -> {Hvt,Binvt,St1} = head(H, Vt0, St0), - Vt1 = vtupdate(Hvt, vtupdate(Binvt, Vt0)), - {Gvt,St2} = guard(G, Vt1, St1), + Vt1 = vtupdate(Hvt, Binvt), + {Gvt,St2} = guard(G, vtupdate(Vt1, Vt0), St1), Vt2 = vtupdate(Gvt, Vt1), - {Bvt,St3} = exprs(B, Vt2, St2), + {Bvt,St3} = exprs(B, vtupdate(Vt2, Vt0), St2), {vtupdate(Bvt, Vt2),St3}. -icrt_export(Csvt, Vt, In, St) -> - Vt1 = vtmerge(Csvt), - All = ordsets:subtract(vintersection(Csvt), vtnames(Vt)), - Some = ordsets:subtract(vtnames(Vt1), vtnames(Vt)), - Xvt = vtexport(All, In, []), - Evt = vtunsafe(ordsets:subtract(Some, All), In, Xvt), - Unused = vtmerge([unused_vars(Vt0, Vt, St) || Vt0 <- Csvt]), - %% Exported and unsafe variables may be unused: - Uvt = vtmerge(Evt, Unused), - %% Make exported and unsafe unused variables unused in subsequent code: - Vt2 = vtmerge(Uvt, vtsubtract(Vt1, Uvt)), - %% Forget about old variables which were not used: - Vt3 = vtmerge(vtnew(Vt2, Vt), vt_no_unused(vtold(Vt2, Vt))), - {Vt3,St}. +icrt_export(Vts, Vt, {Tag,Attrs}) -> + {_File,Loc} = loc(Attrs), + icrt_export(lists:merge(Vts), Vt, {Tag,Loc}, length(Vts), []). + +icrt_export([{V,{{export,_},_,_}}|Vs0], [{V,{{export,_}=S0,_,Ls}}|Vt], + In, I, Acc) -> + %% V was an exported variable and has been used in an expression in at least + %% one clause. Its state needs to be merged from all clauses to silence any + %% exported var warning already emitted. + {VVs,Vs} = lists:partition(fun ({K,_}) -> K =:= V end, Vs0), + S = foldl(fun ({_,{S1,_,_}}, AccS) -> merge_state(AccS, S1) end, S0, VVs), + icrt_export(Vs, Vt, In, I, [{V,{S,used,Ls}}|Acc]); +icrt_export([{V,_}|Vs0], [{V,{_,_,Ls}}|Vt], In, I, Acc) -> + %% V was either unsafe or bound and has now been reused. It may also have + %% been an export but as it was not matched by the previous clause, it means + %% it has been changed to 'bound' in at least one clause because it was used + %% in a pattern. + Vs = lists:dropwhile(fun ({K,_}) -> K =:= V end, Vs0), + icrt_export(Vs, Vt, In, I, [{V,{bound,used,Ls}}|Acc]); +icrt_export([{V1,_}|_]=Vs, [{V2,_}|Vt], In, I, Acc) when V1 > V2 -> + %% V2 was already in scope and has not been reused in any clause. + icrt_export(Vs, Vt, In, I, Acc); +icrt_export([{V,_}|_]=Vs0, Vt, In, I, Acc) -> + %% V is a new variable. + {VVs,Vs} = lists:partition(fun ({K,_}) -> K =:= V end, Vs0), + F = fun ({_,{S,U,Ls}}, {AccI,AccS0,AccLs0}) -> + AccS = case {S,AccS0} of + {{unsafe,_},{unsafe,_}} -> + %% V was found unsafe in a previous clause, mark + %% it as unsafe for the whole parent expression. + {unsafe,In}; + {{unsafe,_},_} -> + %% V was unsafe in a clause, keep that state and + %% generalize it to the whole expression if it + %% is found unsafe in another one. + S; + _ -> + %% V is either bound or exported, keep original + %% state. + AccS0 + end, + AccLs = case U of + used -> AccLs0; + unused -> merge_lines(AccLs0, Ls) + end, + {AccI + 1,AccS,AccLs} + end, + %% Initial state is exported from the current expression. + {Count,S1,Ls} = foldl(F, {0,{export,In},[]}, VVs), + S = case Count of + I -> + %% V was found in all clauses, keep computed state. + S1; + _ -> + %% V was not bound in some clauses, mark as unsafe. + {unsafe,In} + end, + U = case Ls of [] -> used; _ -> unused end, + icrt_export(Vs, Vt, In, I, [{V,{S,U,Ls}}|Acc]); +icrt_export([], _, _, _, Acc) -> + reverse(Acc). handle_comprehension(E, Qs, Vt0, St0) -> {Vt1, Uvt, St1} = lc_quals(Qs, Vt0, St0), @@ -3163,7 +3184,8 @@ fun_clauses(Cs, Vt, St) -> {Cvt,St1} = fun_clause(C, Vt, St0), {vtmerge(Cvt, Bvt0),St1} end, {[],St#lint{recdef_top = false}}, Cs), - {vt_no_unused(vtold(Bvt, Vt)),St2#lint{recdef_top = OldRecDef}}. + Uvt = vt_no_unsafe(vt_no_unused(vtold(Bvt, Vt))), + {Uvt,St2#lint{recdef_top = OldRecDef}}. fun_clause({clause,_Line,H,G,B}, Vt0, St0) -> {Hvt,Binvt,St1} = head(H, Vt0, [], St0), % No imported pattern variables @@ -3277,19 +3299,24 @@ pat_binsize_var(V, Line, Vt, Bvt, St) -> %% exported vars are probably safe, warn only if warn_export_vars is %% set. -expr_var(V, Line, Vt, St0) -> +expr_var(V, Line, Vt, St) -> case orddict:find(V, Vt) of {ok,{bound,_Usage,Ls}} -> - {[{V,{bound,used,Ls}}],St0}; + {[{V,{bound,used,Ls}}],St}; {ok,{{unsafe,In},_Usage,Ls}} -> {[{V,{bound,used,Ls}}], - add_error(Line, {unsafe_var,V,In}, St0)}; + add_error(Line, {unsafe_var,V,In}, St)}; {ok,{{export,From},_Usage,Ls}} -> - {[{V,{bound,used,Ls}}], - exported_var(Line, V, From, St0)}; + case is_warn_enabled(export_vars, St) of + true -> + {[{V,{bound,used,Ls}}], + add_warning(Line, {exported_var,V,From}, St)}; + false -> + {[{V,{{export,From},used,Ls}}],St} + end; error -> {[{V,{bound,used,[Line]}}], - add_error(Line, {unbound_var,V}, St0)} + add_error(Line, {unbound_var,V}, St)} end. exported_var(Line, V, From, St) -> @@ -3353,17 +3380,12 @@ vtupdate(Uvt, Vt0) -> {S, merge_used(U1, U2), merge_lines(L1, L2)} end, Uvt, Vt0). -%% vtexport([Variable], From, VarTable) -> VarTable. -%% vtunsafe([Variable], From, VarTable) -> VarTable. -%% Add the variables to VarTable either as exported from From or as unsafe. +%% vtunsafe(From, UpdVarTable, VarTable) -> UnsafeVarTable. +%% Return all new variables in UpdVarTable as unsafe. -vtexport(Vs, {InTag,FileLine}, Vt0) -> +vtunsafe({Tag,FileLine}, Uvt, Vt) -> {_File,Line} = loc(FileLine), - vtupdate([{V,{{export,{InTag,Line}},unused,[]}} || V <- Vs], Vt0). - -vtunsafe(Vs, {InTag,FileLine}, Vt0) -> - {_File,Line} = loc(FileLine), - vtupdate([{V,{{unsafe,{InTag,Line}},unused,[]}} || V <- Vs], Vt0). + [{V,{{unsafe,{Tag,Line}},U,Ls}} || {V,{_,U,Ls}} <- vtnew(Uvt, Vt)]. %% vtmerge(VarTable, VarTable) -> VarTable. %% Merge two variables tables generating a new vartable. Give priority to @@ -3416,8 +3438,6 @@ vtsubtract(New, Old) -> vtold(New, Old) -> orddict:filter(fun (V, _How) -> orddict:is_key(V, Old) end, New). -vtnames(Vt) -> [ V || {V,_How} <- Vt ]. - vt_no_unsafe(Vt) -> [V || {_,{S,_U,_L}}=V <- Vt, case S of {unsafe,_} -> false; @@ -3426,29 +3446,6 @@ vt_no_unsafe(Vt) -> [V || {_,{S,_U,_L}}=V <- Vt, vt_no_unused(Vt) -> [V || {_,{_,U,_L}}=V <- Vt, U =/= unused]. -%% vunion(VarTable1, VarTable2) -> [VarName]. -%% vunion([VarTable]) -> [VarName]. -%% vintersection(VarTable1, VarTable2) -> [VarName]. -%% vintersection([VarTable]) -> [VarName]. -%% Union/intersection of names of vars in VarTable. - --ifdef(NOTUSED). -vunion(Vs1, Vs2) -> ordsets:union(vtnames(Vs1), vtnames(Vs2)). - -vunion(Vss) -> foldl(fun (Vs, Uvs) -> - ordsets:union(vtnames(Vs), Uvs) - end, [], Vss). - -vintersection(Vs1, Vs2) -> ordsets:intersection(vtnames(Vs1), vtnames(Vs2)). --endif. - -vintersection([Vs]) -> - vtnames(Vs); %Boundary conditions!!! -vintersection([Vs|Vss]) -> - ordsets:intersection(vtnames(Vs), vintersection(Vss)); -vintersection([]) -> - []. - %% copy_expr(Expr, Line) -> Expr. %% Make a copy of Expr converting all line numbers to Line. diff --git a/lib/stdlib/src/erl_parse.yrl b/lib/stdlib/src/erl_parse.yrl index 1d4a2a1fef..3502a50eaa 100644 --- a/lib/stdlib/src/erl_parse.yrl +++ b/lib/stdlib/src/erl_parse.yrl @@ -42,7 +42,6 @@ function_call argument_list exprs guard atomic strings prefix_op mult_op add_op list_op comp_op -rule rule_clauses rule_clause rule_body binary bin_elements bin_element bit_expr opt_bit_size_expr bit_size_expr opt_bit_type_list bit_type_list bit_type top_type top_type_100 top_types type typed_expr typed_attr_val @@ -54,7 +53,7 @@ bin_base_type bin_unit_type type_200 type_300 type_400 type_500. Terminals char integer float atom string var -'(' ')' ',' '->' ':-' '{' '}' '[' ']' '|' '||' '<-' ';' ':' '#' '.' +'(' ')' ',' '->' '{' '}' '[' ']' '|' '||' '<-' ';' ':' '#' '.' 'after' 'begin' 'case' 'try' 'catch' 'end' 'fun' 'if' 'of' 'receive' 'when' 'andalso' 'orelse' 'bnot' 'not' @@ -73,7 +72,6 @@ Rootsymbol form. form -> attribute dot : '$1'. form -> function dot : '$1'. -form -> rule dot : '$1'. attribute -> '-' atom attr_val : build_attribute('$2', '$3'). attribute -> '-' atom typed_attr_val : build_typed_attribute('$2','$3'). @@ -146,8 +144,7 @@ type -> '(' top_type ')' : {paren_type, ?line('$2'), ['$2']}. type -> var : '$1'. type -> atom : '$1'. type -> atom '(' ')' : build_gen_type('$1'). -type -> atom '(' top_types ')' : {type, ?line('$1'), - normalise('$1'), '$3'}. +type -> atom '(' top_types ')' : build_type('$1', '$3'). type -> atom ':' atom '(' ')' : {remote_type, ?line('$1'), ['$1', '$3', []]}. type -> atom ':' atom '(' top_types ')' : {remote_type, ?line('$1'), @@ -181,7 +178,7 @@ fun_type -> '(' top_types ')' '->' top_type map_pair_types -> map_pair_type : ['$1']. map_pair_types -> map_pair_type ',' map_pair_types : ['$1'|'$3']. -map_pair_type -> top_type '=>' top_type : {type, ?line('$2'), map_field_assoc,'$1','$3'}. +map_pair_type -> top_type '=>' top_type : {type, ?line('$2'), map_field_assoc,['$1','$3']}. field_types -> field_type : ['$1']. field_types -> field_type ',' field_types : ['$1'|'$3']. @@ -521,17 +518,6 @@ comp_op -> '>' : '$1'. comp_op -> '=:=' : '$1'. comp_op -> '=/=' : '$1'. -rule -> rule_clauses : build_rule('$1'). - -rule_clauses -> rule_clause : ['$1']. -rule_clauses -> rule_clause ';' rule_clauses : ['$1'|'$3']. - -rule_clause -> atom clause_args clause_guard rule_body : - {clause,?line('$1'),element(3, '$1'),'$2','$3','$4'}. - -rule_body -> ':-' lc_exprs: '$2'. - - Erlang code. -export([parse_form/1,parse_exprs/1,parse_term/1]). @@ -665,6 +651,8 @@ find_arity_from_specs([Spec|_]) -> {type, _, 'fun', [{type, _, product, Args},_]} = Fun, length(Args). +build_def({var, L, '_'}, _Types) -> + ret_err(L, "bad type variable"); build_def(LHS, Types) -> IsSubType = {atom, ?line(LHS), is_subtype}, {type, ?line(LHS), constraint, [IsSubType, [LHS, Types]]}. @@ -684,7 +672,8 @@ build_gen_type({atom, La, tuple}) -> build_gen_type({atom, La, map}) -> {type, La, map, any}; build_gen_type({atom, La, Name}) -> - {type, La, Name, []}. + Tag = type_tag(Name, 0), + {Tag, La, Name, []}. build_bin_type([{var, _, '_'}|Left], Int) -> build_bin_type(Left, Int); @@ -693,6 +682,16 @@ build_bin_type([], Int) -> build_bin_type([{var, La, _}|_], _) -> ret_err(La, "Bad binary type"). +build_type({atom, L, Name}, Types) -> + Tag = type_tag(Name, length(Types)), + {Tag, L, Name, Types}. + +type_tag(TypeName, NumberOfTypeVariables) -> + case erl_internal:is_type(TypeName, NumberOfTypeVariables) of + true -> type; + false -> user_type + end. + %% build_attribute(AttrName, AttrValue) -> %% {attribute,Line,module,Module} %% {attribute,Line,export,Exports} @@ -834,13 +833,6 @@ build_function(Cs) -> Arity = length(element(4, hd(Cs))), {function,?line(hd(Cs)),Name,Arity,check_clauses(Cs, Name, Arity)}. -%% build_rule([Clause]) -> {rule,Line,Name,Arity,[Clause]'} - -build_rule(Cs) -> - Name = element(3, hd(Cs)), - Arity = length(element(4, hd(Cs))), - {rule,?line(hd(Cs)),Name,Arity,check_clauses(Cs, Name, Arity)}. - %% build_fun(Line, [Clause]) -> {'fun',Line,{clauses,[Clause]}}. build_fun(Line, Cs) -> diff --git a/lib/stdlib/src/erl_pp.erl b/lib/stdlib/src/erl_pp.erl index 1fd6d2a8df..469ce544c7 100644 --- a/lib/stdlib/src/erl_pp.erl +++ b/lib/stdlib/src/erl_pp.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2013. All Rights Reserved. +%% Copyright Ericsson AB 1996-2014. 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 @@ -22,7 +22,7 @@ %%% the parser. It does not always produce pretty code. -export([form/1,form/2, - attribute/1,attribute/2,function/1,function/2,rule/1,rule/2, + attribute/1,attribute/2,function/1,function/2, guard/1,guard/2,exprs/1,exprs/2,exprs/3,expr/1,expr/2,expr/3,expr/4]). -import(lists, [append/1,foldr/3,mapfoldl/3,reverse/1,reverse/2]). @@ -91,12 +91,6 @@ function(F) -> function(F, Options) -> frmt(lfunction(F, options(Options)), state(Options)). -rule(R) -> - rule(R, none). - -rule(R, Options) -> - frmt(lrule(R, options(Options)), state(Options)). - -spec(guard(Guard) -> io_lib:chars() when Guard :: [erl_parse:abstract_expr()]). @@ -199,8 +193,6 @@ lform({attribute,Line,Name,Arg}, Opts, State) -> lattribute({attribute,Line,Name,Arg}, Opts, State); lform({function,Line,Name,Arity,Clauses}, Opts, _State) -> lfunction({function,Line,Name,Arity,Clauses}, Opts); -lform({rule,Line,Name,Arity,Clauses}, Opts, _State) -> - lrule({rule,Line,Name,Arity,Clauses}, Opts); %% These are specials to make it easier for the compiler. lform({error,E}, _Opts, _State) -> leaf(format("~p\n", [{error,E}])); @@ -232,13 +224,21 @@ lattribute(import, Name, _Opts, _State) when is_list(Name) -> attr("import", [{var,0,pname(Name)}]); lattribute(import, {From,Falist}, _Opts, _State) -> attr("import",[{var,0,pname(From)},falist(Falist)]); +lattribute(optional_callbacks, Falist, Opts, _State) -> + ArgL = try falist(Falist) + catch _:_ -> abstract(Falist, Opts) + end, + call({var,0,"-optional_callbacks"}, [ArgL], 0, options(none)); lattribute(file, {Name,Line}, _Opts, State) -> attr("file", [{var,0,(State#pp.string_fun)(Name)},{integer,0,Line}]); lattribute(record, {Name,Is}, Opts, _State) -> Nl = leaf(format("-record(~w,", [Name])), [{first,Nl,record_fields(Is, Opts)},$)]; -lattribute(Name, Arg, #options{encoding = Encoding}, _State) -> - attr(write(Name), [erl_parse:abstract(Arg, [{encoding,Encoding}])]). +lattribute(Name, Arg, Options, _State) -> + attr(write(Name), [abstract(Arg, Options)]). + +abstract(Arg, #options{encoding = Encoding}) -> + erl_parse:abstract(Arg, [{encoding,Encoding}]). typeattr(Tag, {TypeName,Type,Args}, _Opts) -> {first,leaf("-"++atom_to_list(Tag)++" "), @@ -277,6 +277,9 @@ ltype({type,_,'fun',[{type,_,any},_]}=FunType) -> ltype({type,_Line,'fun',[{type,_,product,_},_]}=FunType) -> [fun_type(['fun',$(], FunType),$)]; ltype({type,Line,T,Ts}) -> + %% Compatibility. Before 18.0. + simple_type({atom,Line,T}, Ts); +ltype({user_type,Line,T,Ts}) -> simple_type({atom,Line,T}, Ts); ltype({remote_type,Line,[M,F,Ts]}) -> simple_type({remote,Line,M,F}, Ts); @@ -299,7 +302,7 @@ map_type(Fs) -> map_pair_types(Fs) -> tuple_type(Fs, fun map_pair_type/1). -map_pair_type({type,_Line,map_field_assoc,Ktype,Vtype}) -> +map_pair_type({type,_Line,map_field_assoc,[Ktype,Vtype]}) -> map_assoc_typed(ltype(Ktype), Vtype). map_assoc_typed(B, {type,_,union,Ts}) -> @@ -407,19 +410,6 @@ func_clause(Name, {clause,Line,Head,Guard,Body}, Opts) -> Bl = body(Body, Opts), {step,Gl,Bl}. -lrule({rule,_Line,Name,_Arity,Cs}, Opts) -> - Cll = nl_clauses(fun (C, H) -> rule_clause(Name, C, H) end, $;, Opts, Cs), - [Cll,leaf(".\n")]. - -rule_clause(Name, {clause,Line,Head,Guard,Body}, Opts) -> - Hl = call({atom,Line,Name}, Head, 0, Opts), - Gl = guard_when(Hl, Guard, Opts, leaf(" :-")), - Bl = rule_body(Body, Opts), - {step,Gl,Bl}. - -rule_body(Es, Opts) -> - lc_quals(Es, Opts). - guard_when(Before, Guard, Opts) -> guard_when(Before, Guard, Opts, ' ->'). diff --git a/lib/stdlib/src/erl_scan.erl b/lib/stdlib/src/erl_scan.erl index 6fd6bb888b..4960a86760 100644 --- a/lib/stdlib/src/erl_scan.erl +++ b/lib/stdlib/src/erl_scan.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2013. All Rights Reserved. +%% Copyright Ericsson AB 1996-2014. 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 @@ -599,9 +599,6 @@ scan1("|"=Cs, _St, Line, Col, Toks) -> %% := scan1(":="++Cs, St, Line, Col, Toks) -> tok2(Cs, St, Line, Col, Toks, ":=", ':=', 2); -%% :- -scan1(":-"++Cs, St, Line, Col, Toks) -> - tok2(Cs, St, Line, Col, Toks, ":-", ':-', 2); %% :: for typed records scan1("::"++Cs, St, Line, Col, Toks) -> tok2(Cs, St, Line, Col, Toks, "::", '::', 2); diff --git a/lib/stdlib/src/filename.erl b/lib/stdlib/src/filename.erl index e6bde5673c..632af17e2a 100644 --- a/lib/stdlib/src/filename.erl +++ b/lib/stdlib/src/filename.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1997-2013. All Rights Reserved. +%% Copyright Ericsson AB 1997-2014. 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 @@ -444,6 +444,8 @@ join1([], RelativeName, [$:|Rest], win32) -> join1(RelativeName, [], [$:|Rest], win32); join1([], RelativeName, [$/|Result], OsType) -> join1(RelativeName, [], [$/|Result], OsType); +join1([], RelativeName, [$., $/|Result], OsType) -> + join1(RelativeName, [], [$/|Result], OsType); join1([], RelativeName, Result, OsType) -> join1(RelativeName, [], [$/|Result], OsType); join1([[_|_]=List|Rest], RelativeName, Result, OsType) -> @@ -470,6 +472,8 @@ join1b(<<>>, RelativeName, [$:|Rest], win32) -> join1b(RelativeName, <<>>, [$:|Rest], win32); join1b(<<>>, RelativeName, [$/|Result], OsType) -> join1b(RelativeName, <<>>, [$/|Result], OsType); +join1b(<<>>, RelativeName, [$., $/|Result], OsType) -> + join1b(RelativeName, <<>>, [$/|Result], OsType); join1b(<<>>, RelativeName, Result, OsType) -> join1b(RelativeName, <<>>, [$/|Result], OsType); join1b(<<Char,Rest/binary>>, RelativeName, Result, OsType) when is_integer(Char) -> diff --git a/lib/stdlib/src/gen.erl b/lib/stdlib/src/gen.erl index 63116fa16e..6d7ca3d75c 100644 --- a/lib/stdlib/src/gen.erl +++ b/lib/stdlib/src/gen.erl @@ -26,7 +26,7 @@ %%% The standard behaviour should export init_it/6. %%%----------------------------------------------------------------- -export([start/5, start/6, debug_options/1, - call/3, call/4, reply/2]). + call/3, call/4, reply/2, stop/1, stop/3]). -export([init_it/6, init_it/7]). @@ -145,56 +145,10 @@ init_it2(GenMod, Starter, Parent, Name, Mod, Args, Options) -> call(Process, Label, Request) -> call(Process, Label, Request, ?default_timeout). -%% Local or remote by pid -call(Pid, Label, Request, Timeout) - when is_pid(Pid), Timeout =:= infinity; - is_pid(Pid), is_integer(Timeout), Timeout >= 0 -> - do_call(Pid, Label, Request, Timeout); -%% Local by name -call(Name, Label, Request, Timeout) - when is_atom(Name), Timeout =:= infinity; - is_atom(Name), is_integer(Timeout), Timeout >= 0 -> - case whereis(Name) of - Pid when is_pid(Pid) -> - do_call(Pid, Label, Request, Timeout); - undefined -> - exit(noproc) - end; -%% Global by name call(Process, Label, Request, Timeout) - when ((tuple_size(Process) == 2 andalso element(1, Process) == global) - orelse - (tuple_size(Process) == 3 andalso element(1, Process) == via)) - andalso - (Timeout =:= infinity orelse (is_integer(Timeout) andalso Timeout >= 0)) -> - case where(Process) of - Pid when is_pid(Pid) -> - Node = node(Pid), - try do_call(Pid, Label, Request, Timeout) - catch - exit:{nodedown, Node} -> - %% A nodedown not yet detected by global, - %% pretend that it was. - exit(noproc) - end; - undefined -> - exit(noproc) - end; -%% Local by name in disguise -call({Name, Node}, Label, Request, Timeout) - when Node =:= node(), Timeout =:= infinity; - Node =:= node(), is_integer(Timeout), Timeout >= 0 -> - call(Name, Label, Request, Timeout); -%% Remote by name -call({_Name, Node}=Process, Label, Request, Timeout) - when is_atom(Node), Timeout =:= infinity; - is_atom(Node), is_integer(Timeout), Timeout >= 0 -> - if - node() =:= nonode@nohost -> - exit({nodedown, Node}); - true -> - do_call(Process, Label, Request, Timeout) - end. + when Timeout =:= infinity; is_integer(Timeout), Timeout >= 0 -> + Fun = fun(Pid) -> do_call(Pid, Label, Request, Timeout) end, + do_for_proc(Process, Fun). do_call(Process, Label, Request, Timeout) -> try erlang:monitor(process, Process) of @@ -276,6 +230,65 @@ reply({To, Tag}, Reply) -> Msg = {Tag, Reply}, try To ! Msg catch _:_ -> Msg end. +%%----------------------------------------------------------------- +%% Syncronously stop a generic process +%%----------------------------------------------------------------- +stop(Process) -> + stop(Process, normal, infinity). + +stop(Process, Reason, Timeout) + when Timeout =:= infinity; is_integer(Timeout), Timeout >= 0 -> + Fun = fun(Pid) -> proc_lib:stop(Pid, Reason, Timeout) end, + do_for_proc(Process, Fun). + +%%----------------------------------------------------------------- +%% Map different specifications of a process to either Pid or +%% {Name,Node}. Execute the given Fun with the process as only +%% argument. +%% ----------------------------------------------------------------- + +%% Local or remote by pid +do_for_proc(Pid, Fun) when is_pid(Pid) -> + Fun(Pid); +%% Local by name +do_for_proc(Name, Fun) when is_atom(Name) -> + case whereis(Name) of + Pid when is_pid(Pid) -> + Fun(Pid); + undefined -> + exit(noproc) + end; +%% Global by name +do_for_proc(Process, Fun) + when ((tuple_size(Process) == 2 andalso element(1, Process) == global) + orelse + (tuple_size(Process) == 3 andalso element(1, Process) == via)) -> + case where(Process) of + Pid when is_pid(Pid) -> + Node = node(Pid), + try Fun(Pid) + catch + exit:{nodedown, Node} -> + %% A nodedown not yet detected by global, + %% pretend that it was. + exit(noproc) + end; + undefined -> + exit(noproc) + end; +%% Local by name in disguise +do_for_proc({Name, Node}, Fun) when Node =:= node() -> + do_for_proc(Name, Fun); +%% Remote by name +do_for_proc({_Name, Node} = Process, Fun) when is_atom(Node) -> + if + node() =:= nonode@nohost -> + exit({nodedown, Node}); + true -> + Fun(Process) + end. + + %%%----------------------------------------------------------------- %%% Misc. functions. %%%----------------------------------------------------------------- diff --git a/lib/stdlib/src/gen_event.erl b/lib/stdlib/src/gen_event.erl index 469acdc37c..5a1fff3a9c 100644 --- a/lib/stdlib/src/gen_event.erl +++ b/lib/stdlib/src/gen_event.erl @@ -31,8 +31,8 @@ %%% Modified by Martin - uses proc_lib, sys and gen! --export([start/0, start/1, start_link/0, start_link/1, stop/1, notify/2, - sync_notify/2, +-export([start/0, start/1, start_link/0, start_link/1, stop/1, stop/3, + notify/2, sync_notify/2, add_handler/3, add_sup_handler/3, delete_handler/3, swap_handler/3, swap_sup_handler/3, which_handlers/1, call/3, call/4, wake_hib/4]). @@ -99,6 +99,14 @@ -callback code_change(OldVsn :: (term() | {down, term()}), State :: term(), Extra :: term()) -> {ok, NewState :: term()}. +-callback format_status(Opt, StatusData) -> Status when + Opt :: 'normal' | 'terminate', + StatusData :: [PDict | State], + PDict :: [{Key :: term(), Value :: term()}], + State :: term(), + Status :: term(). + +-optional_callbacks([format_status/2]). %%--------------------------------------------------------------------------- @@ -183,7 +191,11 @@ swap_sup_handler(M, {H1, A1}, {H2, A2}) -> which_handlers(M) -> rpc(M, which_handlers). -spec stop(emgr_ref()) -> 'ok'. -stop(M) -> rpc(M, stop). +stop(M) -> + gen:stop(M). + +stop(M, Reason, Timeout) -> + gen:stop(M, Reason, Timeout). rpc(M, Cmd) -> {ok, Reply} = gen:call(M, self(), Cmd, infinity), diff --git a/lib/stdlib/src/gen_fsm.erl b/lib/stdlib/src/gen_fsm.erl index 5afe3e8b09..89825a6a57 100644 --- a/lib/stdlib/src/gen_fsm.erl +++ b/lib/stdlib/src/gen_fsm.erl @@ -106,6 +106,7 @@ -export([start/3, start/4, start_link/3, start_link/4, + stop/1, stop/3, send_event/2, sync_send_event/2, sync_send_event/3, send_all_state_event/2, sync_send_all_state_event/2, sync_send_all_state_event/3, @@ -160,6 +161,14 @@ -callback code_change(OldVsn :: term() | {down, term()}, StateName :: atom(), StateData :: term(), Extra :: term()) -> {ok, NextStateName :: atom(), NewStateData :: term()}. +-callback format_status(Opt, StatusData) -> Status when + Opt :: 'normal' | 'terminate', + StatusData :: [PDict | State], + PDict :: [{Key :: term(), Value :: term()}], + State :: term(), + Status :: term(). + +-optional_callbacks([format_status/2]). %%% --------------------------------------------------- %%% Starts a generic state machine. @@ -189,6 +198,11 @@ start_link(Mod, Args, Options) -> start_link(Name, Mod, Args, Options) -> gen:start(?MODULE, link, Name, Mod, Args, Options). +stop(Name) -> + gen:stop(Name). + +stop(Name, Reason, Timeout) -> + gen:stop(Name, Reason, Timeout). send_event({global, Name}, Event) -> catch global:send(Name, {'$gen_event', Event}), diff --git a/lib/stdlib/src/gen_server.erl b/lib/stdlib/src/gen_server.erl index 528dd23e1c..139bf35d27 100644 --- a/lib/stdlib/src/gen_server.erl +++ b/lib/stdlib/src/gen_server.erl @@ -88,6 +88,7 @@ %% API -export([start/3, start/4, start_link/3, start_link/4, + stop/1, stop/3, call/2, call/3, cast/2, reply/2, abcast/2, abcast/3, @@ -137,6 +138,15 @@ -callback code_change(OldVsn :: (term() | {down, term()}), State :: term(), Extra :: term()) -> {ok, NewState :: term()} | {error, Reason :: term()}. +-callback format_status(Opt, StatusData) -> Status when + Opt :: 'normal' | 'terminate', + StatusData :: [PDict | State], + PDict :: [{Key :: term(), Value :: term()}], + State :: term(), + Status :: term(). + +-optional_callbacks([format_status/2]). + %%% ----------------------------------------------------------------- %%% Starts a generic server. @@ -168,6 +178,17 @@ start_link(Name, Mod, Args, Options) -> %% ----------------------------------------------------------------- +%% Stop a generic server and wait for it to terminate. +%% If the server is located at another node, that node will +%% be monitored. +%% ----------------------------------------------------------------- +stop(Name) -> + gen:stop(Name). + +stop(Name, Reason, Timeout) -> + gen:stop(Name, Reason, Timeout). + +%% ----------------------------------------------------------------- %% Make a call to a generic server. %% If the server is located at another node, that node will %% be monitored. @@ -846,22 +867,10 @@ opt(_, []) -> debug_options(Name, Opts) -> case opt(debug, Opts) of - {ok, Options} -> dbg_options(Name, Options); - _ -> dbg_options(Name, []) + {ok, Options} -> dbg_opts(Name, Options); + _ -> [] end. -dbg_options(Name, []) -> - Opts = - case init:get_argument(generic_debug) of - error -> - []; - _ -> - [log, statistics] - end, - dbg_opts(Name, Opts); -dbg_options(Name, Opts) -> - dbg_opts(Name, Opts). - dbg_opts(Name, Opts) -> case catch sys:debug_options(Opts) of {'EXIT',_} -> diff --git a/lib/stdlib/src/ms_transform.erl b/lib/stdlib/src/ms_transform.erl index 97564e2e44..7b6f4e5b50 100644 --- a/lib/stdlib/src/ms_transform.erl +++ b/lib/stdlib/src/ms_transform.erl @@ -1079,6 +1079,12 @@ normalise({cons,_,Head,Tail}) -> [normalise(Head)|normalise(Tail)]; normalise({tuple,_,Args}) -> list_to_tuple(normalise_list(Args)); +normalise({map,_,Pairs0}) -> + Pairs1 = lists:map(fun ({map_field_exact,_,K,V}) -> + {normalise(K),normalise(V)} + end, + Pairs0), + maps:from_list(Pairs1); %% Special case for unary +/-. normalise({op,_,'+',{char,_,I}}) -> I; normalise({op,_,'+',{integer,_,I}}) -> I; diff --git a/lib/stdlib/src/otp_internal.erl b/lib/stdlib/src/otp_internal.erl index 6c25beabe9..0ace87ef5c 100644 --- a/lib/stdlib/src/otp_internal.erl +++ b/lib/stdlib/src/otp_internal.erl @@ -577,8 +577,6 @@ obsolete_1(asn1rt, utf8_binary_to_list, 1) -> {deprecated,{unicode,characters_to_list,1}}; obsolete_1(asn1rt, utf8_list_to_binary, 1) -> {deprecated,{unicode,characters_to_binary,1}}; -obsolete_1(pg, _, _) -> - {deprecated,"deprecated; will be removed in OTP 18"}; obsolete_1(_, _, _) -> no. diff --git a/lib/stdlib/src/pg.erl b/lib/stdlib/src/pg.erl deleted file mode 100644 index a41fd329c2..0000000000 --- a/lib/stdlib/src/pg.erl +++ /dev/null @@ -1,187 +0,0 @@ -%% -%% %CopyrightBegin% -%% -%% Copyright Ericsson AB 1996-2014. All Rights Reserved. -%% -%% The contents of this file are subject to the Erlang Public License, -%% Version 1.1, (the "License"); you may not use this file except in -%% compliance with the License. You should have received a copy of the -%% Erlang Public License along with this software. If not, it can be -%% retrieved online at http://www.erlang.org/. -%% -%% Software distributed under the License is distributed on an "AS IS" -%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See -%% the License for the specific language governing rights and limitations -%% under the License. -%% -%% %CopyrightEnd% -%% --module(pg). --deprecated(module). - -%% pg provides a process group facility. Messages -%% can be multicasted to all members in the group - --export([create/1, - create/2, - standby/2, - join/2, - send/2, - esend/2, - members/1, - name_to_pid/1, - master/1]). - - -%% Create a brand new empty process group with the master residing -%% at the local node - --spec create(PgName) -> 'ok' | {'error', Reason} when - PgName :: term(), - Reason :: 'already_created' | term(). - -create(PgName) -> - catch begin check(PgName), - Pid = spawn(pg,master,[PgName]), - global:register_name(PgName,Pid), - ok end. - -%% Create a brand new empty process group with the master -%% residing at Node - --spec create(PgName, Node) -> 'ok' | {'error', Reason} when - PgName :: term(), - Node :: node(), - Reason :: 'already_created' | term(). - -create(PgName, Node) -> - catch begin check(PgName), - Pid = spawn(Node,pg,master,[PgName]), - global:register_name(PgName,Pid), - ok end. - -%% Have a process on Node that will act as a standby for the process -%% group manager. So if the node where the manager runs fails, the -%% process group will continue to function. - --spec standby(term(), node()) -> 'ok'. - -standby(_PgName, _Node) -> - ok. - -%% Tell process group PgName that Pid is a new member of the group -%% synchronously return a list of all old members in the group - --spec join(PgName, Pid) -> Members when - PgName :: term(), - Pid :: pid(), - Members :: [pid()]. - -join(PgName, Pid) when is_atom(PgName) -> - global:send(PgName, {join,self(),Pid}), - receive - {_P,{members,Members}} -> - Members - end. - -%% Multi cast Mess to all members in the group - --spec send(PgName, Msg) -> 'ok' when - PgName :: term(), - Msg :: term(). - -send(PgName, Mess) when is_atom(PgName) -> - global:send(PgName, {send, self(), Mess}), - ok; -send(Pg, Mess) when is_pid(Pg) -> - Pg ! {send,self(),Mess}, - ok. - -%% multi cast a message to all members in the group but ourselves -%% If we are a member - --spec esend(PgName, Msg) -> 'ok' when - PgName :: term(), - Msg :: term(). - -esend(PgName, Mess) when is_atom(PgName) -> - global:send(PgName, {esend,self(),Mess}), - ok; -esend(Pg, Mess) when is_pid(Pg) -> - Pg ! {esend,self(),Mess}, - ok. - -%% Return the members of the group - --spec members(PgName) -> Members when - PgName :: term(), - Members :: [pid()]. - -members(PgName) when is_atom(PgName) -> - global:send(PgName, {self() ,members}), - receive - {_P,{members,Members}} -> - Members - end; -members(Pg) when is_pid(Pg) -> - Pg ! {self,members}, - receive - {_P,{members,Members}} -> - Members - end. - --spec name_to_pid(atom()) -> pid() | 'undefined'. - -name_to_pid(PgName) when is_atom(PgName) -> - global:whereis_name(PgName). - --spec master(term()) -> no_return(). - -master(PgName) -> - process_flag(trap_exit, true), - master_loop(PgName, []). - -master_loop(PgName,Members) -> - receive - {send,From,Message} -> - send_all(Members,{pg_message,From,PgName,Message}), - master_loop(PgName,Members); - {esend,From,Message} -> - send_all(lists:delete(From,Members), - {pg_message,From,PgName,Message}), - master_loop(PgName,Members); - {join,From,Pid} -> - link(Pid), - send_all(Members,{new_member,PgName,Pid}), - From ! {self(),{members,Members}}, - master_loop(PgName,[Pid|Members]); - {From,members} -> - From ! {self(),{members,Members}}, - master_loop(PgName,Members); - {'EXIT',From,_} -> - L = - case lists:member(From,Members) of - true -> - NewMembers = lists:delete(From,Members), - send_all(NewMembers, {crashed_member,PgName,From}), - NewMembers; - false -> - Members - end, - master_loop(PgName,L) - end. - -send_all([], _) -> ok; -send_all([P|Ps], M) -> - P ! M, - send_all(Ps, M). - -%% Check if the process group already exists - -check(PgName) -> - case global:whereis_name(PgName) of - Pid when is_pid(Pid) -> - throw({error,already_created}); - undefined -> - ok - end. diff --git a/lib/stdlib/src/proc_lib.erl b/lib/stdlib/src/proc_lib.erl index bf2a4e7ac5..8792ff44d3 100644 --- a/lib/stdlib/src/proc_lib.erl +++ b/lib/stdlib/src/proc_lib.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2013. All Rights Reserved. +%% Copyright Ericsson AB 1996-2014. 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 @@ -30,7 +30,8 @@ hibernate/3, init_ack/1, init_ack/2, init_p/3,init_p/5,format/1,format/2,initial_call/1, - translate_initial_call/1]). + translate_initial_call/1, + stop/1, stop/3]). %% Internal exports. -export([wake_up/3]). @@ -748,3 +749,50 @@ format_tag(Tag, Data) -> modifier(latin1) -> ""; modifier(_) -> "t". + + +%%% ----------------------------------------------------------- +%%% Stop a process and wait for it to terminate +%%% ----------------------------------------------------------- +-spec stop(Process) -> 'ok' when + Process :: pid() | RegName | {RegName,node()}, + RegName :: atom(). +stop(Process) -> + stop(Process, normal, infinity). + +-spec stop(Process, Reason, Timeout) -> 'ok' when + Process :: pid() | RegName | {RegName,node()}, + RegName :: atom(), + Reason :: term(), + Timeout :: timeout(). +stop(Process, Reason, Timeout) -> + {Pid, Mref} = erlang:spawn_monitor(do_stop(Process, Reason)), + receive + {'DOWN', Mref, _, _, Reason} -> + ok; + {'DOWN', Mref, _, _, {noproc,{sys,terminate,_}}} -> + exit(noproc); + {'DOWN', Mref, _, _, CrashReason} -> + exit(CrashReason) + after Timeout -> + exit(Pid, kill), + receive + {'DOWN', Mref, _, _, _} -> + exit(timeout) + end + end. + +-spec do_stop(Process, Reason) -> Fun when + Process :: pid() | RegName | {RegName,node()}, + RegName :: atom(), + Reason :: term(), + Fun :: fun(() -> no_return()). +do_stop(Process, Reason) -> + fun() -> + Mref = erlang:monitor(process, Process), + ok = sys:terminate(Process, Reason, infinity), + receive + {'DOWN', Mref, _, _, ExitReason} -> + exit(ExitReason) + end + end. diff --git a/lib/stdlib/src/stdlib.app.src b/lib/stdlib/src/stdlib.app.src index aa9899da3b..f134c75869 100644 --- a/lib/stdlib/src/stdlib.app.src +++ b/lib/stdlib/src/stdlib.app.src @@ -77,7 +77,6 @@ orddict, ordsets, otp_internal, - pg, pool, proc_lib, proplists, diff --git a/lib/stdlib/src/stdlib.appup.src b/lib/stdlib/src/stdlib.appup.src index 7802ea884f..5900fd3ff3 100644 --- a/lib/stdlib/src/stdlib.appup.src +++ b/lib/stdlib/src/stdlib.appup.src @@ -18,10 +18,8 @@ {"%VSN%", %% Up from - max one major revision back [{<<"2\\.[1-2](\\.[0-9]+)*">>,[restart_new_emulator]}, %% 17.1-17.3 - {<<"2\\.0(\\.[0-9]+)*">>,[restart_new_emulator]}, %% 17.0 - {<<"1\\.19(\\.[0-9]+)*">>,[restart_new_emulator]}],%% R16 + {<<"2\\.0(\\.[0-9]+)*">>,[restart_new_emulator]}], %% 17.0 %% Down to - max one major revision back [{<<"2\\.[1-2](\\.[0-9]+)*">>,[restart_new_emulator]}, %% 17.1-17.3 - {<<"2\\.0(\\.[0-9]+)*">>,[restart_new_emulator]}, %% 17.0 - {<<"1\\.19(\\.[0-9]+)*">>,[restart_new_emulator]}] %% R16 + {<<"2\\.0(\\.[0-9]+)*">>,[restart_new_emulator]}] %% 17.0 }. diff --git a/lib/stdlib/src/supervisor.erl b/lib/stdlib/src/supervisor.erl index ede2742875..658c00dc77 100644 --- a/lib/stdlib/src/supervisor.erl +++ b/lib/stdlib/src/supervisor.erl @@ -25,7 +25,7 @@ start_child/2, restart_child/2, delete_child/2, terminate_child/2, which_children/1, count_children/1, - check_childspecs/1]). + check_childspecs/1, get_childspec/2]). %% Internal exports -export([init/1, handle_call/3, handle_cast/2, handle_info/2, @@ -34,7 +34,7 @@ %%-------------------------------------------------------------------------- --export_type([child_spec/0, startchild_ret/0, strategy/0]). +-export_type([sup_flags/0, child_spec/0, startchild_ret/0, strategy/0]). %%-------------------------------------------------------------------------- @@ -53,7 +53,13 @@ | {'global', Name :: atom()} | {'via', Module :: module(), Name :: any()} | pid(). --type child_spec() :: {Id :: child_id(), +-type child_spec() :: #{id => child_id(), % mandatory + start => mfargs(), % mandatory + restart => restart(), % optional + shutdown => shutdown(), % optional + type => worker(), % optional + modules => modules()} % optional + | {Id :: child_id(), StartFunc :: mfargs(), Restart :: restart(), Shutdown :: shutdown(), @@ -63,6 +69,23 @@ -type strategy() :: 'one_for_all' | 'one_for_one' | 'rest_for_one' | 'simple_one_for_one'. +-type sup_flags() :: #{strategy => strategy(), % optional + intensity => non_neg_integer(), % optional + period => pos_integer()} % optional + | {RestartStrategy :: strategy(), + Intensity :: non_neg_integer(), + Period :: pos_integer()}. + +%%-------------------------------------------------------------------------- +%% Defaults +-define(default_flags, #{strategy => one_for_one, + intensity => 1, + period => 5}). +-define(default_child_spec, #{restart => permanent, + type => worker}). +%% Default 'shutdown' is 5000 for workers and infinity for supervisors. +%% Default 'modules' is [M], where M comes from the child's start {M,F,A}. + %%-------------------------------------------------------------------------- -record(child, {% pid is undefined when child is not running @@ -96,10 +119,7 @@ -define(is_simple(State), State#state.strategy =:= simple_one_for_one). -callback init(Args :: term()) -> - {ok, {{RestartStrategy :: strategy(), - MaxR :: non_neg_integer(), - MaxT :: non_neg_integer()}, - [ChildSpec :: child_spec()]}} + {ok, {SupFlags :: sup_flags(), [ChildSpec :: child_spec()]}} | ignore. -define(restarting(_Pid_), {restarting,_Pid_}). @@ -178,6 +198,14 @@ delete_child(Supervisor, Name) -> terminate_child(Supervisor, Name) -> call(Supervisor, {terminate_child, Name}). +-spec get_childspec(SupRef, Id) -> Result when + SupRef :: sup_ref(), + Id :: pid() | child_id(), + Result :: {'ok', child_spec()} | {'error', Error}, + Error :: 'not_found'. +get_childspec(Supervisor, Name) -> + call(Supervisor, {get_childspec, Name}). + -spec which_children(SupRef) -> [{Id,Child,Type,Modules}] when SupRef :: sup_ref(), Id :: child_id() | undefined, @@ -431,6 +459,14 @@ handle_call({delete_child, Name}, _From, State) -> {reply, {error, not_found}, State} end; +handle_call({get_childspec, Name}, _From, State) -> + case get_child(Name, State, ?is_simple(State)) of + {value, Child} -> + {reply, {ok, child_to_spec(Child)}, State}; + false -> + {reply, {error, not_found}, State} + end; + handle_call(which_children, _From, #state{children = [#child{restart_type = temporary, child_type = CT, modules = Mods}]} = @@ -610,13 +646,11 @@ terminate(_Reason, State) -> code_change(_, State, _) -> case (State#state.module):init(State#state.args) of {ok, {SupFlags, StartSpec}} -> - case catch check_flags(SupFlags) of - ok -> - {Strategy, MaxIntensity, Period} = SupFlags, - update_childspec(State#state{strategy = Strategy, - intensity = MaxIntensity, - period = Period}, - StartSpec); + case set_flags(SupFlags, State) of + {ok, State1} -> + update_childspec(State1, StartSpec); + {invalid_type, SupFlags} -> + {error, {bad_flags, SupFlags}}; % backwards compatibility Error -> {error, Error} end; @@ -626,14 +660,6 @@ code_change(_, State, _) -> Error end. -check_flags({Strategy, MaxIntensity, Period}) -> - validStrategy(Strategy), - validIntensity(MaxIntensity), - validPeriod(Period), - ok; -check_flags(What) -> - {bad_flags, What}. - update_childspec(State, StartSpec) when ?is_simple(State) -> case check_startspec(StartSpec) of {ok, [Child]} -> @@ -1188,25 +1214,36 @@ remove_child(Child, State) -> %% Returns: {ok, state()} | Error %%----------------------------------------------------------------- init_state(SupName, Type, Mod, Args) -> - case catch init_state1(SupName, Type, Mod, Args) of - {ok, State} -> - {ok, State}; - Error -> - Error + set_flags(Type, #state{name = supname(SupName,Mod), + module = Mod, + args = Args}). + +set_flags(Flags, State) -> + try check_flags(Flags) of + #{strategy := Strategy, intensity := MaxIntensity, period := Period} -> + {ok, State#state{strategy = Strategy, + intensity = MaxIntensity, + period = Period}} + catch + Thrown -> Thrown end. -init_state1(SupName, {Strategy, MaxIntensity, Period}, Mod, Args) -> +check_flags(SupFlags) when is_map(SupFlags) -> + do_check_flags(maps:merge(?default_flags,SupFlags)); +check_flags({Strategy, MaxIntensity, Period}) -> + check_flags(#{strategy => Strategy, + intensity => MaxIntensity, + period => Period}); +check_flags(What) -> + throw({invalid_type, What}). + +do_check_flags(#{strategy := Strategy, + intensity := MaxIntensity, + period := Period} = Flags) -> validStrategy(Strategy), validIntensity(MaxIntensity), validPeriod(Period), - {ok, #state{name = supname(SupName,Mod), - strategy = Strategy, - intensity = MaxIntensity, - period = Period, - module = Mod, - args = Args}}; -init_state1(_SupName, Type, _, _) -> - {invalid_type, Type}. + Flags. validStrategy(simple_one_for_one) -> true; validStrategy(one_for_one) -> true; @@ -1227,14 +1264,7 @@ supname(N, _) -> N. %%% ------------------------------------------------------ %%% Check that the children start specification is valid. -%%% Shall be a six (6) tuple -%%% {Name, Func, RestartType, Shutdown, ChildType, Modules} -%%% where Name is an atom -%%% Func is {Mod, Fun, Args} == {atom(), atom(), list()} -%%% RestartType is permanent | temporary | transient -%%% Shutdown = integer() > 0 | infinity | brutal_kill -%%% ChildType = supervisor | worker -%%% Modules = [atom()] | dynamic +%%% Input: [child_spec()] %%% Returns: {ok, [child_rec()]} | Error %%% ------------------------------------------------------ @@ -1244,6 +1274,9 @@ check_startspec([ChildSpec|T], Res) -> case check_childspec(ChildSpec) of {ok, Child} -> case lists:keymember(Child#child.name, #child.name, Res) of + %% The error message duplicate_child_name is kept for + %% backwards compatibility, although + %% duplicate_child_id would be more correct. true -> {duplicate_child_name, Child#child.name}; false -> check_startspec(T, [Child | Res]) end; @@ -1252,16 +1285,41 @@ check_startspec([ChildSpec|T], Res) -> check_startspec([], Res) -> {ok, lists:reverse(Res)}. +check_childspec(ChildSpec) when is_map(ChildSpec) -> + catch do_check_childspec(maps:merge(?default_child_spec,ChildSpec)); check_childspec({Name, Func, RestartType, Shutdown, ChildType, Mods}) -> - catch check_childspec(Name, Func, RestartType, Shutdown, ChildType, Mods); + check_childspec(#{id => Name, + start => Func, + restart => RestartType, + shutdown => Shutdown, + type => ChildType, + modules => Mods}); check_childspec(X) -> {invalid_child_spec, X}. -check_childspec(Name, Func, RestartType, Shutdown, ChildType, Mods) -> +do_check_childspec(#{restart := RestartType, + type := ChildType} = ChildSpec)-> + Name = case ChildSpec of + #{id := N} -> N; + _ -> throw(missing_id) + end, + Func = case ChildSpec of + #{start := F} -> F; + _ -> throw(missing_start) + end, validName(Name), validFunc(Func), validRestartType(RestartType), validChildType(ChildType), - validShutdown(Shutdown, ChildType), + Shutdown = case ChildSpec of + #{shutdown := S} -> S; + #{type := worker} -> 5000; + #{type := supervisor} -> infinity + end, + validShutdown(Shutdown), + Mods = case ChildSpec of + #{modules := Ms} -> Ms; + _ -> {M,_,_} = Func, [M] + end, validMods(Mods), {ok, #child{name = Name, mfargs = Func, restart_type = RestartType, shutdown = Shutdown, child_type = ChildType, modules = Mods}}. @@ -1282,11 +1340,11 @@ validRestartType(temporary) -> true; validRestartType(transient) -> true; validRestartType(RestartType) -> throw({invalid_restart_type, RestartType}). -validShutdown(Shutdown, _) +validShutdown(Shutdown) when is_integer(Shutdown), Shutdown > 0 -> true; -validShutdown(infinity, _) -> true; -validShutdown(brutal_kill, _) -> true; -validShutdown(Shutdown, _) -> throw({invalid_shutdown, Shutdown}). +validShutdown(infinity) -> true; +validShutdown(brutal_kill) -> true; +validShutdown(Shutdown) -> throw({invalid_shutdown, Shutdown}). validMods(dynamic) -> true; validMods(Mods) when is_list(Mods) -> @@ -1299,6 +1357,19 @@ validMods(Mods) when is_list(Mods) -> Mods); validMods(Mods) -> throw({invalid_modules, Mods}). +child_to_spec(#child{name = Name, + mfargs = Func, + restart_type = RestartType, + shutdown = Shutdown, + child_type = ChildType, + modules = Mods}) -> + #{id => Name, + start => Func, + restart => RestartType, + shutdown => Shutdown, + type => ChildType, + modules => Mods}. + %%% ------------------------------------------------------ %%% Add a new restart and calculate if the max restart %%% intensity has been reached (in that case the supervisor @@ -1367,14 +1438,14 @@ report_error(Error, Reason, Child, SupName) -> extract_child(Child) when is_list(Child#child.pid) -> [{nb_children, length(Child#child.pid)}, - {name, Child#child.name}, + {id, Child#child.name}, {mfargs, Child#child.mfargs}, {restart_type, Child#child.restart_type}, {shutdown, Child#child.shutdown}, {child_type, Child#child.child_type}]; extract_child(Child) -> [{pid, Child#child.pid}, - {name, Child#child.name}, + {id, Child#child.name}, {mfargs, Child#child.mfargs}, {restart_type, Child#child.restart_type}, {shutdown, Child#child.shutdown}, diff --git a/lib/stdlib/src/sys.erl b/lib/stdlib/src/sys.erl index d3ba09ce82..7e4bfa1fdd 100644 --- a/lib/stdlib/src/sys.erl +++ b/lib/stdlib/src/sys.erl @@ -24,6 +24,7 @@ get_state/1, get_state/2, replace_state/2, replace_state/3, change_code/4, change_code/5, + terminate/2, terminate/3, log/2, log/3, trace/2, trace/3, statistics/2, statistics/3, log_to_file/2, log_to_file/3, no_debug/1, no_debug/2, install/2, install/3, remove/2, remove/3]). @@ -163,6 +164,19 @@ change_code(Name, Mod, Vsn, Extra) -> change_code(Name, Mod, Vsn, Extra, Timeout) -> send_system_msg(Name, {change_code, Mod, Vsn, Extra}, Timeout). +-spec terminate(Name, Reason) -> 'ok' when + Name :: name(), + Reason :: term(). +terminate(Name, Reason) -> + send_system_msg(Name, {terminate, Reason}). + +-spec terminate(Name, Reason, Timeout) -> 'ok' when + Name :: name(), + Reason :: term(), + Timeout :: timeout(). +terminate(Name, Reason, Timeout) -> + send_system_msg(Name, {terminate, Reason}, Timeout). + %%----------------------------------------------------------------- %% Debug commands %%----------------------------------------------------------------- @@ -298,6 +312,8 @@ mfa(Name, {debug, {Func, Arg2}}) -> {sys, Func, [Name, Arg2]}; mfa(Name, {change_code, Mod, Vsn, Extra}) -> {sys, change_code, [Name, Mod, Vsn, Extra]}; +mfa(Name, {terminate, Reason}) -> + {sys, terminate, [Name, Reason]}; mfa(Name, Atom) -> {sys, Atom, [Name]}. @@ -313,7 +329,7 @@ mfa(Name, Req, Timeout) -> %% Returns: This function *never* returns! It calls the function %% Module:system_continue(Parent, NDebug, Misc) %% there the process continues the execution or -%% Module:system_terminate(Raeson, Parent, Debug, Misc) if +%% Module:system_terminate(Reason, Parent, Debug, Misc) if %% the process should terminate. %% The Module must export system_continue/3, system_terminate/4 %% and format_status/2 for status information. @@ -339,7 +355,10 @@ handle_system_msg(SysState, Msg, From, Parent, Mod, Debug, Misc, Hib) -> suspend_loop(suspended, Parent, Mod, NDebug, NMisc, Hib); {running, Reply, NDebug, NMisc} -> _ = gen:reply(From, Reply), - Mod:system_continue(Parent, NDebug, NMisc) + Mod:system_continue(Parent, NDebug, NMisc); + {{terminating, Reason}, Reply, NDebug, NMisc} -> + _ = gen:reply(From, Reply), + Mod:system_terminate(Reason, Parent, NDebug, NMisc) end. %%----------------------------------------------------------------- @@ -419,6 +438,8 @@ do_cmd(SysState, get_status, Parent, Mod, Debug, Misc) -> do_cmd(SysState, {debug, What}, _Parent, _Mod, Debug, Misc) -> {Res, NDebug} = debug_cmd(What, Debug), {SysState, Res, NDebug, Misc}; +do_cmd(_, {terminate, Reason}, _Parent, _Mod, Debug, Misc) -> + {{terminating, Reason}, ok, Debug, Misc}; do_cmd(suspended, {change_code, Module, Vsn, Extra}, _Parent, Mod, Debug, Misc) -> {Res, NMisc} = do_change_code(Mod, Module, Vsn, Extra, Misc), diff --git a/lib/stdlib/test/binary_module_SUITE.erl b/lib/stdlib/test/binary_module_SUITE.erl index 32cec0db6f..f828c70b63 100644 --- a/lib/stdlib/test/binary_module_SUITE.erl +++ b/lib/stdlib/test/binary_module_SUITE.erl @@ -506,12 +506,35 @@ do_interesting(Module) -> ?line [<<1,2,3>>,<<6>>] = Module:split(<<1,2,3,4,5,6,7,8>>, [<<4,5>>,<<7>>,<<8>>], [global,trim]), + ?line [<<1,2,3>>,<<6>>] = Module:split(<<1,2,3,4,5,6,7,8>>, + [<<4,5>>,<<7>>,<<8>>], + [global,trim_all]), ?line [<<1,2,3,4,5,6,7,8>>] = Module:split(<<1,2,3,4,5,6,7,8>>, [<<4,5>>,<<7>>,<<8>>], [global,trim,{scope,{0,4}}]), ?line [<<1,2,3>>,<<6,7,8>>] = Module:split(<<1,2,3,4,5,6,7,8>>, [<<4,5>>,<<7>>,<<8>>], [global,trim,{scope,{0,5}}]), + + ?line [<<>>,<<>>,<<3>>,<<6,7,8>>] = Module:split(<<1,2,3,4,5,6,7,8>>, + [<<1>>,<<2>>,<<4,5>>], + [global,trim]), + ?line [<<3>>,<<6,7,8>>] = Module:split(<<1,2,3,4,5,6,7,8>>, + [<<1>>,<<2>>,<<4,5>>], + [global,trim_all]), + + ?line [<<1,2,3>>,<<>>,<<7,8>>] = Module:split(<<1,2,3,4,5,6,7,8>>, + [<<4,5>>,<<6>>], + [global,trim]), + ?line [<<1,2,3>>,<<7,8>>] = Module:split(<<1,2,3,4,5,6,7,8>>, + [<<4,5>>,<<6>>], + [global,trim_all]), + ?line [<<>>,<<>>,<<3>>,<<>>,<<6>>] = Module:split(<<1,2,3,4,5,6,7,8>>, + [<<1>>,<<2>>,<<4>>,<<5>>,<<7>>,<<8>>], + [global,trim]), + ?line [<<3>>,<<6>>] = Module:split(<<1,2,3,4,5,6,7,8>>, + [<<1>>,<<2>>,<<4>>,<<5>>,<<7>>,<<8>>], + [global,trim_all]), ?line badarg = ?MASK_ERROR( Module:replace(<<1,2,3,4,5,6,7,8>>, [<<4,5>>,<<7>>,<<8>>],<<99>>, @@ -1247,6 +1270,8 @@ do_random_split_comp(N,NeedleRange,HaystackRange) -> true = do_split_comp(Needle,Haystack,[]), true = do_split_comp(Needle,Haystack,[global]), true = do_split_comp(Needle,Haystack,[global,trim]), + true = do_split_comp(Needle,Haystack,[global,trim_all]), + true = do_split_comp(Needle,Haystack,[global,trim,trim_all]), do_random_split_comp(N-1,NeedleRange,HaystackRange). do_random_split_comp2(0,_,_) -> ok; @@ -1257,6 +1282,9 @@ do_random_split_comp2(N,NeedleRange,HaystackRange) -> _ <- lists:duplicate(NumNeedles,a)], true = do_split_comp(Needles,Haystack,[]), true = do_split_comp(Needles,Haystack,[global]), + true = do_split_comp(Needles,Haystack,[global,trim]), + true = do_split_comp(Needles,Haystack,[global,trim_all]), + true = do_split_comp(Needles,Haystack,[global,trim,trim_all]), do_random_split_comp2(N-1,NeedleRange,HaystackRange). do_split_comp(N,H,Opts) -> diff --git a/lib/stdlib/test/binref.erl b/lib/stdlib/test/binref.erl index 6d96736ef3..a52ea98e5a 100644 --- a/lib/stdlib/test/binref.erl +++ b/lib/stdlib/test/binref.erl @@ -155,7 +155,8 @@ split(Haystack,Needles0,Options) -> true -> exit(badtype) end, - {Part,Global,Trim} = get_opts_split(Options,{nomatch,false,false}), + {Part,Global,Trim,TrimAll} = + get_opts_split(Options,{nomatch,false,false,false}), {Start,End,NewStack} = case Part of nomatch -> @@ -180,20 +181,24 @@ split(Haystack,Needles0,Options) -> [X] end end, - do_split(Haystack,MList,0,Trim) + do_split(Haystack,MList,0,Trim,TrimAll) catch _:_ -> erlang:error(badarg) end. -do_split(H,[],N,true) when N >= byte_size(H) -> +do_split(H,[],N,true,_) when N >= byte_size(H) -> []; -do_split(H,[],N,_) -> +do_split(H,[],N,_,true) when N >= byte_size(H) -> + []; +do_split(H,[],N,_,_) -> [part(H,{N,byte_size(H)-N})]; -do_split(H,[{A,B}|T],N,Trim) -> +do_split(H,[{A,B}|T],N,Trim,TrimAll) -> case part(H,{N,A-N}) of + <<>> when TrimAll == true -> + do_split(H,T,A+B,Trim,TrimAll); <<>> -> - Rest = do_split(H,T,A+B,Trim), + Rest = do_split(H,T,A+B,Trim,TrimAll), case {Trim, Rest} of {true,[]} -> []; @@ -201,7 +206,7 @@ do_split(H,[{A,B}|T],N,Trim) -> [<<>> | Rest] end; Oth -> - [Oth | do_split(H,T,A+B,Trim)] + [Oth | do_split(H,T,A+B,Trim,TrimAll)] end. @@ -565,14 +570,16 @@ get_opts_match([{scope,{A,B}} | T],_Part) -> get_opts_match(_,_) -> throw(badopt). -get_opts_split([],{Part,Global,Trim}) -> - {Part,Global,Trim}; -get_opts_split([{scope,{A,B}} | T],{_Part,Global,Trim}) -> - get_opts_split(T,{{A,B},Global,Trim}); -get_opts_split([global | T],{Part,_Global,Trim}) -> - get_opts_split(T,{Part,true,Trim}); -get_opts_split([trim | T],{Part,Global,_Trim}) -> - get_opts_split(T,{Part,Global,true}); +get_opts_split([],{Part,Global,Trim,TrimAll}) -> + {Part,Global,Trim,TrimAll}; +get_opts_split([{scope,{A,B}} | T],{_Part,Global,Trim,TrimAll}) -> + get_opts_split(T,{{A,B},Global,Trim,TrimAll}); +get_opts_split([global | T],{Part,_Global,Trim,TrimAll}) -> + get_opts_split(T,{Part,true,Trim,TrimAll}); +get_opts_split([trim | T],{Part,Global,_Trim,TrimAll}) -> + get_opts_split(T,{Part,Global,true,TrimAll}); +get_opts_split([trim_all | T],{Part,Global,Trim,_TrimAll}) -> + get_opts_split(T,{Part,Global,Trim,true}); get_opts_split(_,_) -> throw(badopt). diff --git a/lib/stdlib/test/erl_eval_SUITE.erl b/lib/stdlib/test/erl_eval_SUITE.erl index b55324161b..3427f431c5 100644 --- a/lib/stdlib/test/erl_eval_SUITE.erl +++ b/lib/stdlib/test/erl_eval_SUITE.erl @@ -1458,6 +1458,30 @@ eep43(Config) when is_list(Config) -> "lists:map(fun (X) -> X#{price := 0} end, [#{hello => 0, price => nil}]).", [#{hello => 0, price => 0}]), + check(fun () -> + Map = #{ <<33:333>> => "wat" }, + #{ <<33:333>> := "wat" } = Map + end, + "begin " + " Map = #{ <<33:333>> => \"wat\" }, " + " #{ <<33:333>> := \"wat\" } = Map " + "end.", + #{ <<33:333>> => "wat" }), + check(fun () -> + K1 = 1, + K2 = <<42:301>>, + K3 = {3,K2}, + Map = #{ K1 => 1, K2 => 2, K3 => 3, {2,2} => 4}, + #{ K1 := 1, K2 := 2, K3 := 3, {2,2} := 4} = Map + end, + "begin " + " K1 = 1, " + " K2 = <<42:301>>, " + " K3 = {3,K2}, " + " Map = #{ K1 => 1, K2 => 2, K3 => 3, {2,2} => 4}, " + " #{ K1 := 1, K2 := 2, K3 := 3, {2,2} := 4} = Map " + "end.", + #{ 1 => 1, <<42:301>> => 2, {3,<<42:301>>} => 3, {2,2} => 4}), error_check("[camembert]#{}.", {badarg,[camembert]}), error_check("#{} = 1.", {badmatch,1}), ok. diff --git a/lib/stdlib/test/erl_internal_SUITE.erl b/lib/stdlib/test/erl_internal_SUITE.erl index b6b3c004ea..197a7a33eb 100644 --- a/lib/stdlib/test/erl_internal_SUITE.erl +++ b/lib/stdlib/test/erl_internal_SUITE.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1999-2011. All Rights Reserved. +%% Copyright Ericsson AB 1999-2014. 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 @@ -51,7 +51,7 @@ end_per_group(_GroupName, Config) -> -define(default_timeout, ?t:minutes(2)). init_per_testcase(_Case, Config) -> - ?line Dog = test_server:timetrap(?default_timeout), + Dog = test_server:timetrap(?default_timeout), [{watchdog, Dog}|Config]. end_per_testcase(_Case, Config) -> @@ -63,27 +63,50 @@ behav(suite) -> []; behav(doc) -> ["Check that the behaviour callbacks are correctly defined"]; behav(_) -> - ?line check_behav_list([{start,2}, {stop,1}], - application:behaviour_info(callbacks)), - ?line check_behav_list([{init,1}, {handle_call,3}, {handle_cast,2}, - {handle_info,2}, {terminate,2}, {code_change,3}], - gen_server:behaviour_info(callbacks)), - ?line check_behav_list([{init,1}, {handle_event,3}, {handle_sync_event,4}, - {handle_info,3}, {terminate,3}, {code_change,4}], - gen_fsm:behaviour_info(callbacks)), - ?line check_behav_list([{init,1}, {handle_event,2}, {handle_call,2}, - {handle_info,2}, {terminate,2}, {code_change,3}], - gen_event:behaviour_info(callbacks)), - ?line check_behav_list( [{init,1}, {terminate,2}], - supervisor_bridge:behaviour_info(callbacks)), - ?line check_behav_list([{init,1}], - supervisor:behaviour_info(callbacks)), - ok. + Modules = [application, gen_server, gen_fsm, gen_event, + supervisor_bridge, supervisor], + lists:foreach(fun check_behav/1, Modules). + +check_behav(Module) -> + Callbacks = callbacks(Module), + Optional = optional_callbacks(Module), + check_behav_list(Callbacks, Module:behaviour_info(callbacks)), + check_behav_list(Optional, Module:behaviour_info(optional_callbacks)). check_behav_list([], []) -> ok; check_behav_list([L | L1], L2) -> - ?line true = lists:member(L, L2), - ?line L3 = lists:delete(L, L2), + true = lists:member(L, L2), + L3 = lists:delete(L, L2), check_behav_list(L1, L3). - +callbacks(application) -> + [{start,2}, {stop,1}]; +callbacks(gen_server) -> + [{init,1}, {handle_call,3}, {handle_cast,2}, + {handle_info,2}, {terminate,2}, {code_change,3}, + {format_status,2}]; +callbacks(gen_fsm) -> + [{init,1}, {handle_event,3}, {handle_sync_event,4}, + {handle_info,3}, {terminate,3}, {code_change,4}, + {format_status,2}]; +callbacks(gen_event) -> + [{init,1}, {handle_event,2}, {handle_call,2}, + {handle_info,2}, {terminate,2}, {code_change,3}, + {format_status,2}]; +callbacks(supervisor_bridge) -> + [{init,1}, {terminate,2}]; +callbacks(supervisor) -> + [{init,1}]. + +optional_callbacks(application) -> + []; +optional_callbacks(gen_server) -> + [{format_status,2}]; +optional_callbacks(gen_fsm) -> + [{format_status,2}]; +optional_callbacks(gen_event) -> + [{format_status,2}]; +optional_callbacks(supervisor_bridge) -> + []; +optional_callbacks(supervisor) -> + []. diff --git a/lib/stdlib/test/erl_lint_SUITE.erl b/lib/stdlib/test/erl_lint_SUITE.erl index ea61b2082b..f8a99f653a 100644 --- a/lib/stdlib/test/erl_lint_SUITE.erl +++ b/lib/stdlib/test/erl_lint_SUITE.erl @@ -42,6 +42,7 @@ unused_vars_warn_rec/1, unused_vars_warn_fun/1, unused_vars_OTP_4858/1, + unused_unsafe_vars_warn/1, export_vars_warn/1, shadow_vars/1, unused_import/1, @@ -55,7 +56,7 @@ otp_11772/1, otp_11771/1, otp_11872/1, export_all/1, bif_clash/1, - behaviour_basic/1, behaviour_multiple/1, + behaviour_basic/1, behaviour_multiple/1, otp_11861/1, otp_7550/1, otp_8051/1, format_warn/1, @@ -63,7 +64,7 @@ too_many_arguments/1, basic_errors/1,bin_syntax_errors/1, predef/1, - maps/1,maps_type/1 + maps/1,maps_type/1,otp_11851/1 ]). % Default timetrap timeout (set in init_per_testcase). @@ -89,16 +90,16 @@ all() -> otp_5362, otp_5371, otp_7227, otp_5494, otp_5644, otp_5878, otp_5917, otp_6585, otp_6885, otp_10436, otp_11254, otp_11772, otp_11771, otp_11872, export_all, - bif_clash, behaviour_basic, behaviour_multiple, + bif_clash, behaviour_basic, behaviour_multiple, otp_11861, otp_7550, otp_8051, format_warn, {group, on_load}, too_many_arguments, basic_errors, bin_syntax_errors, predef, - maps, maps_type]. + maps, maps_type, otp_11851]. groups() -> [{unused_vars_warn, [], [unused_vars_warn_basic, unused_vars_warn_lc, unused_vars_warn_rec, unused_vars_warn_fun, - unused_vars_OTP_4858]}, + unused_vars_OTP_4858, unused_unsafe_vars_warn]}, {on_load, [], [on_load_successful, on_load_failing]}]. init_per_suite(Config) -> @@ -730,6 +731,48 @@ unused_vars_OTP_4858(Config) when is_list(Config) -> ?line [] = run(Config, Ts), ok. +unused_unsafe_vars_warn(Config) when is_list(Config) -> + Ts = [{unused_unsafe1, + <<"t1() -> + UnusedVar1 = unused1, + try + UnusedVar2 = unused2 + catch + _:_ -> + ok + end, + ok. + ">>, + [warn_unused_vars], + {warnings,[{2,erl_lint,{unused_var,'UnusedVar1'}}, + {4,erl_lint,{unused_var,'UnusedVar2'}}]}}, + {unused_unsafe2, + <<"t2() -> + try + X = 1 + catch + _:_ -> ok + end. + ">>, + [warn_unused_vars], + {warnings,[{3,erl_lint,{unused_var,'X'}}]}}, + {unused_unsafe2, + <<"t3(X, Y) -> + X andalso Y. + ">>, + [warn_unused_vars], + []}, + {unused_unsafe4, + <<"t4() -> + _ = (catch X = X = 1), + _ = case ok of _ -> fun() -> ok end end, + fun (X) -> X end. + ">>, + [warn_unused_vars], + []}], + run(Config, Ts), + ok. + export_vars_warn(doc) -> "Warnings for exported variables"; export_vars_warn(suite) -> []; @@ -808,7 +851,19 @@ export_vars_warn(Config) when is_list(Config) -> [], {error,[{9,erl_lint,{unbound_var,'B'}}], [{9,erl_lint,{exported_var,'Y',{'receive',2}}}, - {10,erl_lint,{shadowed_var,'B',generate}}]}} + {10,erl_lint,{shadowed_var,'B',generate}}]}}, + + {exp4, + <<"t(X) -> + if true -> Z = X end, + case X of + 1 -> Z; + 2 -> X + end, + Z = X. + ">>, + [], + {warnings,[{7,erl_lint,{exported_var,'Z',{'if',2}}}]}} ], ?line [] = run(Config, Ts), ok. @@ -832,8 +887,15 @@ shadow_vars(Config) when is_list(Config) -> ">>, [nowarn_shadow_vars], {error,[{9,erl_lint,{unbound_var,'B'}}], - [{9,erl_lint,{exported_var,'Y',{'receive',2}}}]}}], - + [{9,erl_lint,{exported_var,'Y',{'receive',2}}}]}}, + {shadow2, + <<"t() -> + _ = (catch MS = MS = 1), % MS used unsafe + _ = case ok of _ -> fun() -> ok end end, + fun (MS) -> MS end. % MS not shadowed here + ">>, + [], + []}], ?line [] = run(Config, Ts), ok. @@ -958,6 +1020,45 @@ unsafe_vars(Config) when is_list(Config) -> [warn_unused_vars], {errors,[{3,erl_lint,{unsafe_var,'X',{'if',2}}}, {4,erl_lint,{unsafe_var,'X',{'if',2}}}], + []}}, + {unsafe8, + <<"t8(X) -> + case X of _ -> catch _Y = 1 end, + _Y." + >>, + [], + {errors,[{3,erl_lint,{unsafe_var,'_Y',{'catch',2}}}], + []}}, + {unsafe9, + <<"t9(X) -> + case X of + 1 -> + catch A = 1, % unsafe only here + B = 1, + C = 1, + D = 1; + 2 -> + A = 2, + % B not bound here + C = 2, + catch D = 2; % unsafe in two clauses + 3 -> + A = 3, + B = 3, + C = 3, + catch D = 3; % unsafe in two clauses + 4 -> + A = 4, + B = 4, + C = 4, + D = 4 + end, + {A,B,C,D}." + >>, + [], + {errors,[{24,erl_lint,{unsafe_var,'A',{'catch',4}}}, + {24,erl_lint,{unsafe_var,'B',{'case',2}}}, + {24,erl_lint,{unsafe_var,'D',{'case',2}}}], []}} ], ?line [] = run(Config, Ts), @@ -2648,8 +2749,9 @@ otp_11872(Config) when is_list(Config) -> t() -> 1. ">>, - {error,[{6,erl_lint,{undefined_type,{product,0}}}], - [{8,erl_lint,{new_var_arity_type,map}}]} = + {error,[{6,erl_lint,{undefined_type,{product,0}}}, + {8,erl_lint,{undefined_type,{dict,0}}}], + [{8,erl_lint,{new_builtin_type,{map,0}}}]} = run_test2(Config, Ts, []), ok. @@ -3080,6 +3182,193 @@ behaviour_multiple(Config) when is_list(Config) -> ?line [] = run(Config, Ts), ok. +otp_11861(doc) -> + "OTP-11861. behaviour_info() and -callback."; +otp_11861(suite) -> []; +otp_11861(Conf) when is_list(Conf) -> + CallbackFiles = [callback1, callback2, callback3, + bad_behaviour1, bad_behaviour2], + lists:foreach(fun(M) -> + F = filename:join(?datadir, M), + Opts = [{outdir,?privdir}, return], + {ok, M, []} = compile:file(F, Opts) + end, CallbackFiles), + CodePath = code:get_path(), + true = code:add_path(?privdir), + Ts = [{otp_11861_1, + <<" + -export([b1/1]). + -behaviour(callback1). + -behaviour(callback2). + + -spec b1(atom()) -> integer(). + b1(A) when is_atom(A)-> + 3. + ">>, + [], + %% b2/1 is optional in both modules + {warnings,[{4,erl_lint, + {conflicting_behaviours,{b1,1},callback2,3,callback1}}]}}, + {otp_11861_2, + <<" + -export([b2/1]). + -behaviour(callback1). + -behaviour(callback2). + + -spec b2(integer()) -> atom(). + b2(I) when is_integer(I)-> + a. + ">>, + [], + %% b2/1 is optional in callback2, but not in callback1 + {warnings,[{3,erl_lint,{undefined_behaviour_func,{b1,1},callback1}}, + {4,erl_lint, + {conflicting_behaviours,{b2,1},callback2,3,callback1}}]}}, + {otp_11861_3, + <<" + -callback b(_) -> atom(). + -optional_callbacks({b1,1}). % non-existing and ignored + ">>, + [], + []}, + {otp_11861_4, + <<" + -callback b(_) -> atom(). + -optional_callbacks([{b1,1}]). % non-existing + ">>, + [], + %% No behaviour-info(), but callback. + {errors,[{3,erl_lint,{undefined_callback,{lint_test,b1,1}}}],[]}}, + {otp_11861_5, + <<" + -optional_callbacks([{b1,1}]). % non-existing + ">>, + [], + %% No behaviour-info() and no callback: warning anyway + {errors,[{2,erl_lint,{undefined_callback,{lint_test,b1,1}}}],[]}}, + {otp_11861_6, + <<" + -optional_callbacks([b1/1]). % non-existing + behaviour_info(callbacks) -> [{b1,1}]. + ">>, + [], + %% behaviour-info() and no callback: warning anyway + {errors,[{2,erl_lint,{undefined_callback,{lint_test,b1,1}}}],[]}}, + {otp_11861_7, + <<" + -optional_callbacks([b1/1]). % non-existing + -callback b(_) -> atom(). + behaviour_info(callbacks) -> [{b1,1}]. + ">>, + [], + %% behaviour-info() callback: warning + {errors,[{2,erl_lint,{undefined_callback,{lint_test,b1,1}}}, + {3,erl_lint,{behaviour_info,{lint_test,b,1}}}], + []}}, + {otp_11861_8, + <<" + -callback b(_) -> atom(). + -optional_callbacks([b/1, {b, 1}]). + ">>, + [], + {errors,[{3,erl_lint,{redefine_optional_callback,{b,1}}}],[]}}, + {otp_11861_9, + <<" + -behaviour(gen_server). + -export([handle_call/3,handle_cast/2,handle_info/2, + code_change/3, init/1, terminate/2]). + handle_call(_, _, _) -> ok. + handle_cast(_, _) -> ok. + handle_info(_, _) -> ok. + code_change(_, _, _) -> ok. + init(_) -> ok. + terminate(_, _) -> ok. + ">>, + [], + []}, + {otp_11861_9, + <<" + -behaviour(gen_server). + -export([handle_call/3,handle_cast/2,handle_info/2, + code_change/3, init/1, terminate/2, format_status/2]). + handle_call(_, _, _) -> ok. + handle_cast(_, _) -> ok. + handle_info(_, _) -> ok. + code_change(_, _, _) -> ok. + init(_) -> ok. + terminate(_, _) -> ok. + format_status(_, _) -> ok. % optional callback + ">>, + [], + %% Nothing... + []}, + {otp_11861_10, + <<" + -optional_callbacks([{b1,1,bad}]). % badly formed and ignored + behaviour_info(callbacks) -> [{b1,1}]. + ">>, + [], + []}, + {otp_11861_11, + <<" + -behaviour(bad_behaviour1). + ">>, + [], + {warnings,[{2,erl_lint, + {ill_defined_behaviour_callbacks,bad_behaviour1}}]}}, + {otp_11861_12, + <<" + -behaviour(non_existing_behaviour). + ">>, + [], + {warnings,[{2,erl_lint, + {undefined_behaviour,non_existing_behaviour}}]}}, + {otp_11861_13, + <<" + -behaviour(bad_behaviour_none). + ">>, + [], + {warnings,[{2,erl_lint,{undefined_behaviour,bad_behaviour_none}}]}}, + {otp_11861_14, + <<" + -callback b(_) -> atom(). + ">>, + [], + []}, + {otp_11861_15, + <<" + -optional_callbacks([{b1,1,bad}]). % badly formed + -callback b(_) -> atom(). + ">>, + [], + []}, + {otp_11861_16, + <<" + -callback b(_) -> atom(). + -callback b(_) -> atom(). + ">>, + [], + {errors,[{3,erl_lint,{redefine_callback,{b,1}}}],[]}}, + {otp_11861_17, + <<" + -behaviour(bad_behaviour2). + ">>, + [], + {warnings,[{2,erl_lint,{undefined_behaviour_callbacks, + bad_behaviour2}}]}}, + {otp_11861_18, + <<" + -export([f1/1]). + -behaviour(callback3). + f1(_) -> ok. + ">>, + [], + []} + ], + ?line [] = run(Conf, Ts), + true = code:set_path(CodePath), + ok. + otp_7550(doc) -> "Test that the new utf8/utf16/utf32 types do not allow size or unit specifiers."; otp_7550(Config) when is_list(Config) -> @@ -3145,8 +3434,8 @@ format_warn(Config) when is_list(Config) -> ok. format_level(Level, Count, Config) -> - ?line W = get_compilation_warnings(Config, "format", - [{warn_format, Level}]), + ?line W = get_compilation_result(Config, "format", + [{warn_format, Level}]), %% Pick out the 'format' warnings. ?line FW = lists:filter(fun({_Line, erl_lint, {format_error, _}}) -> true; (_) -> false @@ -3330,42 +3619,22 @@ bin_syntax_errors(Config) -> ok. predef(doc) -> - "OTP-10342: Predefined types: array(), digraph(), and so on"; + "OTP-10342: No longer predefined types: array(), digraph(), and so on"; predef(suite) -> []; predef(Config) when is_list(Config) -> - W = get_compilation_warnings(Config, "predef", []), + W = get_compilation_result(Config, "predef", []), [] = W, - W2 = get_compilation_warnings(Config, "predef2", []), - Tag = deprecated_builtin_type, - [{7,erl_lint,{Tag,{array,0},{array,array,1},"OTP 18.0"}}, - {12,erl_lint,{Tag,{dict,0},{dict,dict,2},"OTP 18.0"}}, - {17,erl_lint,{Tag,{digraph,0},{digraph,graph},"OTP 18.0"}}, - {27,erl_lint,{Tag,{gb_set,0},{gb_sets,set,1},"OTP 18.0"}}, - {32,erl_lint,{Tag,{gb_tree,0},{gb_trees,tree,2},"OTP 18.0"}}, - {37,erl_lint,{Tag,{queue,0},{queue,queue,1},"OTP 18.0"}}, - {42,erl_lint,{Tag,{set,0},{sets,set,1},"OTP 18.0"}}, - {47,erl_lint,{Tag,{tid,0},{ets,tid},"OTP 18.0"}}] = W2, - Ts = [{otp_10342_1, - <<"-compile(nowarn_deprecated_type). - - -spec t(dict()) -> non_neg_integer(). - - t(D) -> - erlang:phash2(D, 3000). - ">>, - {[nowarn_unused_function]}, - []}, - {otp_10342_2, - <<"-spec t(dict()) -> non_neg_integer(). - - t(D) -> - erlang:phash2(D, 3000). - ">>, - {[nowarn_unused_function]}, - {warnings,[{1,erl_lint, - {deprecated_builtin_type,{dict,0},{dict,dict,2}, - "OTP 18.0"}}]}}], - [] = run(Config, Ts), + %% dict(), digraph() and so on were removed in Erlang/OTP 18.0. + E2 = get_compilation_result(Config, "predef2", []), + Tag = undefined_type, + {[{7,erl_lint,{Tag,{array,0}}}, + {12,erl_lint,{Tag,{dict,0}}}, + {17,erl_lint,{Tag,{digraph,0}}}, + {27,erl_lint,{Tag,{gb_set,0}}}, + {32,erl_lint,{Tag,{gb_tree,0}}}, + {37,erl_lint,{Tag,{queue,0}}}, + {42,erl_lint,{Tag,{set,0}}}, + {47,erl_lint,{Tag,{tid,0}}}],[]} = E2, ok. maps(Config) -> @@ -3398,7 +3667,8 @@ maps(Config) -> g := 1 + 1, h := _, i := (_X = _Y), - j := (x ! y) }) -> + j := (x ! y), + <<0:300>> := 33}) -> {A,F}. ">>, [], @@ -3411,9 +3681,10 @@ maps(Config) -> {errors,[{1,erl_lint,illegal_map_construction}, {1,erl_lint,{unbound_var,'X'}}], []}}, - {errors_in_map_keys, + {legal_map_construction, <<"t(V) -> #{ a => 1, #{a=>V} => 2, + #{{a,V}=>V} => 2, #{ \"hi\" => wazzup, hi => ho } => yep, [try a catch _:_ -> b end] => nope, ok => 1.0, @@ -3425,11 +3696,7 @@ maps(Config) -> }. ">>, [], - {errors,[{2,erl_lint,{illegal_map_key_variable,'V'}}, - {4,erl_lint,illegal_map_key}, - {6,erl_lint,illegal_map_key}, - {8,erl_lint,illegal_map_key}, - {10,erl_lint,illegal_map_key}],[]}}, + []}, {errors_in_map_keys_pattern, <<"t(#{ a := 2, #{} := A, @@ -3440,8 +3707,8 @@ maps(Config) -> A. ">>, [], - {errors,[{4,erl_lint,illegal_map_key}, - {6,erl_lint,{illegal_map_key_variable,'V'}}],[]}}], + {errors,[{4,erl_lint,illegal_map_construction}, + {6,erl_lint,illegal_map_key}],[]}}], [] = run(Config, Ts), ok. @@ -3470,7 +3737,94 @@ maps_type(Config) when is_list(Config) -> t(M) -> M. ">>, [], - {warnings,[{3,erl_lint,{new_var_arity_type,map}}]}}], + {warnings,[{3,erl_lint,{new_builtin_type,{map,0}}}]}}], + [] = run(Config, Ts), + ok. + +otp_11851(doc) -> + "OTP-11851: More atoms can be used as type names + bug fixes."; +otp_11851(Config) when is_list(Config) -> + Ts = [ + {otp_11851_1, + <<"-export([t/0]). + -type range(A, B) :: A | B. + + -type union(A) :: A. + + -type product() :: integer(). + + -type tuple(A) :: A. + + -type map(A) :: A. + + -type record() :: a | b. + + -type integer(A) :: A. + + -type atom(A) :: A. + + -type binary(A, B) :: A | B. + + -type 'fun'() :: integer(). + + -type 'fun'(X) :: X. + + -type 'fun'(X, Y) :: X | Y. + + -type all() :: range(atom(), integer()) | union(pid()) | product() + | tuple(reference()) | map(function()) | record() + | integer(atom()) | atom(integer()) + | binary(pid(), tuple()) | 'fun'(port()) + | 'fun'() | 'fun'(<<>>, 'none'). + + -spec t() -> all(). + + t() -> + a. + ">>, + [], + []}, + {otp_11851_2, + <<"-export([a/1, b/1, t/0]). + + -callback b(_) -> integer(). + + -callback ?MODULE:a(_) -> integer(). + + a(_) -> 3. + + b(_) -> a. + + t()-> a. + ">>, + [], + {errors,[{5,erl_lint,{bad_callback,{lint_test,a,1}}}],[]}}, + {otp_11851_3, + <<"-export([a/1]). + + -spec a(_A) -> boolean() when + _ :: atom(), + _A :: integer(). + + a(_) -> true. + ">>, + [], + {errors,[{4,erl_parse,"bad type variable"}],[]}}, + {otp_11851_4, + <<" + -spec a(_) -> ok. + -spec a(_) -> ok. + + -spec ?MODULE:a(_) -> ok. + -spec ?MODULE:a(_) -> ok. + ">>, + [], + {errors,[{3,erl_lint,{redefine_spec,{a,1}}}, + {5,erl_lint,{redefine_spec,{lint_test,a,1}}}, + {6,erl_lint,{redefine_spec,{lint_test,a,1}}}, + {6,erl_lint,{spec_fun_undefined,{a,1}}}], + []}} + ], [] = run(Config, Ts), ok. @@ -3487,9 +3841,9 @@ run(Config, Tests) -> end, lists:foldl(F, [], Tests). -%% Compiles a test file and returns the list of warnings. +%% Compiles a test file and returns the list of warnings/errors. -get_compilation_warnings(Conf, Filename, Warnings) -> +get_compilation_result(Conf, Filename, Warnings) -> ?line DataDir = ?datadir, ?line File = filename:join(DataDir, Filename), {ok,Bin} = file:read_file(File++".erl"), @@ -3498,6 +3852,7 @@ get_compilation_warnings(Conf, Filename, Warnings) -> Test = lists:nthtail(Start+Length, FileS), case run_test(Conf, Test, Warnings) of {warnings, Ws} -> Ws; + {errors,Es,Ws} -> {Es,Ws}; [] -> [] end. diff --git a/lib/stdlib/test/erl_lint_SUITE_data/bad_behaviour1.erl b/lib/stdlib/test/erl_lint_SUITE_data/bad_behaviour1.erl new file mode 100644 index 0000000000..230f4b4519 --- /dev/null +++ b/lib/stdlib/test/erl_lint_SUITE_data/bad_behaviour1.erl @@ -0,0 +1,6 @@ +-module(bad_behaviour1). + +-export([behaviour_info/1]). + +behaviour_info(callbacks) -> + [{a,1,bad}]. diff --git a/lib/stdlib/test/erl_lint_SUITE_data/bad_behaviour2.erl b/lib/stdlib/test/erl_lint_SUITE_data/bad_behaviour2.erl new file mode 100644 index 0000000000..bb755ce18b --- /dev/null +++ b/lib/stdlib/test/erl_lint_SUITE_data/bad_behaviour2.erl @@ -0,0 +1,6 @@ +-module(bad_behaviour2). + +-export([behaviour_info/1]). + +behaviour_info(callbacks) -> + undefined. diff --git a/lib/stdlib/test/erl_lint_SUITE_data/callback1.erl b/lib/stdlib/test/erl_lint_SUITE_data/callback1.erl new file mode 100644 index 0000000000..3cc5b51879 --- /dev/null +++ b/lib/stdlib/test/erl_lint_SUITE_data/callback1.erl @@ -0,0 +1,6 @@ +-module(callback1). + +-callback b1(I :: integer()) -> atom(). +-callback b2(A :: atom()) -> integer(). + +-optional_callbacks([{b2,1}]). diff --git a/lib/stdlib/test/erl_lint_SUITE_data/callback2.erl b/lib/stdlib/test/erl_lint_SUITE_data/callback2.erl new file mode 100644 index 0000000000..211cf9f115 --- /dev/null +++ b/lib/stdlib/test/erl_lint_SUITE_data/callback2.erl @@ -0,0 +1,6 @@ +-module(callback2). + +-callback b1(I :: integer()) -> atom(). +-callback b2(A :: atom()) -> integer(). + +-optional_callbacks([b1/1, b2/1]). diff --git a/lib/stdlib/test/erl_lint_SUITE_data/callback3.erl b/lib/stdlib/test/erl_lint_SUITE_data/callback3.erl new file mode 100644 index 0000000000..97b3ecb860 --- /dev/null +++ b/lib/stdlib/test/erl_lint_SUITE_data/callback3.erl @@ -0,0 +1,8 @@ +-module(callback3). + +-export([behaviour_info/1]). + +behaviour_info(callbacks) -> + [{f1, 1}]; +behaviour_info(_) -> + undefined. diff --git a/lib/stdlib/test/erl_lint_SUITE_data/predef.erl b/lib/stdlib/test/erl_lint_SUITE_data/predef.erl index ee9073aa67..3cb7bf40f1 100644 --- a/lib/stdlib/test/erl_lint_SUITE_data/predef.erl +++ b/lib/stdlib/test/erl_lint_SUITE_data/predef.erl @@ -5,8 +5,8 @@ -export_type([array/0, digraph/0, gb_set/0]). -%% Before Erlang/OTP 17.0 local re-definitions of pre-defined opaque -%% types were ignored but did not generate any warning. +%% Since Erlang/OTP 18.0 array() and so on are no longer pre-defined, +%% so there is nothing special about them at all. -opaque array() :: atom(). -opaque digraph() :: atom(). -opaque gb_set() :: atom(). diff --git a/lib/stdlib/test/erl_pp_SUITE.erl b/lib/stdlib/test/erl_pp_SUITE.erl index 927fe0b595..f71446dd64 100644 --- a/lib/stdlib/test/erl_pp_SUITE.erl +++ b/lib/stdlib/test/erl_pp_SUITE.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2006-2013. All Rights Reserved. +%% Copyright Ericsson AB 2006-2014. 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 @@ -42,7 +42,6 @@ -export([ func/1, call/1, recs/1, try_catch/1, if_then/1, receive_after/1, bits/1, head_tail/1, cond1/1, block/1, case1/1, ops/1, messages/1, - old_mnemosyne_syntax/1, import_export/1, misc_attrs/1, dialyzer_attrs/1, hook/1, neg_indent/1, @@ -50,7 +49,7 @@ otp_6321/1, otp_6911/1, otp_6914/1, otp_8150/1, otp_8238/1, otp_8473/1, otp_8522/1, otp_8567/1, otp_8664/1, otp_9147/1, - otp_10302/1, otp_10820/1, otp_11100/1]). + otp_10302/1, otp_10820/1, otp_11100/1, otp_11861/1]). %% Internal export. -export([ehook/6]). @@ -77,13 +76,13 @@ groups() -> [{expr, [], [func, call, recs, try_catch, if_then, receive_after, bits, head_tail, cond1, block, case1, ops, - messages, old_mnemosyne_syntax, maps_syntax + messages, maps_syntax ]}, {attributes, [], [misc_attrs, import_export, dialyzer_attrs]}, {tickets, [], [otp_6321, otp_6911, otp_6914, otp_8150, otp_8238, otp_8473, otp_8522, otp_8567, otp_8664, otp_9147, - otp_10302, otp_10820, otp_11100]}]. + otp_10302, otp_10820, otp_11100, otp_11861]}]. init_per_suite(Config) -> Config. @@ -561,27 +560,6 @@ messages(Config) when is_list(Config) -> ?line true = "\n" =:= lists:flatten(erl_pp:form({eof,0})), ok. -old_mnemosyne_syntax(Config) when is_list(Config) -> - %% Since we have kept the ':-' token, - %% better test that we can pretty print it. - R = {rule,12,sales,2, - [{clause,12, - [{var,12,'E'},{atom,12,employee}], - [], - [{generate,13, - {var,13,'E'}, - {call,13,{atom,13,table},[{atom,13,employee}]}}, - {match,14, - {record_field,14,{var,14,'E'},{atom,14,salary}}, - {atom,14,sales}}]}]}, - ?line "sales(E, employee) :-\n" - " E <- table(employee),\n" - " E.salary = sales.\n" = - lists:flatten(erl_pp:form(R)), - ok. - - - import_export(suite) -> []; import_export(Config) when is_list(Config) -> @@ -664,26 +642,6 @@ do_hook(HookFun) -> AFormChars = erl_pp:form(A, H), ?line true = AChars =:= lists:flatten(AFormChars), - R = {rule,0,sales,0, - [{clause,0,[{var,0,'E'},{atom,0,employee}],[], - [{generate,2,{var,2,'E'}, - {call,2,{atom,2,table},[{atom,2,employee}]}}, - {match,3, - {record_field,3,{var,3,'E'},{atom,3,salary}}, - {foo,Expr}}]}]}, - RChars = lists:flatten(erl_pp:rule(R, H)), - R2 = {rule,0,sales,0, - [{clause,0,[{var,0,'E'},{atom,0,employee}],[], - [{generate,2,{var,2,'E'}, - {call,2,{atom,2,table},[{atom,2,employee}]}}, - {match,3, - {record_field,3,{var,3,'E'},{atom,3,salary}}, - {call,0,{atom,0,foo},[Expr2]}}]}]}, - RChars2 = erl_pp:rule(R2), - ?line true = RChars =:= lists:flatten(RChars2), - ARChars = erl_pp:form(R, H), - ?line true = RChars =:= lists:flatten(ARChars), - ?line "INVALID-FORM:{foo,bar}:" = lists:flatten(erl_pp:expr({foo,bar})), %% A list (as before R6), not a list of lists. @@ -874,6 +832,7 @@ type_examples() -> {ex3,<<"-type paren() :: (ann2()). ">>}, {ex4,<<"-type t1() :: atom(). ">>}, {ex5,<<"-type t2() :: [t1()]. ">>}, + {ex56,<<"-type integer(A) :: A. ">>}, {ex6,<<"-type t3(Atom) :: integer(Atom). ">>}, {ex7,<<"-type '\\'t::4'() :: t3('\\'foobar'). ">>}, {ex8,<<"-type t5() :: {t1(), t3(foo)}. ">>}, @@ -1204,8 +1163,18 @@ otp_11100(Config) when is_list(Config) -> []}}), ok. +otp_11861(doc) -> + "OTP-11861. behaviour_info() and -callback."; +otp_11861(suite) -> []; +otp_11861(Config) when is_list(Config) -> + "-optional_callbacks([bar/0]).\n" = + pf({attribute,3,optional_callbacks,[{bar,0}]}), + "-optional_callbacks([{bar,1,bad}]).\n" = + pf({attribute,4,optional_callbacks,[{bar,1,bad}]}), + ok. + pf(Form) -> - lists:flatten(erl_pp:form(Form,none)). + lists:flatten(erl_pp:form(Form, none)). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% diff --git a/lib/stdlib/test/erl_scan_SUITE.erl b/lib/stdlib/test/erl_scan_SUITE.erl index 9be9f641c8..6ef947f0e3 100644 --- a/lib/stdlib/test/erl_scan_SUITE.erl +++ b/lib/stdlib/test/erl_scan_SUITE.erl @@ -226,7 +226,7 @@ atoms() -> punctuations() -> L = ["<<", "<-", "<=", "<", ">>", ">=", ">", "->", "--", "-", "++", "+", "=:=", "=/=", "=<", "=>", "==", "=", "/=", - "/", "||", "|", ":=", ":-", "::", ":"], + "/", "||", "|", ":=", "::", ":"], %% One token at a time: [begin W = list_to_atom(S), diff --git a/lib/stdlib/test/filelib_SUITE.erl b/lib/stdlib/test/filelib_SUITE.erl index bd313390b3..146d810189 100644 --- a/lib/stdlib/test/filelib_SUITE.erl +++ b/lib/stdlib/test/filelib_SUITE.erl @@ -77,7 +77,8 @@ wildcard_one(Config) when is_list(Config) -> L = filelib:wildcard(Wc), L = filelib:wildcard(Wc, erl_prim_loader), L = filelib:wildcard(Wc, "."), - L = filelib:wildcard(Wc, Dir) + L = filelib:wildcard(Wc, Dir), + L = filelib:wildcard(Wc, Dir++"/.") end), ?line file:set_cwd(OldCwd), ?line ok = file:del_dir(Dir), diff --git a/lib/stdlib/test/filename_SUITE.erl b/lib/stdlib/test/filename_SUITE.erl index ecd9cff9f9..6f1d1a891d 100644 --- a/lib/stdlib/test/filename_SUITE.erl +++ b/lib/stdlib/test/filename_SUITE.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1997-2012. All Rights Reserved. +%% Copyright Ericsson AB 1997-2014. 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 @@ -287,38 +287,66 @@ extension(Config) when is_list(Config) -> %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% join(Config) when is_list(Config) -> + %% Whenever joining two elements, test the equivalence between + %% join/1 and join/2 (OTP-12158) by using help function + %% filename_join/2. ?line "/" = filename:join(["/"]), ?line "/" = filename:join(["//"]), - ?line "usr/foo.erl" = filename:join("usr","foo.erl"), - ?line "/src/foo.erl" = filename:join(usr, "/src/foo.erl"), - ?line "/src/foo.erl" = filename:join(["/src/",'foo.erl']), - ?line "/src/foo.erl" = filename:join(usr, ["/sr", 'c/foo.erl']), - ?line "/src/foo.erl" = filename:join("usr", "/src/foo.erl"), + "usr/foo.erl" = filename_join("usr","foo.erl"), + "/src/foo.erl" = filename_join(usr, "/src/foo.erl"), + "/src/foo.erl" = filename_join("/src/",'foo.erl'), + "/src/foo.erl" = filename_join(usr, ["/sr", 'c/foo.erl']), + "/src/foo.erl" = filename_join("usr", "/src/foo.erl"), %% Make sure that redundant slashes work too. ?line "a/b/c/d/e/f/g" = filename:join(["a//b/c/////d//e/f/g"]), - ?line "a/b/c/d/e/f/g" = filename:join(["a//b/c/", "d//e/f/g"]), - ?line "a/b/c/d/e/f/g" = filename:join(["a//b/c", "d//e/f/g"]), - ?line "/d/e/f/g" = filename:join(["a//b/c", "/d//e/f/g"]), - ?line "/d/e/f/g" = filename:join(["a//b/c", "//d//e/f/g"]), - - ?line "foo/bar" = filename:join([$f,$o,$o,$/,[]], "bar"), + "a/b/c/d/e/f/g" = filename_join("a//b/c/", "d//e/f/g"), + "a/b/c/d/e/f/g" = filename_join("a//b/c", "d//e/f/g"), + "/d/e/f/g" = filename_join("a//b/c", "/d//e/f/g"), + "/d/e/f/g" = filename:join("a//b/c", "//d//e/f/g"), + + "foo/bar" = filename_join([$f,$o,$o,$/,[]], "bar"), + + %% Single dots - should be removed if in the middle of the path, + %% but not at the end of the path. + "/." = filename:join(["/."]), + "/" = filename:join(["/./"]), + "/." = filename:join(["/./."]), + "./." = filename:join(["./."]), + + "/a/b" = filename_join("/a/.","b"), + "/a/b/." = filename_join("/a/.","b/."), + "/a/." = filename_join("/a/.","."), + "/a/." = filename_join("/a","."), + "/a/." = filename_join("/a/.",""), + "./." = filename_join("./.","."), + "./." = filename_join("./","."), + "./." = filename_join("./.",""), + "." = filename_join(".",""), + "./." = filename_join(".","."), + + %% Trailing slash shall be removed - except the root + "/" = filename:join(["/"]), + "/" = filename:join(["/./"]), + "/a" = filename:join(["/a/"]), + "/b" = filename_join("/a/","/b/"), + "/a/b" = filename_join("/a/","b/"), ?line case os:type() of {win32, _} -> ?line "d:/" = filename:join(["D:/"]), ?line "d:/" = filename:join(["D:\\"]), - ?line "d:/abc" = filename:join(["D:/", "abc"]), - ?line "d:abc" = filename:join(["D:", "abc"]), + "d:/abc" = filename_join("D:/", "abc"), + "d:abc" = filename_join("D:", "abc"), ?line "a/b/c/d/e/f/g" = filename:join(["a//b\\c//\\/\\d/\\e/f\\g"]), ?line "a:usr/foo.erl" = filename:join(["A:","usr","foo.erl"]), ?line "/usr/foo.erl" = filename:join(["A:","/usr","foo.erl"]), - ?line "c:usr" = filename:join("A:","C:usr"), - ?line "a:usr" = filename:join("A:","usr"), - ?line "c:/usr" = filename:join("A:", "C:/usr"), + "c:usr" = filename_join("A:","C:usr"), + "a:usr" = filename_join("A:","usr"), + "c:/usr" = filename_join("A:", "C:/usr"), ?line "c:/usr/foo.erl" = filename:join(["A:","C:/usr","foo.erl"]), ?line "c:usr/foo.erl" = @@ -329,6 +357,11 @@ join(Config) when is_list(Config) -> ok end. +%% Make sure join([A,B]) is equivalent to join(A,B) (OTP-12158) +filename_join(A,B) -> + Res = filename:join(A,B), + Res = filename:join([A,B]). + pathtype(Config) when is_list(Config) -> ?line relative = filename:pathtype(".."), ?line relative = filename:pathtype("foo"), @@ -633,6 +666,53 @@ join_bin(Config) when is_list(Config) -> ?line <<"foo/bar">> = filename:join([$f,$o,$o,$/,[]], <<"bar">>), + %% Single dots - should be removed if in the middle of the path, + %% but not at the end of the path. + %% Also test equivalence between join/1 and join/2 (OTP-12158) + <<"/.">> = filename:join([<<"/.">>]), + <<"/">> = filename:join([<<"/./">>]), + <<"/.">> = filename:join([<<"/./.">>]), + <<"./.">> = filename:join([<<"./.">>]), + + <<"/a/b">> = filename:join([<<"/a/.">>,<<"b">>]), + <<"/a/b">> = filename:join(<<"/a/.">>,<<"b">>), + + <<"/a/b/.">> = filename:join([<<"/a/.">>,<<"b/.">>]), + <<"/a/b/.">> = filename:join(<<"/a/.">>,<<"b/.">>), + + <<"/a/.">> = filename:join([<<"/a/.">>,<<".">>]), + <<"/a/.">> = filename:join(<<"/a/.">>,<<".">>), + + <<"/a/.">> = filename:join([<<"/a">>,<<".">>]), + <<"/a/.">> = filename:join(<<"/a">>,<<".">>), + + <<"/a/.">> = filename:join([<<"/a/.">>,<<"">>]), + <<"/a/.">> = filename:join(<<"/a/.">>,<<"">>), + + <<"./.">> = filename:join([<<"./.">>,<<".">>]), + <<"./.">> = filename:join(<<"./.">>,<<".">>), + + <<"./.">> = filename:join([<<"./">>,<<".">>]), + <<"./.">> = filename:join(<<"./">>,<<".">>), + + <<"./.">> = filename:join([<<"./.">>,<<"">>]), + <<"./.">> = filename:join(<<"./.">>,<<"">>), + + <<".">> = filename:join([<<".">>,<<"">>]), + <<".">> = filename:join(<<".">>,<<"">>), + + <<"./.">> = filename:join([<<".">>,<<".">>]), + <<"./.">> = filename:join(<<".">>,<<".">>), + + %% Trailing slash shall be removed - except the root + <<"/">> = filename:join([<<"/">>]), + <<"/">> = filename:join([<<"/./">>]), + <<"/a">> = filename:join([<<"/a/">>]), + <<"/b">> = filename:join([<<"/a/">>,<<"/b/">>]), + <<"/b">> = filename:join(<<"/a/">>,<<"/b/">>), + <<"/a/b">> = filename:join([<<"/a/">>,<<"b/">>]), + <<"/a/b">> = filename:join(<<"/a/">>,<<"b/">>), + ?line case os:type() of {win32, _} -> ?line <<"d:/">> = filename:join([<<"D:/">>]), diff --git a/lib/stdlib/test/gen_event_SUITE.erl b/lib/stdlib/test/gen_event_SUITE.erl index 60a1ba8c60..576a5adfce 100644 --- a/lib/stdlib/test/gen_event_SUITE.erl +++ b/lib/stdlib/test/gen_event_SUITE.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2013. All Rights Reserved. +%% Copyright Ericsson AB 1996-2014. 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 @@ -106,7 +106,7 @@ start(Config) when is_list(Config) -> ?line {error, {already_started, _}} = gen_event:start({global, my_dummy_name}), - exit(Pid6, shutdown), + ok = gen_event:stop({global, my_dummy_name}, shutdown, 10000), receive {'EXIT', Pid6, shutdown} -> ok after 10000 -> diff --git a/lib/stdlib/test/gen_fsm_SUITE.erl b/lib/stdlib/test/gen_fsm_SUITE.erl index 39f0442824..dabc10aec4 100644 --- a/lib/stdlib/test/gen_fsm_SUITE.erl +++ b/lib/stdlib/test/gen_fsm_SUITE.erl @@ -27,6 +27,9 @@ -export([start1/1, start2/1, start3/1, start4/1, start5/1, start6/1, start7/1, start8/1, start9/1, start10/1, start11/1, start12/1]). +-export([stop1/1, stop2/1, stop3/1, stop4/1, stop5/1, stop6/1, stop7/1, + stop8/1, stop9/1, stop10/1]). + -export([ abnormal1/1, abnormal2/1]). -export([shutdown/1]). @@ -66,6 +69,8 @@ groups() -> [{start, [], [start1, start2, start3, start4, start5, start6, start7, start8, start9, start10, start11, start12]}, + {stop, [], + [stop1, stop2, stop3, stop4, stop5, stop6, stop7, stop8, stop9, stop10]}, {abnormal, [], [abnormal1, abnormal2]}, {sys, [], [sys1, call_format_status, error_format_status, terminate_crash_format, @@ -281,6 +286,105 @@ start12(Config) when is_list(Config) -> ok. +%% Anonymous, reason 'normal' +stop1(_Config) -> + {ok, Pid} = gen_fsm:start(?MODULE, [], []), + ok = gen_fsm:stop(Pid), + false = erlang:is_process_alive(Pid), + {'EXIT',noproc} = (catch gen_fsm:stop(Pid)), + ok. + +%% Anonymous, other reason +stop2(_Config) -> + {ok,Pid} = gen_fsm:start(?MODULE, [], []), + ok = gen_fsm:stop(Pid, other_reason, infinity), + false = erlang:is_process_alive(Pid), + ok. + +%% Anonymous, invalid timeout +stop3(_Config) -> + {ok,Pid} = gen_fsm:start(?MODULE, [], []), + {'EXIT',_} = (catch gen_fsm:stop(Pid, other_reason, invalid_timeout)), + true = erlang:is_process_alive(Pid), + ok = gen_fsm:stop(Pid), + false = erlang:is_process_alive(Pid), + ok. + +%% Registered name +stop4(_Config) -> + {ok,Pid} = gen_fsm:start({local,to_stop},?MODULE, [], []), + ok = gen_fsm:stop(to_stop), + false = erlang:is_process_alive(Pid), + {'EXIT',noproc} = (catch gen_fsm:stop(to_stop)), + ok. + +%% Registered name and local node +stop5(_Config) -> + {ok,Pid} = gen_fsm:start({local,to_stop},?MODULE, [], []), + ok = gen_fsm:stop({to_stop,node()}), + false = erlang:is_process_alive(Pid), + {'EXIT',noproc} = (catch gen_fsm:stop({to_stop,node()})), + ok. + +%% Globally registered name +stop6(_Config) -> + {ok, Pid} = gen_fsm:start({global, to_stop}, ?MODULE, [], []), + ok = gen_fsm:stop({global,to_stop}), + false = erlang:is_process_alive(Pid), + {'EXIT',noproc} = (catch gen_fsm:stop({global,to_stop})), + ok. + +%% 'via' registered name +stop7(_Config) -> + dummy_via:reset(), + {ok, Pid} = gen_fsm:start({via, dummy_via, to_stop}, + ?MODULE, [], []), + ok = gen_fsm:stop({via, dummy_via, to_stop}), + false = erlang:is_process_alive(Pid), + {'EXIT',noproc} = (catch gen_fsm:stop({via, dummy_via, to_stop})), + ok. + +%% Anonymous on remote node +stop8(_Config) -> + {ok,Node} = test_server:start_node(gen_fsm_SUITE_stop8,slave,[]), + Dir = filename:dirname(code:which(?MODULE)), + rpc:call(Node,code,add_path,[Dir]), + {ok, Pid} = rpc:call(Node,gen_fsm,start,[?MODULE,[],[]]), + ok = gen_fsm:stop(Pid), + false = rpc:call(Node,erlang,is_process_alive,[Pid]), + {'EXIT',noproc} = (catch gen_fsm:stop(Pid)), + true = test_server:stop_node(Node), + {'EXIT',{{nodedown,Node},_}} = (catch gen_fsm:stop(Pid)), + ok. + +%% Registered name on remote node +stop9(_Config) -> + {ok,Node} = test_server:start_node(gen_fsm_SUITE_stop9,slave,[]), + Dir = filename:dirname(code:which(?MODULE)), + rpc:call(Node,code,add_path,[Dir]), + {ok, Pid} = rpc:call(Node,gen_fsm,start,[{local,to_stop},?MODULE,[],[]]), + ok = gen_fsm:stop({to_stop,Node}), + undefined = rpc:call(Node,erlang,whereis,[to_stop]), + false = rpc:call(Node,erlang,is_process_alive,[Pid]), + {'EXIT',noproc} = (catch gen_fsm:stop({to_stop,Node})), + true = test_server:stop_node(Node), + {'EXIT',{{nodedown,Node},_}} = (catch gen_fsm:stop({to_stop,Node})), + ok. + +%% Globally registered name on remote node +stop10(_Config) -> + {ok,Node} = test_server:start_node(gen_fsm_SUITE_stop10,slave,[]), + Dir = filename:dirname(code:which(?MODULE)), + rpc:call(Node,code,add_path,[Dir]), + {ok, Pid} = rpc:call(Node,gen_fsm,start,[{global,to_stop},?MODULE,[],[]]), + global:sync(), + ok = gen_fsm:stop({global,to_stop}), + false = rpc:call(Node,erlang,is_process_alive,[Pid]), + {'EXIT',noproc} = (catch gen_fsm:stop({global,to_stop})), + true = test_server:stop_node(Node), + {'EXIT',noproc} = (catch gen_fsm:stop({global,to_stop})), + ok. + %% Check that time outs in calls work abnormal1(suite) -> []; abnormal1(Config) when is_list(Config) -> diff --git a/lib/stdlib/test/gen_server_SUITE.erl b/lib/stdlib/test/gen_server_SUITE.erl index 0f03fda30a..30dabf63c5 100644 --- a/lib/stdlib/test/gen_server_SUITE.erl +++ b/lib/stdlib/test/gen_server_SUITE.erl @@ -36,6 +36,9 @@ get_state/1, replace_state/1, call_with_huge_message_queue/1 ]). +-export([stop1/1, stop2/1, stop3/1, stop4/1, stop5/1, stop6/1, stop7/1, + stop8/1, stop9/1, stop10/1]). + % spawn export -export([spec_init_local/2, spec_init_global/2, spec_init_via/2, spec_init_default_timeout/2, spec_init_global_default_timeout/2, @@ -51,7 +54,7 @@ suite() -> [{ct_hooks,[ts_install_cth]}]. all() -> - [start, crash, call, cast, cast_fast, info, abcast, + [start, {group,stop}, crash, call, cast, cast_fast, info, abcast, multicall, multicall_down, call_remote1, call_remote2, call_remote3, call_remote_n1, call_remote_n2, call_remote_n3, spec_init, @@ -63,7 +66,8 @@ all() -> call_with_huge_message_queue]. groups() -> - []. + [{stop, [], + [stop1, stop2, stop3, stop4, stop5, stop6, stop7, stop8, stop9, stop10]}]. init_per_suite(Config) -> Config. @@ -237,6 +241,105 @@ start(Config) when is_list(Config) -> process_flag(trap_exit, OldFl), ok. +%% Anonymous, reason 'normal' +stop1(_Config) -> + {ok, Pid} = gen_server:start(?MODULE, [], []), + ok = gen_server:stop(Pid), + false = erlang:is_process_alive(Pid), + {'EXIT',noproc} = (catch gen_server:stop(Pid)), + ok. + +%% Anonymous, other reason +stop2(_Config) -> + {ok,Pid} = gen_server:start(?MODULE, [], []), + ok = gen_server:stop(Pid, other_reason, infinity), + false = erlang:is_process_alive(Pid), + ok. + +%% Anonymous, invalid timeout +stop3(_Config) -> + {ok,Pid} = gen_server:start(?MODULE, [], []), + {'EXIT',_} = (catch gen_server:stop(Pid, other_reason, invalid_timeout)), + true = erlang:is_process_alive(Pid), + ok = gen_server:stop(Pid), + false = erlang:is_process_alive(Pid), + ok. + +%% Registered name +stop4(_Config) -> + {ok,Pid} = gen_server:start({local,to_stop},?MODULE, [], []), + ok = gen_server:stop(to_stop), + false = erlang:is_process_alive(Pid), + {'EXIT',noproc} = (catch gen_server:stop(to_stop)), + ok. + +%% Registered name and local node +stop5(_Config) -> + {ok,Pid} = gen_server:start({local,to_stop},?MODULE, [], []), + ok = gen_server:stop({to_stop,node()}), + false = erlang:is_process_alive(Pid), + {'EXIT',noproc} = (catch gen_server:stop({to_stop,node()})), + ok. + +%% Globally registered name +stop6(_Config) -> + {ok, Pid} = gen_server:start({global, to_stop}, ?MODULE, [], []), + ok = gen_server:stop({global,to_stop}), + false = erlang:is_process_alive(Pid), + {'EXIT',noproc} = (catch gen_server:stop({global,to_stop})), + ok. + +%% 'via' registered name +stop7(_Config) -> + dummy_via:reset(), + {ok, Pid} = gen_server:start({via, dummy_via, to_stop}, + ?MODULE, [], []), + ok = gen_server:stop({via, dummy_via, to_stop}), + false = erlang:is_process_alive(Pid), + {'EXIT',noproc} = (catch gen_server:stop({via, dummy_via, to_stop})), + ok. + +%% Anonymous on remote node +stop8(_Config) -> + {ok,Node} = test_server:start_node(gen_server_SUITE_stop8,slave,[]), + Dir = filename:dirname(code:which(?MODULE)), + rpc:call(Node,code,add_path,[Dir]), + {ok, Pid} = rpc:call(Node,gen_server,start,[?MODULE,[],[]]), + ok = gen_server:stop(Pid), + false = rpc:call(Node,erlang,is_process_alive,[Pid]), + {'EXIT',noproc} = (catch gen_server:stop(Pid)), + true = test_server:stop_node(Node), + {'EXIT',{{nodedown,Node},_}} = (catch gen_server:stop(Pid)), + ok. + +%% Registered name on remote node +stop9(_Config) -> + {ok,Node} = test_server:start_node(gen_server_SUITE_stop9,slave,[]), + Dir = filename:dirname(code:which(?MODULE)), + rpc:call(Node,code,add_path,[Dir]), + {ok, Pid} = rpc:call(Node,gen_server,start,[{local,to_stop},?MODULE,[],[]]), + ok = gen_server:stop({to_stop,Node}), + undefined = rpc:call(Node,erlang,whereis,[to_stop]), + false = rpc:call(Node,erlang,is_process_alive,[Pid]), + {'EXIT',noproc} = (catch gen_server:stop({to_stop,Node})), + true = test_server:stop_node(Node), + {'EXIT',{{nodedown,Node},_}} = (catch gen_server:stop({to_stop,Node})), + ok. + +%% Globally registered name on remote node +stop10(_Config) -> + {ok,Node} = test_server:start_node(gen_server_SUITE_stop10,slave,[]), + Dir = filename:dirname(code:which(?MODULE)), + rpc:call(Node,code,add_path,[Dir]), + {ok, Pid} = rpc:call(Node,gen_server,start,[{global,to_stop},?MODULE,[],[]]), + global:sync(), + ok = gen_server:stop({global,to_stop}), + false = rpc:call(Node,erlang,is_process_alive,[Pid]), + {'EXIT',noproc} = (catch gen_server:stop({global,to_stop})), + true = test_server:stop_node(Node), + {'EXIT',noproc} = (catch gen_server:stop({global,to_stop})), + ok. + crash(Config) when is_list(Config) -> ?line error_logger_forwarder:register(), diff --git a/lib/stdlib/test/proc_lib_SUITE.erl b/lib/stdlib/test/proc_lib_SUITE.erl index 8dca69bac4..b6f1973a05 100644 --- a/lib/stdlib/test/proc_lib_SUITE.erl +++ b/lib/stdlib/test/proc_lib_SUITE.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2012. All Rights Reserved. +%% Copyright Ericsson AB 1996-2014. 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 @@ -27,7 +27,7 @@ init_per_group/2,end_per_group/2, crash/1, sync_start_nolink/1, sync_start_link/1, spawn_opt/1, sp1/0, sp2/0, sp3/1, sp4/2, sp5/1, - hibernate/1]). + hibernate/1, stop/1]). -export([ otp_6345/1, init_dont_hang/1]). -export([hib_loop/1, awaken/1]). @@ -38,6 +38,7 @@ -export([otp_6345_init/1, init_dont_hang_init/1]). +-export([system_terminate/4]). -ifdef(STANDALONE). -define(line, noop, ). @@ -49,7 +50,7 @@ suite() -> [{ct_hooks,[ts_install_cth]}]. all() -> [crash, {group, sync_start}, spawn_opt, hibernate, - {group, tickets}]. + {group, tickets}, stop]. groups() -> [{tickets, [], [otp_6345, init_dont_hang]}, @@ -361,10 +362,94 @@ init_dont_hang(Config) when is_list(Config) -> exit(Error) end. -init_dont_hang_init(Parent) -> +init_dont_hang_init(_Parent) -> 1 = 2. +%% Test proc_lib:stop/1,3 +stop(_Config) -> + Parent = self(), + SysMsgProc = + fun() -> + receive + {system,From,Request} -> + sys:handle_system_msg(Request,From,Parent,?MODULE,[],[]) + end + end, + + %% Normal case: + %% Process handles system message and terminated with given reason + Pid1 = proc_lib:spawn(SysMsgProc), + ok = proc_lib:stop(Pid1), + false = erlang:is_process_alive(Pid1), + + %% Process does not exit + {'EXIT',noproc} = (catch proc_lib:stop(Pid1)), + + %% Badly handled system message + DieProc = + fun() -> + receive + {system,_From,_Request} -> + exit(die) + end + end, + Pid2 = proc_lib:spawn(DieProc), + {'EXIT',{die,_}} = (catch proc_lib:stop(Pid2)), + + %% Hanging process => timeout + HangProc = + fun() -> + receive + {system,_From,_Request} -> + timer:sleep(5000) + end + end, + Pid3 = proc_lib:spawn(HangProc), + {'EXIT',timeout} = (catch proc_lib:stop(Pid3,normal,1000)), + + %% Success case with other reason than 'normal' + Pid4 = proc_lib:spawn(SysMsgProc), + ok = proc_lib:stop(Pid4,other_reason,infinity), + false = erlang:is_process_alive(Pid4), + + %% System message is handled, but process dies with other reason + %% than the given (in system_terminate/4 below) + Pid5 = proc_lib:spawn(SysMsgProc), + {'EXIT',{badmatch,2}} = (catch proc_lib:stop(Pid5,crash,infinity)), + false = erlang:is_process_alive(Pid5), + + %% Local registered name + Pid6 = proc_lib:spawn(SysMsgProc), + register(to_stop,Pid6), + ok = proc_lib:stop(to_stop), + undefined = whereis(to_stop), + false = erlang:is_process_alive(Pid6), + + %% Remote registered name + {ok,Node} = test_server:start_node(proc_lib_SUITE_stop,slave,[]), + Dir = filename:dirname(code:which(?MODULE)), + rpc:call(Node,code,add_path,[Dir]), + Pid7 = spawn(Node,SysMsgProc), + true = rpc:call(Node,erlang,register,[to_stop,Pid7]), + Pid7 = rpc:call(Node,erlang,whereis,[to_stop]), + ok = proc_lib:stop({to_stop,Node}), + undefined = rpc:call(Node,erlang,whereis,[to_stop]), + false = rpc:call(Node,erlang,is_process_alive,[Pid7]), + + %% Local and remote registered name, but non-existing + {'EXIT',noproc} = (catch proc_lib:stop(to_stop)), + {'EXIT',noproc} = (catch proc_lib:stop({to_stop,Node})), + + true = test_server:stop_node(Node), + + %% Remote registered name, but non-existing node + {'EXIT',{{nodedown,Node},_}} = (catch proc_lib:stop({to_stop,Node})), + ok. +system_terminate(crash,_Parent,_Deb,_State) -> + 1 = 2; +system_terminate(Reason,_Parent,_Deb,_State) -> + exit(Reason). %%----------------------------------------------------------------- %% The error_logger handler used. diff --git a/lib/stdlib/test/qlc_SUITE.erl b/lib/stdlib/test/qlc_SUITE.erl index 37fbb5267b..4173a40d14 100644 --- a/lib/stdlib/test/qlc_SUITE.erl +++ b/lib/stdlib/test/qlc_SUITE.erl @@ -7891,7 +7891,7 @@ run_test(Config, Extra, {cres, Body, Opts, ExpectedCompileReturn}) -> {module, _} = code:load_abs(AbsFile, Mod), Ms0 = erlang:process_info(self(),messages), - Before = {get(), pps(), ets:all(), Ms0}, + Before = {{get(), ets:all(), Ms0}, pps()}, %% Prepare the check that the qlc module does not call qlc_pt. _ = [unload_pt() || {file, Name} <- [code:is_loaded(qlc_pt)], @@ -7921,12 +7921,29 @@ run_test(Config, Extra, {cres, Body, Opts, ExpectedCompileReturn}) -> run_test(Config, Extra, Body) -> run_test(Config, Extra, {cres,Body,[]}). -wait_for_expected(R, Before, SourceFile, Wait) -> +wait_for_expected(R, {Strict0,PPS0}=Before, SourceFile, Wait) -> Ms = erlang:process_info(self(),messages), - After = {get(), pps(), ets:all(), Ms}, + After = {_,PPS1} = {{get(), ets:all(), Ms}, pps()}, case {R, After} of {ok, Before} -> ok; + {ok, {Strict0,_}} -> + {Ports0,Procs0} = PPS0, + {Ports1,Procs1} = PPS1, + case {Ports1 -- Ports0, Procs1 -- Procs0} of + {[], []} -> ok; + _ when Wait -> + timer:sleep(1000), + wait_for_expected(R, Before, SourceFile, false); + {PortsDiff,ProcsDiff} -> + io:format("failure, got ~p~n, expected ~p\n", + [PPS1, PPS0]), + show("Old port", Ports0 -- Ports1), + show("New port", PortsDiff), + show("Old proc", Procs0 -- Procs1), + show("New proc", ProcsDiff), + fail(SourceFile) + end; _ when Wait -> timer:sleep(1000), wait_for_expected(R, Before, SourceFile, false); @@ -7993,7 +8010,7 @@ compile_file(Config, Test0, Opts0) -> case compile:file(File, Opts) of {ok, _M, Ws} -> warnings(File, Ws); {error, [{File,Es}], []} -> {errors, Es, []}; - {error, [{File,Es}], [{File,Ws}]} -> {error, Es, Ws} + {error, [{File,Es}], [{File,Ws}]} -> {errors, Es, Ws} end. comp_compare(T, T) -> @@ -8058,6 +8075,17 @@ filename(Name, Config) when is_atom(Name) -> filename(Name, Config) -> filename:join(?privdir, Name). +show(_S, []) -> + ok; +show(S, [{Pid, Name, InitCall}|Pids]) when is_pid(Pid) -> + io:format("~s: ~w (~w), ~w: ~p~n", + [S, Pid, proc_reg_name(Name), InitCall, + erlang:process_info(Pid)]), + show(S, Pids); +show(S, [{Port, _}|Ports]) when is_port(Port)-> + io:format("~s: ~w: ~p~n", [S, Port, erlang:port_info(Port)]), + show(S, Ports). + pps() -> {port_list(), process_list()}. @@ -8070,6 +8098,9 @@ process_list() -> safe_second_element(process_info(P, initial_call))} || P <- processes(), is_process_alive(P)]. +proc_reg_name({registered_name, Name}) -> Name; +proc_reg_name([]) -> no_reg_name. + safe_second_element({_,Info}) -> Info; safe_second_element(Other) -> Other. diff --git a/lib/stdlib/test/stdlib_SUITE.erl b/lib/stdlib/test/stdlib_SUITE.erl index 3d09bd27ff..6669a21b9c 100644 --- a/lib/stdlib/test/stdlib_SUITE.erl +++ b/lib/stdlib/test/stdlib_SUITE.erl @@ -22,14 +22,7 @@ -module(stdlib_SUITE). -include_lib("test_server/include/test_server.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]). --export([init_per_testcase/2, end_per_testcase/2]). - -% Test cases must be exported. --export([app_test/1, appup_test/1]). +-compile(export_all). %% %% all/1 @@ -37,10 +30,10 @@ suite() -> [{ct_hooks,[ts_install_cth]}]. all() -> - [app_test, appup_test]. + [app_test, appup_test, {group,upgrade}]. groups() -> - []. + [{upgrade,[minor_upgrade,major_upgrade]}]. init_per_suite(Config) -> Config. @@ -48,9 +41,13 @@ init_per_suite(Config) -> end_per_suite(_Config) -> ok. +init_per_group(upgrade, Config) -> + ct_release_test:init(Config); init_per_group(_GroupName, Config) -> Config. +end_per_group(upgrade, Config) -> + ct_release_test:cleanup(Config); end_per_group(_GroupName, Config) -> Config. @@ -165,3 +162,19 @@ check_appup([Vsn|Vsns],Instrs,Expected) -> end; check_appup([],_,_) -> ok. + + +minor_upgrade(Config) -> + ct_release_test:upgrade(stdlib,minor,{?MODULE,[]},Config). + +major_upgrade(Config) -> + ct_release_test:upgrade(stdlib,major,{?MODULE,[]},Config). + +%% Version numbers are checked by ct_release_test, so there is nothing +%% more to check here... +upgrade_init(State) -> + State. +upgrade_upgraded(State) -> + State. +upgrade_downgraded(State) -> + State. diff --git a/lib/stdlib/test/supervisor_SUITE.erl b/lib/stdlib/test/supervisor_SUITE.erl index 836ea7c030..c98654aef7 100644 --- a/lib/stdlib/test/supervisor_SUITE.erl +++ b/lib/stdlib/test/supervisor_SUITE.erl @@ -37,9 +37,11 @@ sup_start_ignore_child/1, sup_start_ignore_temporary_child/1, sup_start_ignore_temporary_child_start_child/1, sup_start_ignore_temporary_child_start_child_simple/1, - sup_start_error_return/1, sup_start_fail/1, sup_stop_infinity/1, - sup_stop_timeout/1, sup_stop_brutal_kill/1, child_adm/1, - child_adm_simple/1, child_specs/1, extra_return/1]). + sup_start_error_return/1, sup_start_fail/1, + sup_start_map/1, sup_start_map_faulty_specs/1, + sup_stop_infinity/1, sup_stop_timeout/1, sup_stop_brutal_kill/1, + child_adm/1, child_adm_simple/1, child_specs/1, extra_return/1, + sup_flags/1]). %% Tests concept permanent, transient and temporary -export([ permanent_normal/1, transient_normal/1, @@ -65,7 +67,8 @@ do_not_save_child_specs_for_temporary_children/1, simple_one_for_one_scale_many_temporary_children/1, simple_global_supervisor/1, hanging_restart_loop/1, - hanging_restart_loop_simple/1]). + hanging_restart_loop_simple/1, code_change/1, code_change_map/1, + code_change_simple/1, code_change_simple_map/1]). %%------------------------------------------------------------------------- @@ -73,8 +76,8 @@ suite() -> [{ct_hooks,[ts_install_cth]}]. all() -> - [{group, sup_start}, {group, sup_stop}, child_adm, - child_adm_simple, extra_return, child_specs, + [{group, sup_start}, {group, sup_start_map}, {group, sup_stop}, child_adm, + child_adm_simple, extra_return, child_specs, sup_flags, {group, restart_one_for_one}, {group, restart_one_for_all}, {group, restart_simple_one_for_one}, @@ -85,7 +88,8 @@ all() -> count_children, do_not_save_start_parameters_for_temporary_children, do_not_save_child_specs_for_temporary_children, simple_one_for_one_scale_many_temporary_children, temporary_bystander, - simple_global_supervisor, hanging_restart_loop, hanging_restart_loop_simple]. + simple_global_supervisor, hanging_restart_loop, hanging_restart_loop_simple, + code_change, code_change_map, code_change_simple, code_change_simple_map]. groups() -> [{sup_start, [], @@ -94,6 +98,8 @@ groups() -> sup_start_ignore_temporary_child_start_child, sup_start_ignore_temporary_child_start_child_simple, sup_start_error_return, sup_start_fail]}, + {sup_start_map, [], + [sup_start_map, sup_start_map_faulty_specs]}, {sup_stop, [], [sup_stop_infinity, sup_stop_timeout, sup_stop_brutal_kill]}, @@ -256,6 +262,60 @@ sup_start_fail(Config) when is_list(Config) -> check_exit_reason(Term). %%------------------------------------------------------------------------- +%% Tests that the supervisor process starts correctly with map +%% startspec, and that the full childspec can be read. +sup_start_map(Config) when is_list(Config) -> + process_flag(trap_exit, true), + Child1 = #{id=>child1, start=>{supervisor_1, start_child, []}}, + Child2 = #{id=>child2, + start=>{supervisor_1, start_child, []}, + shutdown=>brutal_kill}, + Child3 = #{id=>child3, + start=>{supervisor_1, start_child, []}, + type=>supervisor}, + {ok, Pid} = start_link({ok, {#{}, [Child1,Child2,Child3]}}), + + %% Check default values + {ok,#{id:=child1, + start:={supervisor_1,start_child,[]}, + restart:=permanent, + shutdown:=5000, + type:=worker, + modules:=[supervisor_1]}} = supervisor:get_childspec(Pid, child1), + {ok,#{id:=child2, + start:={supervisor_1,start_child,[]}, + restart:=permanent, + shutdown:=brutal_kill, + type:=worker, + modules:=[supervisor_1]}} = supervisor:get_childspec(Pid, child2), + {ok,#{id:=child3, + start:={supervisor_1,start_child,[]}, + restart:=permanent, + shutdown:=infinity, + type:=supervisor, + modules:=[supervisor_1]}} = supervisor:get_childspec(Pid, child3), + {error,not_found} = supervisor:get_childspec(Pid, child4), + terminate(Pid, shutdown). + +%%------------------------------------------------------------------------- +%% Tests that the supervisor produces good error messages when start- +%% and child specs are faulty. +sup_start_map_faulty_specs(Config) when is_list(Config) -> + process_flag(trap_exit, true), + Child1 = #{start=>{supervisor_1, start_child, []}}, + Child2 = #{id=>child2}, + Child3 = #{id=>child3, + start=>{supervisor_1, start_child, []}, + silly_flag=>true}, + Child4 = child4, + {error,{start_spec,missing_id}} = start_link({ok, {#{}, [Child1]}}), + {error,{start_spec,missing_start}} = start_link({ok, {#{}, [Child2]}}), + {ok,Pid} = start_link({ok, {#{}, [Child3]}}), + terminate(Pid,shutdown), + {error,{start_spec,{invalid_child_spec,child4}}} = + start_link({ok, {#{}, [Child4]}}). + +%%------------------------------------------------------------------------- %% See sup_stop/1 when Shutdown = infinity, this walue is allowed for %% children of type supervisor _AND_ worker. sup_stop_infinity(Config) when is_list(Config) -> @@ -479,7 +539,7 @@ child_adm_simple(Config) when is_list(Config) -> %% Tests child specs, invalid formats should be rejected. child_specs(Config) when is_list(Config) -> process_flag(trap_exit, true), - {ok, _Pid} = start_link({ok, {{one_for_one, 2, 3600}, []}}), + {ok, Pid} = start_link({ok, {{one_for_one, 2, 3600}, []}}), {error, _} = supervisor:start_child(sup_test, hej), %% Bad child specs @@ -509,6 +569,7 @@ child_specs(Config) when is_list(Config) -> {error, {invalid_modules,dy}} = supervisor:start_child(sup_test, B5), + {error, {badarg, _}} = supervisor:check_childspecs(B1), % should be list {error, {invalid_mfa,mfa}} = supervisor:check_childspecs([B1]), {error, {invalid_restart_type,prmanent}} = supervisor:check_childspecs([B2]), @@ -524,6 +585,54 @@ child_specs(Config) when is_list(Config) -> ok = supervisor:check_childspecs([C3]), ok = supervisor:check_childspecs([C4]), ok = supervisor:check_childspecs([C5]), + + {error,{duplicate_child_name,child}} = supervisor:check_childspecs([C1,C2]), + + terminate(Pid, shutdown), + + %% Faulty child specs in supervisor start + {error, {start_spec, {invalid_mfa, mfa}}} = + start_link({ok, {{one_for_one, 2, 3600}, [B1]}}), + {error, {start_spec, {invalid_restart_type, prmanent}}} = + start_link({ok, {{simple_one_for_one, 2, 3600}, [B2]}}), + + %% simple_one_for_one needs exactly one child + {error,{bad_start_spec,[]}} = + start_link({ok, {{simple_one_for_one, 2, 3600}, []}}), + {error,{bad_start_spec,[C1,C2]}} = + start_link({ok, {{simple_one_for_one, 2, 3600}, [C1,C2]}}), + + ok. + +%%------------------------------------------------------------------------- +%% Test error handling of supervisor flags +sup_flags(_Config) -> + process_flag(trap_exit,true), + {error,{supervisor_data,{invalid_strategy,_}}} = + start_link({ok, {{none_for_one, 2, 3600}, []}}), + {error,{supervisor_data,{invalid_strategy,_}}} = + start_link({ok, {#{strategy=>none_for_one}, []}}), + {error,{supervisor_data,{invalid_intensity,_}}} = + start_link({ok, {{one_for_one, infinity, 3600}, []}}), + {error,{supervisor_data,{invalid_intensity,_}}} = + start_link({ok, {#{intensity=>infinity}, []}}), + {error,{supervisor_data,{invalid_period,_}}} = + start_link({ok, {{one_for_one, 2, 0}, []}}), + {error,{supervisor_data,{invalid_period,_}}} = + start_link({ok, {#{period=>0}, []}}), + {error,{supervisor_data,{invalid_period,_}}} = + start_link({ok, {{one_for_one, 2, infinity}, []}}), + {error,{supervisor_data,{invalid_period,_}}} = + start_link({ok, {#{period=>infinity}, []}}), + + %% SupFlags other than a map or a 3-tuple + {error,{supervisor_data,{invalid_type,_}}} = + start_link({ok, {{one_for_one, 2}, []}}), + + %% Unexpected flags are ignored + {ok,Pid} = start_link({ok,{#{silly_flag=>true},[]}}), + terminate(Pid,shutdown), + ok. %%------------------------------------------------------------------------- @@ -1647,6 +1756,186 @@ hanging_restart_loop_simple(Config) when is_list(Config) -> ok. %%------------------------------------------------------------------------- +%% Test the code_change function +code_change(_Config) -> + process_flag(trap_exit, true), + + SupFlags = {one_for_one, 0, 1}, + {ok, Pid} = start_link({ok, {SupFlags, []}}), + [] = supervisor:which_children(Pid), + + %% Change supervisor flags + S1 = sys:get_state(Pid), + ok = fake_upgrade(Pid,{ok, {{one_for_one, 1, 3}, []}}), + S2 = sys:get_state(Pid), + true = (S1 /= S2), + + %% Faulty childspec + FaultyChild = {child1, permanent, brutal_kill, worker, []}, % missing start + {error,{error,{invalid_child_spec,FaultyChild}}} = + fake_upgrade(Pid,{ok,{SupFlags,[FaultyChild]}}), + + %% Add child1 and child2 + Child1 = {child1, {supervisor_1, start_child, []}, + permanent, 2000, worker, []}, + Child2 = {child2, {supervisor_1, start_child, []}, + permanent, brutal_kill, worker, []}, + ok = fake_upgrade(Pid,{ok,{SupFlags,[Child1,Child2]}}), + %% Children are not automatically started + {ok,_} = supervisor:restart_child(Pid,child1), + {ok,_} = supervisor:restart_child(Pid,child2), + [{child2,_,_,_},{child1,_,_,_}] = supervisor:which_children(Pid), + + %% Change child1, remove child2 and add child3 + Child11 = {child1, {supervisor_1, start_child, []}, + permanent, 1000, worker, []}, + Child3 = {child3, {supervisor_1, start_child, []}, + permanent, brutal_kill, worker, []}, + ok = fake_upgrade(Pid,{ok, {SupFlags, [Child11,Child3]}}), + %% Children are not deleted on upgrade, so it is ok that child2 is + %% still here + [{child2,_,_,_},{child3,_,_,_},{child1,_,_,_}] = + supervisor:which_children(Pid), + + %% Ignore during upgrade + ok = fake_upgrade(Pid,ignore), + + %% Error during upgrade + {error, faulty_return} = fake_upgrade(Pid,faulty_return), + + %% Faulty flags + {error,{error, {invalid_intensity,faulty_intensity}}} = + fake_upgrade(Pid,{ok, {{one_for_one,faulty_intensity,1}, []}}), + {error,{error,{bad_flags, faulty_flags}}} = + fake_upgrade(Pid,{ok, {faulty_flags, []}}), + + terminate(Pid,shutdown). + +code_change_map(_Config) -> + process_flag(trap_exit, true), + + {ok, Pid} = start_link({ok, {#{}, []}}), + [] = supervisor:which_children(Pid), + + %% Change supervisor flags + S1 = sys:get_state(Pid), + ok = fake_upgrade(Pid,{ok, {#{intensity=>1, period=>3}, []}}), + S2 = sys:get_state(Pid), + true = (S1 /= S2), + + %% Faulty childspec + FaultyChild = #{id=>faulty_child}, + {error,{error,missing_start}} = + fake_upgrade(Pid,{ok,{#{},[FaultyChild]}}), + + %% Add child1 and child2 + Child1 = #{id=>child1, + start=>{supervisor_1, start_child, []}, + shutdown=>2000}, + Child2 = #{id=>child2, + start=>{supervisor_1, start_child, []}}, + ok = fake_upgrade(Pid,{ok,{#{},[Child1,Child2]}}), + %% Children are not automatically started + {ok,_} = supervisor:restart_child(Pid,child1), + {ok,_} = supervisor:restart_child(Pid,child2), + [{child2,_,_,_},{child1,_,_,_}] = supervisor:which_children(Pid), + {ok,#{shutdown:=2000}} = supervisor:get_childspec(Pid,child1), + + %% Change child1, remove child2 and add child3 + Child11 = #{id=>child1, + start=>{supervisor_1, start_child, []}, + shutdown=>1000}, + Child3 = #{id=>child3, + start=>{supervisor_1, start_child, []}}, + ok = fake_upgrade(Pid,{ok, {#{}, [Child11,Child3]}}), + %% Children are not deleted on upgrade, so it is ok that child2 is + %% still here + [{child2,_,_,_},{child3,_,_,_},{child1,_,_,_}] = + supervisor:which_children(Pid), + {ok,#{shutdown:=1000}} = supervisor:get_childspec(Pid,child1), + + %% Ignore during upgrade + ok = fake_upgrade(Pid,ignore), + + %% Error during upgrade + {error, faulty_return} = fake_upgrade(Pid,faulty_return), + + %% Faulty flags + {error,{error, {invalid_intensity,faulty_intensity}}} = + fake_upgrade(Pid,{ok, {#{intensity=>faulty_intensity}, []}}), + + terminate(Pid,shutdown). + +code_change_simple(_Config) -> + process_flag(trap_exit, true), + + SimpleChild1 = {child1,{supervisor_1, start_child, []}, permanent, + brutal_kill, worker, []}, + SimpleFlags = {simple_one_for_one, 0, 1}, + {ok, SimplePid} = start_link({ok, {SimpleFlags,[SimpleChild1]}}), + %% Change childspec + SimpleChild11 = {child1,{supervisor_1, start_child, []}, permanent, + 1000, worker, []}, + ok = fake_upgrade(SimplePid,{ok,{SimpleFlags,[SimpleChild11]}}), + + %% Attempt to add child + SimpleChild2 = {child2,{supervisor_1, start_child, []}, permanent, + brutal_kill, worker, []}, + + {error, {error, {ok,[_,_]}}} = + fake_upgrade(SimplePid,{ok,{SimpleFlags,[SimpleChild1,SimpleChild2]}}), + + %% Attempt to remove child + {error, {error, {ok,[]}}} = fake_upgrade(SimplePid,{ok,{SimpleFlags,[]}}), + + terminate(SimplePid,shutdown), + ok. + +code_change_simple_map(_Config) -> + process_flag(trap_exit, true), + + SimpleChild1 = #{id=>child1, + start=>{supervisor_1, start_child, []}}, + SimpleFlags = #{strategy=>simple_one_for_one}, + {ok, SimplePid} = start_link({ok, {SimpleFlags,[SimpleChild1]}}), + %% Change childspec + SimpleChild11 = #{id=>child1, + start=>{supervisor_1, start_child, []}, + shutdown=>1000}, + ok = fake_upgrade(SimplePid,{ok,{SimpleFlags,[SimpleChild11]}}), + + %% Attempt to add child + SimpleChild2 = #{id=>child2, + start=>{supervisor_1, start_child, []}}, + {error, {error, {ok, [_,_]}}} = + fake_upgrade(SimplePid,{ok,{SimpleFlags,[SimpleChild1,SimpleChild2]}}), + + %% Attempt to remove child + {error, {error, {ok, []}}} = + fake_upgrade(SimplePid,{ok,{SimpleFlags,[]}}), + + terminate(SimplePid,shutdown), + ok. + +fake_upgrade(Pid,NewInitReturn) -> + ok = sys:suspend(Pid), + + %% Update state to fake code change + %% The #state record in supervisor.erl holds the arguments given + %% to the callback init function. By replacing these arguments the + %% init function will return something new and by that fake a code + %% change (see init function above in this module). + Fun = fun(State) -> + Size = size(State), % 'args' is the last field in #state. + setelement(Size,State,NewInitReturn) + end, + sys:replace_state(Pid,Fun), + + R = sys:change_code(Pid,gen_server,dummy_vsn,[]), + ok = sys:resume(Pid), + R. + +%%------------------------------------------------------------------------- terminate(Pid, Reason) when Reason =/= supervisor -> terminate(dummy, Pid, dummy, Reason). diff --git a/lib/stdlib/test/sys_SUITE.erl b/lib/stdlib/test/sys_SUITE.erl index f38bc87ae5..047ee9f1fa 100644 --- a/lib/stdlib/test/sys_SUITE.erl +++ b/lib/stdlib/test/sys_SUITE.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2013. All Rights Reserved. +%% Copyright Ericsson AB 1996-2014. 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 @@ -202,14 +202,7 @@ spec_proc(Mod) -> {Mod,system_get_state},{throw,fail}},_}} -> ok end, - Mod:stop(), - WaitForUnregister = fun W() -> - case whereis(Mod) of - undefined -> ok; - _ -> timer:sleep(10), W() - end - end, - WaitForUnregister(), + ok = sys:terminate(Mod, normal), {ok,_} = Mod:start_link(4), ok = case catch sys:replace_state(Mod, fun(_) -> {} end) of {} -> @@ -218,8 +211,7 @@ spec_proc(Mod) -> {Mod,system_replace_state},{throw,fail}},_}} -> ok end, - Mod:stop(), - WaitForUnregister(), + ok = sys:terminate(Mod, normal), {ok,_} = Mod:start_link(4), StateFun = fun(_) -> error(fail) end, ok = case catch sys:replace_state(Mod, StateFun) of @@ -231,7 +223,7 @@ spec_proc(Mod) -> {'EXIT',{{callback_failed,StateFun,{error,fail}},_}} -> ok end, - Mod:stop(). + ok = sys:terminate(Mod, normal). %%%%%%%%%%%%%%%%%%%% %% Dummy server diff --git a/lib/stdlib/test/sys_sp1.erl b/lib/stdlib/test/sys_sp1.erl index e84ffcfa12..0fb288991f 100644 --- a/lib/stdlib/test/sys_sp1.erl +++ b/lib/stdlib/test/sys_sp1.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2013. All Rights Reserved. +%% Copyright Ericsson AB 1996-2014. 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 @@ -17,7 +17,7 @@ %% %CopyrightEnd% %% -module(sys_sp1). --export([start_link/1, stop/0]). +-export([start_link/1]). -export([alloc/0, free/1]). -export([init/1]). -export([system_continue/3, system_terminate/4, @@ -31,10 +31,6 @@ start_link(NumCh) -> proc_lib:start_link(?MODULE, init, [[self(),NumCh]]). -stop() -> - ?MODULE ! stop, - ok. - alloc() -> ?MODULE ! {self(), alloc}, receive @@ -70,11 +66,7 @@ loop(Chs, Parent, Deb) -> loop(Chs2, Parent, Deb2); {system, From, Request} -> sys:handle_system_msg(Request, From, Parent, - ?MODULE, Deb, Chs); - stop -> - sys:handle_debug(Deb, fun write_debug/3, - ?MODULE, {in, stop}), - ok + ?MODULE, Deb, Chs) end. system_continue(Parent, Deb, Chs) -> diff --git a/lib/stdlib/test/sys_sp2.erl b/lib/stdlib/test/sys_sp2.erl index 56a5e4d071..a0847b5838 100644 --- a/lib/stdlib/test/sys_sp2.erl +++ b/lib/stdlib/test/sys_sp2.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2013. All Rights Reserved. +%% Copyright Ericsson AB 1996-2014. 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 @@ -17,7 +17,7 @@ %% %CopyrightEnd% %% -module(sys_sp2). --export([start_link/1, stop/0]). +-export([start_link/1]). -export([alloc/0, free/1]). -export([init/1]). -export([system_continue/3, system_terminate/4, @@ -30,10 +30,6 @@ start_link(NumCh) -> proc_lib:start_link(?MODULE, init, [[self(),NumCh]]). -stop() -> - ?MODULE ! stop, - ok. - alloc() -> ?MODULE ! {self(), alloc}, receive @@ -45,11 +41,6 @@ free(Ch) -> ?MODULE ! {free, Ch}, ok. -%% can't use 2-tuple for state here as we do in sys_sp1, since the 2-tuple -%% is not compatible with the backward compatibility handling for -%% sys:get_state in sys.erl --record(state, {alloc,free}). - init([Parent,NumCh]) -> register(?MODULE, self()), Chs = channels(NumCh), @@ -74,11 +65,7 @@ loop(Chs, Parent, Deb) -> loop(Chs2, Parent, Deb2); {system, From, Request} -> sys:handle_system_msg(Request, From, Parent, - ?MODULE, Deb, Chs); - stop -> - sys:handle_debug(Deb, fun write_debug/3, - ?MODULE, {in, stop}), - ok + ?MODULE, Deb, Chs) end. system_continue(Parent, Deb, Chs) -> @@ -91,17 +78,17 @@ write_debug(Dev, Event, Name) -> io:format(Dev, "~p event = ~p~n", [Name, Event]). channels(NumCh) -> - #state{alloc=[], free=lists:seq(1,NumCh)}. + {_Allocated=[], _Free=lists:seq(1,NumCh)}. -alloc(#state{free=[]}=Channels) -> - {{error, "no channels available"}, Channels}; -alloc(#state{alloc=Allocated, free=[H|T]}) -> - {H, #state{alloc=[H|Allocated], free=T}}. +alloc({_, []}) -> + {error, "no channels available"}; +alloc({Allocated, [H|T]}) -> + {H, {[H|Allocated], T}}. -free(Ch, #state{alloc=Alloc, free=Free}=Channels) -> +free(Ch, {Alloc, Free}=Channels) -> case lists:member(Ch, Alloc) of true -> - #state{alloc=lists:delete(Ch, Alloc), free=[Ch|Free]}; + {lists:delete(Ch, Alloc), [Ch|Free]}; false -> Channels end. diff --git a/lib/syntax_tools/src/erl_syntax.erl b/lib/syntax_tools/src/erl_syntax.erl index 40372a2106..de271d7f2f 100644 --- a/lib/syntax_tools/src/erl_syntax.erl +++ b/lib/syntax_tools/src/erl_syntax.erl @@ -3323,6 +3323,11 @@ attribute_arguments(Node) -> [set_pos( list(unfold_function_names(Data, Pos)), Pos)]; + optional_callbacks -> + D = try list(unfold_function_names(Data, Pos)) + catch _:_ -> abstract(Data) + end, + [set_pos(D, Pos)]; import -> {Module, Imports} = Data, [set_pos(atom(Module), Pos), @@ -6135,6 +6140,13 @@ abstract_tail(H, T) -> %% {@link char/1} function to explicitly create an abstract %% character.) %% +%% Note: `arity_qualifier' nodes are recognized. This is to follow The +%% Erlang Parser when it comes to wild attributes: both {F, A} and F/A +%% are recognized, which makes it possible to turn wild attributes +%% into recognized attributes without at the same time making it +%% impossible to compile files using the new syntax with the old +%% version of the Erlang Compiler. +%% %% @see abstract/1 %% @see is_literal/1 %% @see char/1 @@ -6184,6 +6196,20 @@ concrete(Node) -> {value, concrete(F), []} end, [], true), B; + arity_qualifier -> + A = erl_syntax:arity_qualifier_argument(Node), + case erl_syntax:type(A) of + integer -> + F = erl_syntax:arity_qualifier_body(Node), + case erl_syntax:type(F) of + atom -> + {F, A}; + _ -> + erlang:error({badarg, Node}) + end; + _ -> + erlang:error({badarg, Node}) + end; _ -> erlang:error({badarg, Node}) end. diff --git a/lib/tools/emacs/erlang-skels.el b/lib/tools/emacs/erlang-skels.el index 78929ac510..8d2c02e455 100644 --- a/lib/tools/emacs/erlang-skels.el +++ b/lib/tools/emacs/erlang-skels.el @@ -1,7 +1,7 @@ ;; ;; %CopyrightBegin% ;; -;; Copyright Ericsson AB 2010. All Rights Reserved. +;; Copyright Ericsson AB 2010-2014. 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 @@ -352,26 +352,25 @@ Please see the function `tempo-define-template'.") "%% @doc" n "%% Whenever a supervisor is started using supervisor:start_link/[2,3]," n "%% this function is called by the new process to find out about" n - "%% restart strategy, maximum restart frequency and child" n + "%% restart strategy, maximum restart intensity, and child" n "%% specifications." n "%%" n "%% @spec init(Args) -> {ok, {SupFlags, [ChildSpec]}} |" n "%% ignore |" n "%% {error, Reason}" n (erlang-skel-separator-end 2) - "init([]) ->" n> - "RestartStrategy = one_for_one," n> - "MaxRestarts = 1000," n> - "MaxSecondsBetweenRestarts = 3600," n - "" n> - "SupFlags = {RestartStrategy, MaxRestarts, MaxSecondsBetweenRestarts}," n + "init([]) ->" n "" n> - "Restart = permanent," n> - "Shutdown = 2000," n> - "Type = worker," n + "SupFlags = #{strategy => one_for_one," n> + "intensity => 1," n> + "period => 5}," n "" n> - "AChild = {'AName', {'AModule', start_link, []}," n> - "Restart, Shutdown, Type, ['AModule']}," n + "AChild = #{id => 'AName'," n> + "start => {'AModule', start_link, []}," n> + "restart => permanent," n> + "shutdown => 5000," n> + "type => worker," n> + "modules => ['AModule']}," n "" n> "{ok, {SupFlags, [AChild]}}." n n @@ -379,7 +378,7 @@ Please see the function `tempo-define-template'.") "%%% Internal functions" n (erlang-skel-double-separator-end 3) ) - "*The template of an supervisor behaviour. + "*The template of a supervisor behaviour. Please see the function `tempo-define-template'.") (defvar erlang-skel-supervisor-bridge @@ -449,7 +448,7 @@ Please see the function `tempo-define-template'.") "%%% Internal functions" n (erlang-skel-double-separator-end 3) ) - "*The template of an supervisor_bridge behaviour. + "*The template of a supervisor_bridge behaviour. Please see the function `tempo-define-template'.") (defvar erlang-skel-generic-server diff --git a/lib/typer/src/typer.erl b/lib/typer/src/typer.erl index 572bf24ca4..cbad05081e 100644 --- a/lib/typer/src/typer.erl +++ b/lib/typer/src/typer.erl @@ -405,7 +405,7 @@ get_type({{M, F, A} = MFA, Range, Arg}, CodeServer, Records) -> case dialyzer_codeserver:lookup_mfa_contract(MFA, CodeServer) of error -> {{F, A}, {Range, Arg}}; - {ok, {_FileLine, Contract}} -> + {ok, {_FileLine, Contract, _Xtra}} -> Sig = erl_types:t_fun(Arg, Range), case dialyzer_contracts:check_contract(Contract, Sig) of ok -> {{F, A}, {contract, Contract}}; diff --git a/lib/wx/src/wx_object.erl b/lib/wx/src/wx_object.erl index 80f8937656..2c016e7951 100644 --- a/lib/wx/src/wx_object.erl +++ b/lib/wx/src/wx_object.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2008-2011. All Rights Reserved. +%% Copyright Ericsson AB 2008-2014. All Rights Reserved. %% %% The contents of this file are subject to the Erlang Public License, %% Version 1.1, (the "License"); you may not use this file except in @@ -102,6 +102,7 @@ %% API -export([start/3, start/4, start_link/3, start_link/4, + stop/1, stop/3, call/2, call/3, cast/2, reply/2, @@ -215,6 +216,42 @@ gen_response({ok, Pid}) -> gen_response(Reply) -> Reply. +%% @spec (Ref::wxObject()|atom()|pid()) -> ok +%% @doc Stops a generic wx_object server with reason 'normal'. +%% Invokes terminate(Reason,State) in the server. The call waits until +%% the process is terminated. If the process does not exist, an +%% exception is raised. +stop(Ref = #wx_ref{state=Pid}) when is_pid(Pid) -> + try + gen:stop(Pid) + catch _:ExitReason -> + erlang:error({ExitReason, {?MODULE, stop, [Ref]}}) + end; +stop(Name) when is_atom(Name) orelse is_pid(Name) -> + try + gen:stop(Name) + catch _:ExitReason -> + erlang:error({ExitReason, {?MODULE, stop, [Name]}}) + end. + +%% @spec (Ref::wxObject()|atom()|pid(), Reason::term(), Timeout::timeout()) -> ok +%% @doc Stops a generic wx_object server with the given Reason. +%% Invokes terminate(Reason,State) in the server. The call waits until +%% the process is terminated. If the call times out, or if the process +%% does not exist, an exception is raised. +stop(Ref = #wx_ref{state=Pid}, Reason, Timeout) when is_pid(Pid) -> + try + gen:stop(Pid, Reason, Timeout) + catch _:ExitReason -> + erlang:error({ExitReason, {?MODULE, stop, [Ref, Reason, Timeout]}}) + end; +stop(Name, Reason, Timeout) when is_atom(Name) orelse is_pid(Name) -> + try + gen:stop(Name, Reason, Timeout) + catch _:ExitReason -> + erlang:error({ExitReason, {?MODULE, stop, [Name, Reason, Timeout]}}) + end. + %% @spec (Ref::wxObject()|atom()|pid(), Request::term()) -> term() %% @doc Make a call to a wx_object server. %% The call waits until it gets a result. @@ -563,22 +600,10 @@ opt(_, []) -> %% @hidden debug_options(Name, Opts) -> case opt(debug, Opts) of - {ok, Options} -> dbg_options(Name, Options); - _ -> dbg_options(Name, []) + {ok, Options} -> dbg_opts(Name, Options); + _ -> [] end. %% @hidden -dbg_options(Name, []) -> - Opts = - case init:get_argument(generic_debug) of - error -> - []; - _ -> - [log, statistics] - end, - dbg_opts(Name, Opts); -dbg_options(Name, Opts) -> - dbg_opts(Name, Opts). -%% @hidden dbg_opts(Name, Opts) -> case catch sys:debug_options(Opts) of {'EXIT',_} -> diff --git a/lib/wx/test/wx_event_SUITE.erl b/lib/wx/test/wx_event_SUITE.erl index 076f16ba16..2c6c59bb55 100644 --- a/lib/wx/test/wx_event_SUITE.erl +++ b/lib/wx/test/wx_event_SUITE.erl @@ -542,13 +542,14 @@ handler_clean(_Config) -> ?mt(wxFrame, Frame1), wxWindow:show(Frame1), ?m([_|_], lists:sort(wx_test_lib:flush())), - ?m({stop,_}, wx_obj_test:stop(Frame1, fun(_) -> normal end)), + ?m(ok, wx_obj_test:stop(Frame1)), ?m([{terminate,normal}], lists:sort(wx_test_lib:flush())), - Frame2 = wx_obj_test:start([{init, Init}]), + Terminate = fun({Frame,_}) -> wxWindow:destroy(Frame) end, + Frame2 = wx_obj_test:start([{init, Init}, {terminate, Terminate}]), wxWindow:show(Frame2), ?m([_|_], lists:sort(wx_test_lib:flush())), - ?m({stop,_}, wx_obj_test:stop(Frame2, fun(_) -> wxWindow:destroy(Frame2), normal end)), + ?m(ok, wx_obj_test:stop(Frame2)), ?m([{terminate,normal}], lists:sort(wx_test_lib:flush())), timer:sleep(104), ?m({[],[],[]}, white_box_check_event_handlers()), diff --git a/lib/wx/test/wx_obj_test.erl b/lib/wx/test/wx_obj_test.erl index f47f2fbc46..6c648c65f8 100644 --- a/lib/wx/test/wx_obj_test.erl +++ b/lib/wx/test/wx_obj_test.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2011-2013. All Rights Reserved. +%% Copyright Ericsson AB 2011-2014. 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,7 +18,7 @@ -module(wx_obj_test). -include_lib("wx/include/wx.hrl"). --export([start/1, stop/2]). +-export([start/1, stop/1]). %% wx_object callbacks -export([init/1, handle_info/2, terminate/2, code_change/3, handle_call/3, @@ -29,8 +29,8 @@ start(Opts) -> wx_object:start_link(?MODULE, [{parent, self()}| Opts], []). -stop(Object, Fun) -> - wx_object:call(Object, {stop, Fun}). +stop(Object) -> + wx_object:stop(Object). init(Opts) -> Parent = proplists:get_value(parent, Opts), @@ -61,8 +61,6 @@ handle_event(Event, State = #state{parent=Parent}) -> handle_call(What, From, State = #state{user_state=US}) when is_function(What) -> Result = What(US), {reply, {call, Result, From}, State}; -handle_call({stop, Fun}, From, State = #state{user_state=US}) -> - {stop, Fun(US), {stop, From}, State}; handle_call(What, From, State) -> {reply, {call, What, From}, State}. @@ -79,7 +77,13 @@ handle_info(What, State = #state{parent=Pid}) -> Pid ! {info, What}, {noreply, State}. -terminate(What, #state{parent=Pid}) -> +terminate(What, #state{parent=Pid, opts=Opts, user_state=US}) -> + case proplists:get_value(terminate, Opts) of + undefined -> + ok; + Terminate -> + Terminate(US) + end, Pid ! {terminate, What}, ok. |