aboutsummaryrefslogtreecommitdiffstats
path: root/lib/common_test/src
diff options
context:
space:
mode:
Diffstat (limited to 'lib/common_test/src')
-rw-r--r--lib/common_test/src/Makefile13
-rw-r--r--lib/common_test/src/common_test.app.src36
-rw-r--r--lib/common_test/src/ct_config.erl3
-rw-r--r--lib/common_test/src/ct_make.erl7
-rw-r--r--lib/common_test/src/ct_release_test.erl2
-rw-r--r--lib/common_test/src/ct_run.erl4
-rw-r--r--lib/common_test/src/erl2html2.erl311
-rw-r--r--lib/common_test/src/test_server.erl2783
-rw-r--r--lib/common_test/src/test_server_ctrl.erl5692
-rw-r--r--lib/common_test/src/test_server_gl.erl350
-rw-r--r--lib/common_test/src/test_server_internal.hrl60
-rw-r--r--lib/common_test/src/test_server_io.erl452
-rw-r--r--lib/common_test/src/test_server_node.erl766
-rw-r--r--lib/common_test/src/test_server_sup.erl943
14 files changed, 11402 insertions, 20 deletions
diff --git a/lib/common_test/src/Makefile b/lib/common_test/src/Makefile
index 987345c679..91c1e8ede8 100644
--- a/lib/common_test/src/Makefile
+++ b/lib/common_test/src/Makefile
@@ -79,7 +79,15 @@ MODULES= \
cth_conn_log \
ct_groups \
ct_property_test \
- ct_release_test
+ ct_release_test \
+ erl2html2 \
+ test_server_ctrl \
+ test_server_gl \
+ test_server_io \
+ test_server_node \
+ test_server \
+ test_server_sup
+
TARGET_MODULES= $(MODULES:%=$(EBIN)/%)
BEAM_FILES= $(MODULES:%=$(EBIN)/%.$(EMULATOR))
@@ -101,8 +109,7 @@ DTD_FILES = \
# FLAGS
# ----------------------------------------------------
ERL_COMPILE_FLAGS += -pa ../ebin -I../include -I $(ERL_TOP)/lib/snmp/include/ \
- -I../../test_server/include -I../../xmerl/inc/ \
- -I $(ERL_TOP)/lib/kernel/include -Werror
+ -I../../xmerl/inc/ -I $(ERL_TOP)/lib/kernel/include -Werror
# ----------------------------------------------------
# Targets
diff --git a/lib/common_test/src/common_test.app.src b/lib/common_test/src/common_test.app.src
index d847907d75..26bcf00824 100644
--- a/lib/common_test/src/common_test.app.src
+++ b/lib/common_test/src/common_test.app.src
@@ -53,7 +53,13 @@
ct_slave,
cth_log_redirect,
cth_conn_log,
- cth_surefire
+ cth_surefire,
+ erl2html2,
+ test_server_ctrl,
+ test_server,
+ test_server_io,
+ test_server_node,
+ test_server_sup
]},
{registered, [ct_logs,
ct_util_server,
@@ -61,13 +67,27 @@
ct_make_ref,
vts,
ct_master,
- ct_master_logs]},
+ ct_master_logs,
+ test_server_ctrl,
+ test_server,
+ test_server_break_process]},
{applications, [kernel,stdlib]},
{env, []},
- {runtime_dependencies,["xmerl-1.3.8","tools-2.8",
- "test_server-3.9","stdlib-2.5","ssh-4.0",
- "snmp-5.1.2","sasl-2.4.2","runtime_tools-1.8.16",
- "kernel-4.0","inets-6.0","erts-7.0",
- "debugger-4.1","crypto-3.6","compiler-6.0",
- "observer-2.1"]}]}.
+ {runtime_dependencies,
+ ["compiler-6.0",
+ "crypto-3.6",
+ "debugger-4.1",
+ "erts-7.0",
+ "inets-6.0",
+ "kernel-4.0",
+ "observer-2.1",
+ "runtime_tools-1.8.16",
+ "sasl-2.4.2",
+ "snmp-5.1.2",
+ "ssh-4.0",
+ "stdlib-2.5",
+ "syntax_tools-1.7",
+ "tools-2.8",
+ "xmerl-1.3.8"
+ ]}]}.
diff --git a/lib/common_test/src/ct_config.erl b/lib/common_test/src/ct_config.erl
index 251204aa75..33efe7a14a 100644
--- a/lib/common_test/src/ct_config.erl
+++ b/lib/common_test/src/ct_config.erl
@@ -694,11 +694,10 @@ make_crypto_key(String) ->
{[K1,K2,K3],IVec}.
random_bytes(N) ->
- random:seed(os:timestamp()),
random_bytes_1(N, []).
random_bytes_1(0, Acc) -> Acc;
-random_bytes_1(N, Acc) -> random_bytes_1(N-1, [random:uniform(255)|Acc]).
+random_bytes_1(N, Acc) -> random_bytes_1(N-1, [rand:uniform(255)|Acc]).
check_callback_load(Callback) ->
case code:is_loaded(Callback) of
diff --git a/lib/common_test/src/ct_make.erl b/lib/common_test/src/ct_make.erl
index f4b81a0ef6..e7a9cfa843 100644
--- a/lib/common_test/src/ct_make.erl
+++ b/lib/common_test/src/ct_make.erl
@@ -1,7 +1,7 @@
%%
%% %CopyrightBegin%
%%
-%% Copyright Ericsson AB 2009-2013. All Rights Reserved.
+%% Copyright Ericsson AB 2009-2016. All Rights Reserved.
%%
%% Licensed under the Apache License, Version 2.0 (the "License");
%% you may not use this file except in compliance with the License.
@@ -324,10 +324,11 @@ check_includes(File, IncludePath, ObjMTime) ->
end.
check_includes2(Epp, File, ObjMTime) ->
+ A1 = erl_anno:new(1),
case epp:parse_erl_form(Epp) of
- {ok, {attribute, 1, file, {File, 1}}} ->
+ {ok, {attribute, A1, file, {File, A1}}} ->
check_includes2(Epp, File, ObjMTime);
- {ok, {attribute, 1, file, {IncFile, 1}}} ->
+ {ok, {attribute, A1, file, {IncFile, A1}}} ->
case file:read_file_info(IncFile) of
{ok, #file_info{mtime=MTime}} when MTime>ObjMTime ->
epp:close(Epp),
diff --git a/lib/common_test/src/ct_release_test.erl b/lib/common_test/src/ct_release_test.erl
index 5d7e945cc3..6c38f51363 100644
--- a/lib/common_test/src/ct_release_test.erl
+++ b/lib/common_test/src/ct_release_test.erl
@@ -766,7 +766,7 @@ create_relfile(AppsVsns,CreateDir,RelName0,RelVsn) ->
%% 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]),
+ TestToolAppsVsns0 = get_vsns([common_test]),
TestToolAppsVsns =
[{A,V,none} || {A,V} <- TestToolAppsVsns0,
false == lists:keymember(A,1,AllAppsVsns0)],
diff --git a/lib/common_test/src/ct_run.erl b/lib/common_test/src/ct_run.erl
index ceb94ceee5..e156c9b773 100644
--- a/lib/common_test/src/ct_run.erl
+++ b/lib/common_test/src/ct_run.erl
@@ -2634,11 +2634,9 @@ run_make(Targets, TestDir0, Mod, UserInclude) ->
data=TestDir}),
{ok,Cwd} = file:get_cwd(),
ok = file:set_cwd(TestDir),
- TestServerInclude = get_dir(test_server, "include"),
CtInclude = get_dir(common_test, "include"),
XmerlInclude = get_dir(xmerl, "include"),
- ErlFlags = UserInclude ++ [{i,TestServerInclude},
- {i,CtInclude},
+ ErlFlags = UserInclude ++ [{i,CtInclude},
{i,XmerlInclude},
debug_info],
Result =
diff --git a/lib/common_test/src/erl2html2.erl b/lib/common_test/src/erl2html2.erl
new file mode 100644
index 0000000000..d440d0940d
--- /dev/null
+++ b/lib/common_test/src/erl2html2.erl
@@ -0,0 +1,311 @@
+%%
+%% %CopyrightBegin%
+%%
+%% Copyright Ericsson AB 1997-2015. All Rights Reserved.
+%%
+%% Licensed under the Apache License, Version 2.0 (the "License");
+%% you may not use this file except in compliance with the License.
+%% You may obtain a copy of the License at
+%%
+%% http://www.apache.org/licenses/LICENSE-2.0
+%%
+%% Unless required by applicable law or agreed to in writing, software
+%% distributed under the License is distributed on an "AS IS" BASIS,
+%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+%% See the License for the specific language governing permissions and
+%% limitations under the License.
+%%
+%% %CopyrightEnd%
+%%
+
+%%%------------------------------------------------------------------
+%%% Purpose:Convert Erlang files to html.
+%%%------------------------------------------------------------------
+
+-module(erl2html2).
+-export([convert/3, convert/4]).
+
+convert([], _Dest, _InclPath) -> % Fake clause.
+ ok;
+convert(File, Dest, InclPath) ->
+ %% The generated code uses the BGCOLOR attribute in the
+ %% BODY tag, which wasn't valid until HTML 3.2. Also,
+ %% good HTML should either override all colour attributes
+ %% or none of them -- *never* just a few.
+ %%
+ %% FIXME: The colours should *really* be set with
+ %% stylesheets...
+ %%
+ %% The html file is written with the same encoding as the input file.
+ Encoding = encoding(File),
+ Header = ["<!DOCTYPE HTML PUBLIC "
+ "\"-//W3C//DTD HTML 3.2 Final//EN\">\n"
+ "<!-- autogenerated by '",atom_to_list(?MODULE),"'. -->\n"
+ "<html>\n"
+ "<head>\n"
+ "<meta http-equiv=\"Content-Type\" content=\"text/html;"
+ "charset=",html_encoding(Encoding),"\"/></meta>\n"
+ "<title>", to_raw_list(File,Encoding), "</title>\n"
+ "</head>\n\n"
+ "<body bgcolor=\"white\" text=\"black\""
+ " link=\"blue\" vlink=\"purple\" alink=\"red\">\n"],
+ convert(File, Dest, InclPath, Header).
+
+
+convert(File, Dest, InclPath, Header) ->
+ %% statistics(runtime),
+ case parse_file(File, InclPath) of
+ {ok,Functions} ->
+ %% {_, Time1} = statistics(runtime),
+ %% io:format("Parsed file in ~.2f Seconds.~n",[Time1/1000]),
+ case file:open(File,[raw,{read_ahead,10000}]) of
+ {ok,SFd} ->
+ case file:open(Dest,[write,raw]) of
+ {ok,DFd} ->
+ file:write(DFd,[Header,"<pre>\n"]),
+ _Lines = build_html(SFd,DFd,encoding(File),Functions),
+ file:write(DFd,["</pre>\n",footer(),
+ "</body>\n</html>\n"]),
+ %% {_, Time2} = statistics(runtime),
+ %% io:format("Converted ~p lines in ~.2f Seconds.~n",
+ %% [_Lines, Time2/1000]),
+ file:close(SFd),
+ file:close(DFd),
+ ok;
+ Error ->
+ Error
+ end;
+ Error ->
+ Error
+ end;
+ Error ->
+ Error
+ end.
+
+%%%-----------------------------------------------------------------
+%%% Parse the input file to get the line numbers for all function
+%%% definitions. This will be used when creating link targets for each
+%%% function in build_html/5.
+%%%
+%%% All function clauses are also marked in order to allow
+%%% possibly_enhance/2 to write these in bold.
+%%%
+%%% Use expanded preprocessor directives if possible (epp). Only if
+%%% this fails, fall back on using non-expanded code (epp_dodger).
+
+parse_file(File, InclPath) ->
+ case epp:open(File, InclPath, []) of
+ {ok,Epp} ->
+ try parse_preprocessed_file(Epp,File,false) of
+ Forms ->
+ epp:close(Epp),
+ {ok,Forms}
+ catch
+ _:{error,_Reason,true} ->
+ parse_non_preprocessed_file(File);
+ _:{error,_Reason,false} ->
+ {ok,[]}
+ end;
+ Error = {error,_} ->
+ Error
+ end.
+
+parse_preprocessed_file(Epp, File, InCorrectFile) ->
+ case epp:parse_erl_form(Epp) of
+ {ok,Form} ->
+ case Form of
+ {attribute,_,file,{File,_}} ->
+ parse_preprocessed_file(Epp, File, true);
+ {attribute,_,file,{_OtherFile,_}} ->
+ parse_preprocessed_file(Epp, File, false);
+ {function,L,F,A,Cs} when InCorrectFile ->
+ {CLs,LastCL} = find_clause_lines(Cs, []),
+ %% tl(CLs) cause we know the start line already
+ [{atom_to_list(F),A,get_line(L),LastCL} | tl(CLs)] ++
+ parse_preprocessed_file(Epp, File, true);
+ _ ->
+ parse_preprocessed_file(Epp, File, InCorrectFile)
+ end;
+ {error,Reason={_L,epp,{undefined,_Macro,none}}} ->
+ throw({error,Reason,InCorrectFile});
+ {error,_Reason} ->
+ parse_preprocessed_file(Epp, File, InCorrectFile);
+ {eof,_Location} ->
+ []
+ end.
+
+parse_non_preprocessed_file(File) ->
+ case file:open(File, []) of
+ {ok,Epp} ->
+ Forms = parse_non_preprocessed_file(Epp, File, 1),
+ file:close(Epp),
+ {ok,Forms};
+ Error = {error,_E} ->
+ Error
+ end.
+
+parse_non_preprocessed_file(Epp, File, Location) ->
+ case epp_dodger:parse_form(Epp, Location) of
+ {ok,Tree,Location1} ->
+ try erl_syntax:revert(Tree) of
+ {function,L,F,A,Cs} ->
+ {CLs,LastCL} = find_clause_lines(Cs, []),
+ %% tl(CLs) cause we know the start line already
+ [{atom_to_list(F),A,get_line(L),LastCL} | tl(CLs)] ++
+ parse_non_preprocessed_file(Epp, File, Location1);
+ _ ->
+ parse_non_preprocessed_file(Epp, File, Location1)
+ catch
+ _:_ -> parse_non_preprocessed_file(Epp, File, Location1)
+ end;
+ {error,_E,Location1} ->
+ parse_non_preprocessed_file(Epp, File, Location1);
+ {eof,_Location} ->
+ []
+ end.
+
+get_line(Anno) ->
+ erl_anno:line(Anno).
+
+%%%-----------------------------------------------------------------
+%%% Find the line number of the last expression in the function
+find_clause_lines([{clause,CL,_Params,_Op,Exprs}], CLs) -> % last clause
+ case classify_exprs(Exprs) of
+ {anno, Anno} ->
+ {lists:reverse([{clause,get_line(CL)}|CLs]), get_line(Anno)};
+ {tree, Exprs1} ->
+ find_clause_lines([{clause,CL,undefined,undefined,Exprs1}], CLs);
+ unknown ->
+ {lists:reverse([{clause,get_line(CL)}|CLs]), get_line(CL)}
+ end;
+find_clause_lines([{clause,CL,_Params,_Op,_Exprs} | Cs], CLs) ->
+ find_clause_lines(Cs, [{clause,get_line(CL)}|CLs]).
+
+classify_exprs(Exprs) ->
+ case tuple_to_list(lists:last(Exprs)) of
+ [macro,{_var,Anno,_MACRO} | _] ->
+ {anno, Anno};
+ [T,ExprAnno | Exprs1] ->
+ case erl_anno:is_anno(ExprAnno) of
+ true ->
+ {anno, ExprAnno};
+ false when T =:= tree ->
+ {tree, Exprs1};
+ false ->
+ unknown
+ end
+ end.
+
+%%%-----------------------------------------------------------------
+%%% Add a link target for each line and one for each function definition.
+build_html(SFd,DFd,Encoding,FuncsAndCs) ->
+ build_html(SFd,DFd,Encoding,file:read_line(SFd),1,FuncsAndCs,
+ false,undefined).
+
+%% line of last expression in function found
+build_html(SFd,DFd,Enc,{ok,Str},LastL,FuncsAndCs,_IsFuncDef,{F,LastL}) ->
+ LastLineLink = test_server_ctrl:uri_encode(F++"-last_expr",utf8),
+ file:write(DFd,["<a name=\"",
+ to_raw_list(LastLineLink,Enc),"\"/>"]),
+ build_html(SFd,DFd,Enc,{ok,Str},LastL,FuncsAndCs,true,undefined);
+%% function start line found
+build_html(SFd,DFd,Enc,{ok,Str},L0,[{F,A,L0,LastL}|FuncsAndCs],
+ _IsFuncDef,_FAndLastL) ->
+ FALink = test_server_ctrl:uri_encode(F++"-"++integer_to_list(A),utf8),
+ file:write(DFd,["<a name=\"",to_raw_list(FALink,Enc),"\"/>"]),
+ build_html(SFd,DFd,Enc,{ok,Str},L0,FuncsAndCs,true,{F,LastL});
+build_html(SFd,DFd,Enc,{ok,Str},L,[{clause,L}|FuncsAndCs],
+ _IsFuncDef,FAndLastL) ->
+ build_html(SFd,DFd,Enc,{ok,Str},L,FuncsAndCs,true,FAndLastL);
+build_html(SFd,DFd,Enc,{ok,Str},L,FuncsAndCs,IsFuncDef,FAndLastL) ->
+ LStr = line_number(L),
+ Str1 = line(Str,IsFuncDef),
+ file:write(DFd,[LStr,Str1]),
+ build_html(SFd,DFd,Enc,file:read_line(SFd),L+1,FuncsAndCs,false,FAndLastL);
+build_html(_SFd,_DFd,_Enc,eof,L,_FuncsAndCs,_IsFuncDef,_FAndLastL) ->
+ L.
+
+line_number(L) ->
+ LStr = integer_to_list(L),
+ Pred =
+ case length(LStr) of
+ Length when Length < 5 ->
+ lists:duplicate(5-Length,$\s);
+ _ ->
+ []
+ end,
+ ["<a name=\"",LStr,"\"/>",Pred,LStr,": "].
+
+line(Str,IsFuncDef) ->
+ Str1 = htmlize(Str),
+ possibly_enhance(Str1,IsFuncDef).
+
+%%%-----------------------------------------------------------------
+%%% Substitute special characters that should not appear in HTML
+htmlize([$<|Str]) ->
+ [$&,$l,$t,$;|htmlize(Str)];
+htmlize([$>|Str]) ->
+ [$&,$g,$t,$;|htmlize(Str)];
+htmlize([$&|Str]) ->
+ [$&,$a,$m,$p,$;|htmlize(Str)];
+htmlize([$"|Str]) ->
+ [$&,$q,$u,$o,$t,$;|htmlize(Str)];
+htmlize([Ch|Str]) ->
+ [Ch|htmlize(Str)];
+htmlize([]) ->
+ [].
+
+%%%-----------------------------------------------------------------
+%%% Write comments in italic and function definitions in bold.
+possibly_enhance(Str,true) ->
+ case lists:splitwith(fun($() -> false; (_) -> true end, Str) of
+ {_,[]} -> Str;
+ {F,A} -> ["<b>",F,"</b>",A]
+ end;
+possibly_enhance([$%|_]=Str,_) ->
+ ["<i>",Str--"\n","</i>","\n"];
+possibly_enhance([$-|_]=Str,_) ->
+ possibly_enhance(Str,true);
+possibly_enhance(Str,false) ->
+ Str.
+
+%%%-----------------------------------------------------------------
+%%% End of the file
+footer() ->
+ "".
+
+%%%-----------------------------------------------------------------
+%%% Read encoding from source file
+encoding(File) ->
+ case epp:read_encoding(File) of
+ none ->
+ epp:default_encoding();
+ E ->
+ E
+ end.
+
+%%%-----------------------------------------------------------------
+%%% Covert encoding atom to string for use in HTML header
+html_encoding(latin1) ->
+ "iso-8859-1";
+html_encoding(utf8) ->
+ "utf-8".
+
+%%%-----------------------------------------------------------------
+%%% Convert a string to a list of raw printable characters in the
+%%% given encoding. This is necessary since the files (source and
+%%% destination) are both opened in raw mode (default encoding). Byte
+%%% by byte is read from source and written to the destination. This
+%%% conversion is needed when printing data that is not first read
+%%% from the source.
+%%%
+%%% Example: if the encoding of the file is utf8, and we have a string
+%%% containing "å" = [229], then we need to convert this to [195,165]
+%%% before writing. Note that this conversion is only necessary
+%%% because the destination file is not (necessarily) opened with utf8
+%%% encoding - it is opened with default encoding in order to allow
+%%% raw file mode and byte by byte copying from source.
+to_raw_list(X,latin1) when is_list(X) ->
+ X;
+to_raw_list(X,utf8) when is_list(X) ->
+ binary_to_list(unicode:characters_to_binary(X)).
diff --git a/lib/common_test/src/test_server.erl b/lib/common_test/src/test_server.erl
new file mode 100644
index 0000000000..34acad6fd1
--- /dev/null
+++ b/lib/common_test/src/test_server.erl
@@ -0,0 +1,2783 @@
+%%
+%% %CopyrightBegin%
+%%
+%% Copyright Ericsson AB 1996-2016. All Rights Reserved.
+%%
+%% Licensed under the Apache License, Version 2.0 (the "License");
+%% you may not use this file except in compliance with the License.
+%% You may obtain a copy of the License at
+%%
+%% http://www.apache.org/licenses/LICENSE-2.0
+%%
+%% Unless required by applicable law or agreed to in writing, software
+%% distributed under the License is distributed on an "AS IS" BASIS,
+%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+%% See the License for the specific language governing permissions and
+%% limitations under the License.
+%%
+%% %CopyrightEnd%
+-module(test_server).
+
+-define(DEFAULT_TIMETRAP_SECS, 60).
+
+%%% TEST_SERVER_CTRL INTERFACE %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+-export([run_test_case_apply/1,init_target_info/0,init_purify/0]).
+-export([cover_compile/1,cover_analyse/2]).
+
+%%% TEST_SERVER_SUP INTERFACE %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+-export([get_loc/1,set_tc_state/1]).
+
+%%% TEST SUITE INTERFACE %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+-export([lookup_config/2]).
+-export([fail/0,fail/1,format/1,format/2,format/3]).
+-export([capture_start/0,capture_stop/0,capture_get/0]).
+-export([messages_get/0]).
+-export([permit_io/2]).
+-export([hours/1,minutes/1,seconds/1,sleep/1,adjusted_sleep/1,timecall/3]).
+-export([timetrap_scale_factor/0,timetrap/1,get_timetrap_info/0,
+ timetrap_cancel/1,timetrap_cancel/0]).
+-export([m_out_of_n/3,do_times/4,do_times/2]).
+-export([call_crash/3,call_crash/4,call_crash/5]).
+-export([temp_name/1]).
+-export([start_node/3, stop_node/1, wait_for_node/1, is_release_available/1]).
+-export([app_test/1, app_test/2, appup_test/1]).
+-export([is_native/1]).
+-export([comment/1, make_priv_dir/0]).
+-export([os_type/0]).
+-export([run_on_shielded_node/2]).
+-export([is_cover/0,is_debug/0,is_commercial/0]).
+
+-export([break/1,break/2,break/3,continue/0,continue/1]).
+
+%%% DEBUGGER INTERFACE %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+-export([purify_new_leaks/0, purify_format/2, purify_new_fds_inuse/0,
+ purify_is_running/0]).
+
+%%% PRIVATE EXPORTED %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+-export([]).
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+-include("test_server_internal.hrl").
+-include_lib("kernel/include/file.hrl").
+
+init_target_info() ->
+ [$.|Emu] = code:objfile_extension(),
+ {_, OTPRel} = init:script_id(),
+ #target_info{os_family=test_server_sup:get_os_family(),
+ os_type=os:type(),
+ version=erlang:system_info(version),
+ system_version=erlang:system_info(system_version),
+ root_dir=code:root_dir(),
+ emulator=Emu,
+ otp_release=OTPRel,
+ username=test_server_sup:get_username(),
+ cookie=atom_to_list(erlang:get_cookie())}.
+
+init_purify() ->
+ purify_new_leaks().
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% cover_compile(#cover{app=App,incl=Include,excl=Exclude,cross=Cross}) ->
+%% {ok,#cover{mods=AnalyseModules}} | {error,Reason}
+%%
+%% App = atom() , name of application to be compiled
+%% Exclude = [atom()], list of modules to exclude
+%% Include = [atom()], list of modules outside of App that should be included
+%% in the cover compilation
+%% Cross = [atoms()], list of modules outside of App shat should be included
+%% in the cover compilation, but that shall not be part of
+%% the cover analysis for this application.
+%% AnalyseModules = [atom()], list of successfully compiled modules
+%%
+%% Cover compile the given application. Return {ok,CoverInfo} if
+%% compilation succeeds, else (if application is not found and there
+%% are no modules to compile) {error,application_not_found}.
+
+cover_compile(CoverInfo=#cover{app=none,incl=Include,cross=Cross}) ->
+ CrossMods = lists:flatmap(fun({_,M}) -> M end,Cross),
+ CompileMods = Include++CrossMods,
+ case length(CompileMods) of
+ 0 ->
+ io:fwrite("WARNING: No modules to cover compile!\n\n",[]),
+ cover:start(), % start cover server anyway
+ {ok,CoverInfo#cover{mods=[]}};
+ N ->
+ io:fwrite("Cover compiling ~w modules - "
+ "this may take some time... ",[N]),
+ do_cover_compile(CompileMods),
+ io:fwrite("done\n\n",[]),
+ {ok,CoverInfo#cover{mods=Include}}
+ end;
+cover_compile(CoverInfo=#cover{app=App,excl=all,incl=Include,cross=Cross}) ->
+ CrossMods = lists:flatmap(fun({_,M}) -> M end,Cross),
+ CompileMods = Include++CrossMods,
+ case length(CompileMods) of
+ 0 ->
+ io:fwrite("WARNING: No modules to cover compile!\n\n",[]),
+ cover:start(), % start cover server anyway
+ {ok,CoverInfo#cover{mods=[]}};
+ N ->
+ io:fwrite("Cover compiling '~w' (~w files) - "
+ "this may take some time... ",[App,N]),
+ io:format("\nWARNING: All modules in \'~w\' are excluded\n"
+ "Only cover compiling modules in include list "
+ "and the modules\nin the cross cover file:\n"
+ "~tp\n", [App,CompileMods]),
+ do_cover_compile(CompileMods),
+ io:fwrite("done\n\n",[]),
+ {ok,CoverInfo#cover{mods=Include}}
+ end;
+cover_compile(CoverInfo=#cover{app=App,excl=Exclude,
+ incl=Include,cross=Cross}) ->
+ CrossMods = lists:flatmap(fun({_,M}) -> M end,Cross),
+ case code:lib_dir(App) of
+ {error,bad_name} ->
+ case Include++CrossMods of
+ [] ->
+ io:format("\nWARNING: Can't find lib_dir for \'~w\'\n"
+ "Not cover compiling!\n\n",[App]),
+ {error,application_not_found};
+ CompileMods ->
+ io:fwrite("Cover compiling '~w' (~w files) - "
+ "this may take some time... ",
+ [App,length(CompileMods)]),
+ io:format("\nWARNING: Can't find lib_dir for \'~w\'\n"
+ "Only cover compiling modules in include list: "
+ "~tp\n", [App,Include]),
+ do_cover_compile(CompileMods),
+ io:fwrite("done\n\n",[]),
+ {ok,CoverInfo#cover{mods=Include}}
+ end;
+ LibDir ->
+ EbinDir = filename:join([LibDir,"ebin"]),
+ WC = filename:join(EbinDir,"*.beam"),
+ AllMods = module_names(filelib:wildcard(WC)),
+ AnalyseMods = (AllMods ++ Include) -- Exclude,
+ CompileMods = AnalyseMods ++ CrossMods,
+ case length(CompileMods) of
+ 0 ->
+ io:fwrite("WARNING: No modules to cover compile!\n\n",[]),
+ cover:start(), % start cover server anyway
+ {ok,CoverInfo#cover{mods=[]}};
+ N ->
+ io:fwrite("Cover compiling '~w' (~w files) - "
+ "this may take some time... ",[App,N]),
+ do_cover_compile(CompileMods),
+ io:fwrite("done\n\n",[]),
+ {ok,CoverInfo#cover{mods=AnalyseMods}}
+ end
+ end.
+
+
+module_names(Beams) ->
+ [list_to_atom(filename:basename(filename:rootname(Beam))) || Beam <- Beams].
+
+
+do_cover_compile(Modules) ->
+ cover:start(),
+ Sticky = prepare_cover_compile(Modules,[]),
+ R = cover:compile_beam(Modules),
+ [warn_compile(Error) || Error <- R,element(1,Error)=/=ok],
+ [code:stick_mod(M) || M <- Sticky],
+ ok.
+
+warn_compile({error,{Reason,Module}}) ->
+ io:fwrite("\nWARNING: Could not cover compile ~ts: ~p\n",
+ [Module,{error,Reason}]).
+
+%% Make sure all modules are loaded and unstick if sticky
+prepare_cover_compile([M|Ms],Sticky) ->
+ case {code:is_sticky(M),code:is_loaded(M)} of
+ {true,_} ->
+ code:unstick_mod(M),
+ prepare_cover_compile(Ms,[M|Sticky]);
+ {false,false} ->
+ case code:load_file(M) of
+ {module,_} ->
+ prepare_cover_compile([M|Ms],Sticky);
+ Error ->
+ io:fwrite("\nWARNING: Could not load ~w: ~p\n",[M,Error]),
+ prepare_cover_compile(Ms,Sticky)
+ end;
+ {false,_} ->
+ prepare_cover_compile(Ms,Sticky)
+ end;
+prepare_cover_compile([],Sticky) ->
+ Sticky.
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% cover_analyse(Dir,#cover{level=Analyse,mods=Modules,stop=Stop) ->
+%% [{M,{Cov,NotCov,Details}}]
+%%
+%% Dir = string()
+%% Analyse = details | overview
+%% Modules = [atom()], the modules to analyse
+%%
+%% Cover analysis. If Analyse==details analyse_to_file is used.
+%%
+%% If Analyse==overview analyse_to_file is not used, only an overview
+%% containing the number of covered/not covered lines in each module.
+%%
+%% Also, cover data will be exported to a file called all.coverdata in
+%% the given directory.
+%%
+%% Finally, if Stop==true, then cover will be stopped after the
+%% analysis is completed. Stopping cover causes the original (non
+%% cover compiled) modules to be loaded back in. If a process at this
+%% point is still running old code of any of the cover compiled
+%% modules, meaning that is has not done any fully qualified function
+%% call after the cover compilation, the process will now be
+%% killed. To avoid this scenario, it is possible to set Stop=false,
+%% which means that the modules will stay cover compiled. Note that
+%% this is only recommended if the erlang node is being terminated
+%% after the test is completed.
+cover_analyse(Dir,#cover{level=Analyse,mods=Modules,stop=Stop}) ->
+ io:fwrite(user, "Cover analysing... ", []),
+ {ATFOk,ATFFail} =
+ case Analyse of
+ details ->
+ case cover:export(filename:join(Dir,"all.coverdata")) of
+ ok ->
+ {result,Ok1,Fail1} =
+ cover:analyse_to_file(Modules,[{outdir,Dir},html]),
+ {lists:map(fun(OutFile) ->
+ M = list_to_atom(
+ filename:basename(
+ filename:rootname(OutFile,
+ ".COVER.html")
+ )
+ ),
+ {M,{file,OutFile}}
+ end, Ok1),
+ lists:map(fun({Reason,M}) ->
+ {M,{error,Reason}}
+ end, Fail1)};
+ Error ->
+ {[],lists:map(fun(M) -> {M,Error} end, Modules)}
+ end;
+ overview ->
+ case cover:export(filename:join(Dir,"all.coverdata")) of
+ ok ->
+ {[],lists:map(fun(M) -> {M,undefined} end, Modules)};
+ Error ->
+ {[],lists:map(fun(M) -> {M,Error} end, Modules)}
+ end
+ end,
+ {result,AOk,AFail} = cover:analyse(Modules,module),
+ R0 = merge_analysis_results(AOk,ATFOk++ATFFail,[]) ++
+ [{M,{error,Reason}} || {Reason,M} <- AFail],
+ R = lists:sort(R0),
+ io:fwrite(user, "done\n\n", []),
+
+ case Stop of
+ true ->
+ Sticky = unstick_all_sticky(node()),
+ cover:stop(),
+ stick_all_sticky(node(),Sticky);
+ false ->
+ ok
+ end,
+ R.
+
+merge_analysis_results([{M,{Cov,NotCov}}|T],ATF,Acc) ->
+ case lists:keytake(M,1,ATF) of
+ {value,{_,R},ATF1} ->
+ merge_analysis_results(T,ATF1,[{M,{Cov,NotCov,R}}|Acc]);
+ false ->
+ merge_analysis_results(T,ATF,Acc)
+ end;
+merge_analysis_results([],_,Acc) ->
+ Acc.
+
+do_cover_for_node(Node,CoverFunc) ->
+ do_cover_for_node(Node,CoverFunc,true).
+do_cover_for_node(Node,CoverFunc,StickUnstick) ->
+ %% In case a slave node is starting another slave node! I.e. this
+ %% function is executed on a slave node - then the cover function
+ %% must be executed on the master node. This is for instance the
+ %% case in test_server's own tests.
+ MainCoverNode = cover:get_main_node(),
+ Sticky =
+ if StickUnstick -> unstick_all_sticky(MainCoverNode,Node);
+ true -> ok
+ end,
+ rpc:call(MainCoverNode,cover,CoverFunc,[Node]),
+ if StickUnstick -> stick_all_sticky(Node,Sticky);
+ true -> ok
+ end.
+
+unstick_all_sticky(Node) ->
+ unstick_all_sticky(node(),Node).
+unstick_all_sticky(MainCoverNode,Node) ->
+ lists:filter(
+ fun(M) ->
+ case code:is_sticky(M) of
+ true ->
+ rpc:call(Node,code,unstick_mod,[M]),
+ true;
+ false ->
+ false
+ end
+ end,
+ rpc:call(MainCoverNode,cover,modules,[])).
+
+stick_all_sticky(Node,Sticky) ->
+ lists:foreach(
+ fun(M) ->
+ rpc:call(Node,code,stick_mod,[M])
+ end,
+ Sticky).
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% run_test_case_apply(Mod,Func,Args,Name,RunInit,TimetrapData) ->
+%% {Time,Value,Loc,Opts,Comment} | {died,Reason,unknown,Comment}
+%%
+%% Time = float() (seconds)
+%% Value = term()
+%% Loc = term()
+%% Comment = string()
+%% Reason = term()
+%%
+%% Spawns off a process (case process) that actually runs the test suite.
+%% The case process will have the job process as group leader, which makes
+%% it possible to capture all it's output from io:format/2, etc.
+%%
+%% The job process then sits down and waits for news from the case process.
+%%
+%% Returns a tuple with the time spent (in seconds) in the test case,
+%% the return value from the test case or an {'EXIT',Reason} if the case
+%% failed, Loc points out where the test case crashed (if it did). Loc
+%% is either the name of the function, or {<Module>,<Line>} of the last
+%% line executed that had a ?line macro. If the test case did execute
+%% erase/0 or similar, it may be empty. Comment is the last comment added
+%% by test_server:comment/1, the reason if test_server:fail has been
+%% called or the comment given by the return value {comment,Comment} from
+%% a test case.
+%%
+%% {died,Reason,unknown,Comment} is returned if the test case was killed
+%% by some other process. Reason is the kill reason provided.
+%%
+%% TimetrapData = {MultiplyTimetrap,ScaleTimetrap}, which indicates a
+%% possible extension of all timetraps. Timetraps will be multiplied by
+%% MultiplyTimetrap. If it is infinity, no timetraps will be started at all.
+%% ScaleTimetrap indicates if test_server should attemp to automatically
+%% compensate timetraps for runtime delays introduced by e.g. tools like
+%% cover.
+
+run_test_case_apply({CaseNum,Mod,Func,Args,Name,
+ RunInit,TimetrapData}) ->
+ purify_format("Test case #~w ~w:~w/1", [CaseNum, Mod, Func]),
+ case os:getenv("TS_RUN_VALGRIND") of
+ false ->
+ ok;
+ _ ->
+ os:putenv("VALGRIND_LOGFILE_INFIX",atom_to_list(Mod)++"."++
+ atom_to_list(Func)++"-")
+ end,
+ ProcBef = erlang:system_info(process_count),
+ Result = run_test_case_apply(Mod, Func, Args, Name, RunInit,
+ TimetrapData),
+ ProcAft = erlang:system_info(process_count),
+ purify_new_leaks(),
+ DetFail = get(test_server_detected_fail),
+ {Result,DetFail,ProcBef,ProcAft}.
+
+-type tc_status() :: 'starting' | 'running' | 'init_per_testcase' |
+ 'end_per_testcase' | {'framework',atom(),atom()} |
+ 'tc'.
+-record(st,
+ {
+ ref :: reference(),
+ pid :: pid(),
+ mf :: {atom(),atom()},
+ last_known_loc :: term(),
+ status :: tc_status() | 'undefined',
+ ret_val :: term(),
+ comment :: list(char()),
+ timeout :: non_neg_integer() | 'infinity',
+ config :: list() | 'undefined',
+ end_conf_pid :: pid() | 'undefined'
+ }).
+
+run_test_case_apply(Mod, Func, Args, Name, RunInit, TimetrapData) ->
+ print_timestamp(minor,"Started at "),
+ print(minor, "", [], internal_raw),
+ TCCallback = get(test_server_testcase_callback),
+ LogOpts = get(test_server_logopts),
+ Ref = make_ref(),
+ Pid =
+ spawn_link(
+ run_test_case_eval_fun(Mod, Func, Args, Name, Ref,
+ RunInit, TimetrapData,
+ LogOpts, TCCallback)),
+ put(test_server_detected_fail, []),
+ St = #st{ref=Ref,pid=Pid,mf={Mod,Func},last_known_loc=unknown,
+ status=starting,ret_val=[],comment="",timeout=infinity,
+ config=hd(Args)},
+ run_test_case_msgloop(St).
+
+%% Ugly bug (pre R5A):
+%% If this process (group leader of the test case) terminates before
+%% all messages have been replied back to the io server, the io server
+%% hangs. Fixed by the 20 milli timeout check here, and by using monitor in
+%% io.erl.
+%%
+%% A test case is known to have failed if it returns {'EXIT', _} tuple,
+%% or sends a message {failed, File, Line} to it's group_leader
+%%
+run_test_case_msgloop(#st{ref=Ref,pid=Pid,end_conf_pid=EndConfPid0}=St0) ->
+ receive
+ {set_tc_state=Tag,From,{Status,Config0}} ->
+ Config = case Config0 of
+ unknown -> St0#st.config;
+ _ -> Config0
+ end,
+ St = St0#st{status=Status,config=Config},
+ From ! {self(),Tag,ok},
+ run_test_case_msgloop(St);
+ {abort_current_testcase,_,_}=Abort when St0#st.status =:= starting ->
+ %% we're in init phase, must must postpone this operation
+ %% until test case execution is in progress (or FW:init_tc
+ %% gets killed)
+ self() ! Abort,
+ erlang:yield(),
+ run_test_case_msgloop(St0);
+ {abort_current_testcase,Reason,From} ->
+ Line = case is_process_alive(Pid) of
+ true -> get_loc(Pid);
+ false -> unknown
+ end,
+ Mon = erlang:monitor(process, Pid),
+ exit(Pid,{testcase_aborted,Reason,Line}),
+ erlang:yield(),
+ From ! {self(),abort_current_testcase,ok},
+ St = receive
+ {'DOWN', Mon, process, Pid, _} ->
+ St0
+ after 10000 ->
+ %% Pid is probably trapping exits, hit it harder...
+ exit(Pid, kill),
+ %% here's the only place we know Reason, so we save
+ %% it as a comment, potentially replacing user data
+ Error = lists:flatten(io_lib:format("Aborted: ~p",
+ [Reason])),
+ Error1 = lists:flatten([string:strip(S,left) ||
+ S <- string:tokens(Error,
+ [$\n])]),
+ Comment = if length(Error1) > 63 ->
+ string:substr(Error1,1,60) ++ "...";
+ true ->
+ Error1
+ end,
+ St0#st{comment=Comment}
+ end,
+ run_test_case_msgloop(St);
+ {sync_apply,From,MFA} ->
+ do_sync_apply(false,From,MFA),
+ run_test_case_msgloop(St0);
+ {sync_apply_proxy,Proxy,From,MFA} ->
+ do_sync_apply(Proxy,From,MFA),
+ run_test_case_msgloop(St0);
+ {comment,NewComment0} ->
+ NewComment1 = test_server_ctrl:to_string(NewComment0),
+ NewComment = test_server_sup:framework_call(format_comment,
+ [NewComment1],
+ NewComment1),
+ run_test_case_msgloop(St0#st{comment=NewComment});
+ {read_comment,From} ->
+ From ! {self(),read_comment,St0#st.comment},
+ run_test_case_msgloop(St0);
+ {make_priv_dir,From} ->
+ Config = case St0#st.config of
+ undefined -> [];
+ Config0 -> Config0
+ end,
+ Result =
+ case proplists:get_value(priv_dir, Config) of
+ undefined ->
+ {error,no_priv_dir_in_config};
+ PrivDir ->
+ case file:make_dir(PrivDir) of
+ ok ->
+ ok;
+ {error, eexist} ->
+ ok;
+ MkDirError ->
+ {error,{MkDirError,PrivDir}}
+ end
+ end,
+ From ! {self(),make_priv_dir,Result},
+ run_test_case_msgloop(St0);
+ {'EXIT',Pid,{Ref,Time,Value,Loc,Opts}} ->
+ RetVal = {Time/1000000,Value,Loc,Opts},
+ St = setup_termination(RetVal, St0#st{config=undefined}),
+ run_test_case_msgloop(St);
+ {'EXIT',Pid,Reason} ->
+ %% This exit typically happens when an unknown external process
+ %% has caused a test case process to terminate (e.g. if a linked
+ %% process has crashed).
+ St =
+ case Reason of
+ {What,[Loc0={_M,_F,A,[{file,_}|_]}|_]} when
+ is_integer(A) ->
+ Loc = rewrite_loc_item(Loc0),
+ handle_tc_exit(What, St0#st{last_known_loc=[Loc]});
+ {What,[Details,Loc0={_M,_F,A,[{file,_}|_]}|_]} when
+ is_integer(A) ->
+ Loc = rewrite_loc_item(Loc0),
+ handle_tc_exit({What,Details}, St0#st{last_known_loc=[Loc]});
+ _ ->
+ handle_tc_exit(Reason, St0)
+ end,
+ run_test_case_msgloop(St);
+ {EndConfPid0,{call_end_conf,Data,_Result}} ->
+ #st{mf={Mod,Func},config=CurrConf} = St0,
+ case CurrConf of
+ _ when is_list(CurrConf) ->
+ {_Mod,_Func,TCPid,TCExitReason,Loc} = Data,
+ spawn_fw_call(Mod,Func,CurrConf,TCPid,
+ TCExitReason,Loc,self()),
+ St = St0#st{config=undefined,end_conf_pid=undefined},
+ run_test_case_msgloop(St);
+ _ ->
+ run_test_case_msgloop(St0)
+ end;
+ {_FwCallPid,fw_notify_done,{T,Value,Loc,Opts,AddToComment}} ->
+ %% the framework has been notified, we're finished
+ RetVal = {T,Value,Loc,Opts},
+ Comment0 = St0#st.comment,
+ Comment = case AddToComment of
+ undefined ->
+ Comment0;
+ _ ->
+ if Comment0 =:= "" ->
+ AddToComment;
+ true ->
+ Comment0 ++
+ test_server_ctrl:xhtml("<br>",
+ "<br />") ++
+ AddToComment
+ end
+ end,
+ St = setup_termination(RetVal, St0#st{comment=Comment,
+ config=undefined}),
+ run_test_case_msgloop(St);
+ {'EXIT',_FwCallPid,{fw_notify_done,Func,Error}} ->
+ %% a framework function failed
+ CB = os:getenv("TEST_SERVER_FRAMEWORK"),
+ Loc = case CB of
+ FW when FW =:= false; FW =:= "undefined" ->
+ [{test_server,Func}];
+ _ ->
+ [{list_to_atom(CB),Func}]
+ end,
+ RetVal = {died,{framework_error,Loc,Error},Loc},
+ St = setup_termination(RetVal, St0#st{comment="Framework error",
+ config=undefined}),
+ run_test_case_msgloop(St);
+ {failed,File,Line} ->
+ put(test_server_detected_fail,
+ [{File, Line}| get(test_server_detected_fail)]),
+ run_test_case_msgloop(St0);
+
+ {user_timetrap,Pid,_TrapTime,StartTime,E={user_timetrap_error,_},_} ->
+ case update_user_timetraps(Pid, StartTime) of
+ proceed ->
+ self() ! {abort_current_testcase,E,Pid};
+ ignore ->
+ ok
+ end,
+ run_test_case_msgloop(St0);
+ {user_timetrap,Pid,TrapTime,StartTime,ElapsedTime,Scale} ->
+ %% a user timetrap is triggered, ignore it if new
+ %% timetrap has been started since
+ case update_user_timetraps(Pid, StartTime) of
+ proceed ->
+ TotalTime = if is_integer(TrapTime) ->
+ TrapTime + ElapsedTime;
+ true ->
+ TrapTime
+ end,
+ timetrap(TrapTime, TotalTime, Pid, Scale);
+ ignore ->
+ ok
+ end,
+ run_test_case_msgloop(St0);
+ {timetrap_cancel_one,Handle,_From} ->
+ timetrap_cancel_one(Handle, false),
+ run_test_case_msgloop(St0);
+ {timetrap_cancel_all,TCPid,_From} ->
+ timetrap_cancel_all(TCPid, false),
+ run_test_case_msgloop(St0);
+ {get_timetrap_info,From,TCPid} ->
+ Info = get_timetrap_info(TCPid, false),
+ From ! {self(),get_timetrap_info,Info},
+ run_test_case_msgloop(St0);
+ _Other when not is_tuple(_Other) ->
+ %% ignore anything not generated by test server
+ run_test_case_msgloop(St0);
+ _Other when element(1, _Other) /= 'EXIT',
+ element(1, _Other) /= started,
+ element(1, _Other) /= finished,
+ element(1, _Other) /= print ->
+ %% ignore anything not generated by test server
+ run_test_case_msgloop(St0)
+ after St0#st.timeout ->
+ #st{ret_val=RetVal,comment=Comment} = St0,
+ erlang:append_element(RetVal, Comment)
+ end.
+
+setup_termination(RetVal, #st{pid=Pid}=St) ->
+ timetrap_cancel_all(Pid, false),
+ St#st{ret_val=RetVal,timeout=20}.
+
+set_tc_state(State) ->
+ set_tc_state(State,unknown).
+set_tc_state(State, Config) ->
+ tc_supervisor_req(set_tc_state, {State,Config}).
+
+handle_tc_exit(killed, St) ->
+ %% probably the result of an exit(TestCase,kill) call, which is the
+ %% only way to abort a testcase process that traps exits
+ %% (see abort_current_testcase).
+ #st{config=Config,mf={Mod,Func},pid=Pid} = St,
+ Msg = testcase_aborted_or_killed,
+ spawn_fw_call(Mod, Func, Config, Pid, Msg, unknown, self()),
+ St;
+handle_tc_exit({testcase_aborted,{user_timetrap_error,_}=Msg,_}, St) ->
+ #st{config=Config,mf={Mod,Func},pid=Pid} = St,
+ spawn_fw_call(Mod, Func, Config, Pid, Msg, unknown, self()),
+ St;
+handle_tc_exit(Reason, #st{status={framework,FwMod,FwFunc},
+ config=Config,pid=Pid}=St) ->
+ R = case Reason of
+ {timetrap_timeout,TVal,_} ->
+ {timetrap,TVal};
+ {testcase_aborted=E,AbortReason,_} ->
+ {E,AbortReason};
+ {fw_error,{FwMod,FwFunc,FwError}} ->
+ FwError;
+ Other ->
+ Other
+ end,
+ Error = {framework_error,R},
+ spawn_fw_call(FwMod, FwFunc, Config, Pid, Error, unknown, self()),
+ St;
+handle_tc_exit(Reason, #st{status=tc,config=Config0,mf={Mod,Func},pid=Pid}=St)
+ when is_list(Config0) ->
+ {R,Loc1,F} = case Reason of
+ {timetrap_timeout=E,TVal,Loc0} ->
+ {{E,TVal},Loc0,E};
+ {testcase_aborted=E,AbortReason,Loc0} ->
+ Msg = {E,AbortReason},
+ {Msg,Loc0,Msg};
+ Other ->
+ {{'EXIT',Other},unknown,Other}
+ end,
+ Timeout = end_conf_timeout(Reason, St),
+ Config = [{tc_status,{failed,F}}|Config0],
+ EndConfPid = call_end_conf(Mod, Func, Pid, R, Loc1, Config, Timeout),
+ St#st{end_conf_pid=EndConfPid};
+handle_tc_exit(Reason, #st{config=Config,mf={Mod,Func0},pid=Pid,
+ status=Status}=St) ->
+ {R,Loc1} = case Reason of
+ {timetrap_timeout=E,TVal,Loc0} ->
+ {{E,TVal},Loc0};
+ {testcase_aborted=E,AbortReason,Loc0} ->
+ {{E,AbortReason},Loc0};
+ Other ->
+ {{'EXIT',Other},St#st.last_known_loc}
+ end,
+ Func = case Status of
+ init_per_testcase=F -> {F,Func0};
+ end_per_testcase=F -> {F,Func0};
+ _ -> Func0
+ end,
+ spawn_fw_call(Mod, Func, Config, Pid, R, Loc1, self()),
+ St.
+
+end_conf_timeout({timetrap_timeout,Timeout,_}, _) ->
+ Timeout;
+end_conf_timeout(_, #st{config=Config}) when is_list(Config) ->
+ proplists:get_value(default_timeout, Config, ?DEFAULT_TIMETRAP_SECS*1000);
+end_conf_timeout(_, _) ->
+ ?DEFAULT_TIMETRAP_SECS*1000.
+
+call_end_conf(Mod,Func,TCPid,TCExitReason,Loc,Conf,TVal) ->
+ Starter = self(),
+ Data = {Mod,Func,TCPid,TCExitReason,Loc},
+ case erlang:function_exported(Mod,end_per_testcase,2) of
+ false ->
+ spawn_link(fun() ->
+ Starter ! {self(),{call_end_conf,Data,ok}}
+ end);
+ true ->
+ do_call_end_conf(Starter,Mod,Func,Data,TCExitReason,Conf,TVal)
+ end.
+
+do_call_end_conf(Starter,Mod,Func,Data,TCExitReason,Conf,TVal) ->
+ EndConfProc =
+ fun() ->
+ process_flag(trap_exit,true), % to catch timetraps
+ Supervisor = self(),
+ EndConfApply =
+ fun() ->
+ timetrap(TVal),
+ %% We can't handle fails or skips here
+ %% (neither input nor output). The error can
+ %% be read from Conf though (tc_status).
+ EndConf =
+ case do_init_tc_call(Mod,{end_per_testcase,Func},
+ [Conf],
+ {TCExitReason,[Conf]}) of
+ {_,[EPTCInit]} when is_list(EPTCInit) ->
+ EPTCInit;
+ _ ->
+ Conf
+ end,
+ try apply(Mod,end_per_testcase,[Func,EndConf]) of
+ _ -> ok
+ catch
+ _:Error ->
+ timer:sleep(1),
+ print_end_conf_result(Mod,Func,Conf,
+ "crashed",Error)
+ end,
+ Supervisor ! {self(),end_conf}
+ end,
+ Pid = spawn_link(EndConfApply),
+ receive
+ {Pid,end_conf} ->
+ Starter ! {self(),{call_end_conf,Data,ok}};
+ {'EXIT',Pid,Reason} ->
+ print_end_conf_result(Mod,Func,Conf,"failed",Reason),
+ Starter ! {self(),{call_end_conf,Data,{error,Reason}}};
+ {'EXIT',_OtherPid,Reason} ->
+ %% Probably the parent - not much to do about that
+ exit(Reason)
+ end
+ end,
+ spawn_link(EndConfProc).
+
+print_end_conf_result(Mod,Func,Conf,Cause,Error) ->
+ Str2Print =
+ fun(NoHTML) when NoHTML == stdout; NoHTML == major ->
+ io_lib:format("WARNING! "
+ "~w:end_per_testcase(~w, ~tp)"
+ " ~s!\n\tReason: ~tp\n",
+ [Mod,Func,Conf,Cause,Error]);
+ (minor) ->
+ ErrorStr = test_server_ctrl:escape_chars(Error),
+ io_lib:format("WARNING! "
+ "~w:end_per_testcase(~w, ~tp)"
+ " ~s!\n\tReason: ~ts\n",
+ [Mod,Func,Conf,Cause,ErrorStr])
+ end,
+ group_leader() ! {printout,12,Str2Print}.
+
+
+spawn_fw_call(Mod,IPTC={init_per_testcase,Func},CurrConf,Pid,
+ Why,Loc,SendTo) ->
+ FwCall =
+ fun() ->
+ Skip = {skip,{failed,{Mod,init_per_testcase,Why}}},
+ %% if init_per_testcase fails, the test case
+ %% should be skipped
+ try begin do_end_tc_call(Mod,IPTC, {Pid,Skip,[CurrConf]}, Why),
+ do_init_tc_call(Mod,{end_per_testcase,Func},
+ [CurrConf],{ok,[CurrConf]}),
+ do_end_tc_call(Mod,{end_per_testcase,Func},
+ {Pid,Skip,[CurrConf]}, Why) end of
+ _ -> ok
+ catch
+ _:FwEndTCErr ->
+ exit({fw_notify_done,end_tc,FwEndTCErr})
+ end,
+ Time = case Why of
+ {timetrap_timeout,TVal} -> TVal/1000;
+ _ -> died
+ end,
+ group_leader() ! {printout,12,
+ "ERROR! ~w:init_per_testcase(~w, ~p)"
+ " failed!\n\tReason: ~tp\n",
+ [Mod,Func,CurrConf,Why]},
+ %% finished, report back
+ SendTo ! {self(),fw_notify_done,{Time,Skip,Loc,[],undefined}}
+ end,
+ spawn_link(FwCall);
+
+spawn_fw_call(Mod,EPTC={end_per_testcase,Func},EndConf,Pid,
+ Why,_Loc,SendTo) ->
+ FwCall =
+ fun() ->
+ {RetVal,Report} =
+ case proplists:get_value(tc_status, EndConf) of
+ undefined ->
+ E = {failed,{Mod,end_per_testcase,Why}},
+ {E,E};
+ E = {failed,Reason} ->
+ {E,{error,Reason}};
+ Result ->
+ E = {failed,{Mod,end_per_testcase,Why}},
+ {Result,E}
+ end,
+ {Time,Warn} =
+ case Why of
+ {timetrap_timeout,TVal} ->
+ group_leader() !
+ {printout,12,
+ "WARNING! ~w:end_per_testcase(~w, ~p)"
+ " failed!\n\tReason: timetrap timeout"
+ " after ~w ms!\n", [Mod,Func,EndConf,TVal]},
+ W = "<font color=\"red\">"
+ "WARNING: end_per_testcase timed out!</font>",
+ {TVal/1000,W};
+ _ ->
+ group_leader() !
+ {printout,12,
+ "WARNING! ~w:end_per_testcase(~w, ~p)"
+ " failed!\n\tReason: ~tp\n",
+ [Mod,Func,EndConf,Why]},
+ W = "<font color=\"red\">"
+ "WARNING: end_per_testcase failed!</font>",
+ {died,W}
+ end,
+ try do_end_tc_call(Mod,EPTC,{Pid,Report,[EndConf]}, Why) of
+ _ -> ok
+ catch
+ _:FwEndTCErr ->
+ exit({fw_notify_done,end_tc,FwEndTCErr})
+ end,
+ FailLoc = proplists:get_value(tc_fail_loc, EndConf),
+ %% finished, report back (if end_per_testcase fails, a warning
+ %% should be printed as part of the comment)
+ SendTo ! {self(),fw_notify_done,
+ {Time,RetVal,FailLoc,[],Warn}}
+ end,
+ spawn_link(FwCall);
+
+spawn_fw_call(FwMod,FwFunc,_,_Pid,{framework_error,FwError},_,SendTo) ->
+ FwCall =
+ fun() ->
+ test_server_sup:framework_call(report, [framework_error,
+ {{FwMod,FwFunc},
+ FwError}]),
+ Comment =
+ lists:flatten(
+ io_lib:format("<font color=\"red\">"
+ "WARNING! ~w:~w failed!</font>",
+ [FwMod,FwFunc])),
+ %% finished, report back
+ SendTo ! {self(),fw_notify_done,
+ {died,{error,{FwMod,FwFunc,FwError}},
+ {FwMod,FwFunc},[],Comment}}
+ end,
+ spawn_link(FwCall);
+
+spawn_fw_call(Mod,Func,CurrConf,Pid,Error,Loc,SendTo) ->
+ {Func1,EndTCFunc} = case Func of
+ CF when CF == init_per_suite; CF == end_per_suite;
+ CF == init_per_group; CF == end_per_group ->
+ {CF,CF};
+ TC -> {TC,{end_per_testcase,TC}}
+ end,
+ FwCall =
+ fun() ->
+ try fw_error_notify(Mod,Func1,[],
+ Error,Loc) of
+ _ -> ok
+ catch
+ _:FwErrorNotifyErr ->
+ exit({fw_notify_done,error_notification,
+ FwErrorNotifyErr})
+ end,
+ Conf = [{tc_status,{failed,Error}}|CurrConf],
+ try do_end_tc_call(Mod,EndTCFunc,{Pid,Error,[Conf]},Error) of
+ _ -> ok
+ catch
+ _:FwEndTCErr ->
+ exit({fw_notify_done,end_tc,FwEndTCErr})
+ end,
+ %% finished, report back
+ SendTo ! {self(),fw_notify_done,{died,Error,Loc,[],undefined}}
+ end,
+ spawn_link(FwCall).
+
+%% The job proxy process forwards messages between the test case
+%% process on a shielded node (and its descendants) and the job process.
+%%
+%% The job proxy process have to be started by the test-case process
+%% on the shielded node!
+start_job_proxy() ->
+ group_leader(spawn(fun () -> job_proxy_msgloop() end), self()), ok.
+
+%% The io_reply_proxy is not the most satisfying solution but it works...
+io_reply_proxy(ReplyTo) ->
+ receive
+ IoReply when is_tuple(IoReply),
+ element(1, IoReply) == io_reply ->
+ ReplyTo ! IoReply;
+ _ ->
+ io_reply_proxy(ReplyTo)
+ end.
+
+job_proxy_msgloop() ->
+ receive
+
+ %%
+ %% Messages that need intervention by proxy...
+ %%
+
+ %% io stuff ...
+ IoReq when tuple_size(IoReq) >= 2,
+ element(1, IoReq) == io_request ->
+
+ ReplyProxy = spawn(fun () -> io_reply_proxy(element(2, IoReq)) end),
+ group_leader() ! setelement(2, IoReq, ReplyProxy);
+
+ %% test_server stuff...
+ {sync_apply, From, MFA} ->
+ group_leader() ! {sync_apply_proxy, self(), From, MFA};
+ {sync_result_proxy, To, Result} ->
+ To ! {sync_result, Result};
+
+ %%
+ %% Messages that need no intervention by proxy...
+ %%
+ Msg ->
+ group_leader() ! Msg
+ end,
+ job_proxy_msgloop().
+
+-spec run_test_case_eval_fun(_, _, _, _, _, _, _, _, _) ->
+ fun(() -> no_return()).
+run_test_case_eval_fun(Mod, Func, Args, Name, Ref, RunInit,
+ TimetrapData, LogOpts, TCCallback) ->
+ fun () ->
+ run_test_case_eval(Mod, Func, Args, Name, Ref,
+ RunInit, TimetrapData,
+ LogOpts, TCCallback)
+ end.
+
+%% A test case is known to have failed if it returns {'EXIT', _} tuple,
+%% or sends a message {failed, File, Line} to it's group_leader
+
+run_test_case_eval(Mod, Func, Args0, Name, Ref, RunInit,
+ TimetrapData, LogOpts, TCCallback) ->
+ put(test_server_multiply_timetraps, TimetrapData),
+ put(test_server_logopts, LogOpts),
+ Where = [{Mod,Func}],
+ put(test_server_loc, Where),
+
+ FWInitFunc = case RunInit of
+ run_init -> {init_per_testcase,Func};
+ _ -> Func
+ end,
+
+ FWInitResult0 = do_init_tc_call(Mod,FWInitFunc,Args0,{ok,Args0}),
+
+ set_tc_state(running),
+ {{Time,Value},Loc,Opts} =
+ case FWInitResult0 of
+ {ok,Args} ->
+ run_test_case_eval1(Mod, Func, Args, Name, RunInit, TCCallback);
+ Error = {error,_Reason} ->
+ NewResult = do_end_tc_call(Mod,FWInitFunc, {Error,Args0},
+ {auto_skip,{failed,Error}}),
+ {{0,NewResult},Where,[]};
+ {fail,Reason} ->
+ Conf = [{tc_status,{failed,Reason}} | hd(Args0)],
+ fw_error_notify(Mod, Func, Conf, Reason),
+ NewResult = do_end_tc_call(Mod,FWInitFunc,
+ {{error,Reason},[Conf]},
+ {fail,Reason}),
+ {{0,NewResult},Where,[]};
+ Skip = {SkipType,_Reason} when SkipType == skip;
+ SkipType == skipped ->
+ NewResult = do_end_tc_call(Mod,FWInitFunc,
+ {Skip,Args0}, Skip),
+ {{0,NewResult},Where,[]};
+ AutoSkip = {auto_skip,_Reason} ->
+ %% special case where a conf case "pretends" to be skipped
+ NewResult =
+ do_end_tc_call(Mod,FWInitFunc, {AutoSkip,Args0}, AutoSkip),
+ {{0,NewResult},Where,[]}
+ end,
+ exit({Ref,Time,Value,Loc,Opts}).
+
+run_test_case_eval1(Mod, Func, Args, Name, RunInit, TCCallback) ->
+ case RunInit of
+ run_init ->
+ set_tc_state(init_per_testcase, hd(Args)),
+ ensure_timetrap(Args),
+ case init_per_testcase(Mod, Func, Args) of
+ Skip = {SkipType,Reason} when SkipType == skip;
+ SkipType == skipped ->
+ Line = get_loc(),
+ Conf = [{tc_status,{skipped,Reason}}|hd(Args)],
+ NewRes = do_end_tc_call(Mod,{init_per_testcase,Func},
+ {Skip,[Conf]}, Skip),
+ {{0,NewRes},Line,[]};
+ {skip_and_save,Reason,SaveCfg} ->
+ Line = get_loc(),
+ Conf = [{tc_status,{skipped,Reason}},
+ {save_config,SaveCfg}|hd(Args)],
+ NewRes = do_end_tc_call(Mod,{init_per_testcase,Func},
+ {{skip,Reason},[Conf]},
+ {skip,Reason}),
+ {{0,NewRes},Line,[]};
+ FailTC = {fail,Reason} -> % user fails the testcase
+ EndConf = [{tc_status,{failed,Reason}} | hd(Args)],
+ fw_error_notify(Mod, Func, EndConf, Reason),
+ NewRes = do_end_tc_call(Mod,{init_per_testcase,Func},
+ {{error,Reason},[EndConf]},
+ FailTC),
+ {{0,NewRes},[{Mod,Func}],[]};
+ {ok,NewConf} ->
+ IPTCEndRes = do_end_tc_call(Mod,{init_per_testcase,Func},
+ {ok,[NewConf]}, NewConf),
+ {{T,Return},Loc,NewConf1} =
+ if not is_list(IPTCEndRes) ->
+ %% received skip or fail, not config
+ {{0,IPTCEndRes},undefined,NewConf};
+ true ->
+ %% call user callback function if defined
+ NewConfUC =
+ user_callback(TCCallback, Mod, Func,
+ init, IPTCEndRes),
+ %% save current state in controller loop
+ set_tc_state(tc, NewConfUC),
+ %% execute the test case
+ {ts_tc(Mod,Func,[NewConfUC]),get_loc(),NewConfUC}
+ end,
+ {EndConf,TSReturn,FWReturn} =
+ case Return of
+ {E,TCError} when E=='EXIT' ; E==failed ->
+ fw_error_notify(Mod, Func, NewConf1,
+ TCError, Loc),
+ {[{tc_status,{failed,TCError}},
+ {tc_fail_loc,Loc}|NewConf1],
+ Return,{error,TCError}};
+ SaveCfg={save_config,_} ->
+ {[{tc_status,ok},SaveCfg|NewConf1],Return,ok};
+ {skip_and_save,Why,SaveCfg} ->
+ Skip = {skip,Why},
+ {[{tc_status,{skipped,Why}},
+ {save_config,SaveCfg}|NewConf1],
+ Skip,Skip};
+ {SkipType,Why} when SkipType == skip;
+ SkipType == skipped ->
+ {[{tc_status,{skipped,Why}}|NewConf1],Return,
+ Return};
+ _ ->
+ {[{tc_status,ok}|NewConf1],Return,ok}
+ end,
+ %% call user callback function if defined
+ EndConf1 =
+ user_callback(TCCallback, Mod, Func, 'end', EndConf),
+
+ %% We can't handle fails or skips here
+ EndConf2 =
+ case do_init_tc_call(Mod,{end_per_testcase,Func},
+ [EndConf1],{ok,[EndConf1]}) of
+ {ok,[EPTCInitRes]} when is_list(EPTCInitRes) ->
+ EPTCInitRes;
+ _ ->
+ EndConf1
+ end,
+
+ %% update current state in controller loop
+ {FWReturn1,TSReturn1,EndConf3} =
+ case end_per_testcase(Mod, Func, EndConf2) of
+ SaveCfg1={save_config,_} ->
+ {FWReturn,TSReturn,
+ [SaveCfg1|lists:keydelete(save_config,1,
+ EndConf2)]};
+ {fail,ReasonToFail} ->
+ %% user has failed the testcase
+ fw_error_notify(Mod, Func, EndConf2,
+ ReasonToFail),
+ {{error,ReasonToFail},
+ {failed,ReasonToFail},
+ EndConf2};
+ {failed,{_,end_per_testcase,_}} = Failure when
+ FWReturn == ok ->
+ %% unexpected termination in end_per_testcase
+ %% report this as the result to the framework
+ {Failure,TSReturn,EndConf2};
+ _ ->
+ %% test case result should be reported to
+ %% framework no matter the status of
+ %% end_per_testcase
+ {FWReturn,TSReturn,EndConf2}
+ end,
+ %% clear current state in controller loop
+ case do_end_tc_call(Mod,{end_per_testcase,Func},
+ {FWReturn1,[EndConf3]}, TSReturn1) of
+ {failed,Reason} = NewReturn ->
+ fw_error_notify(Mod,Func,EndConf3, Reason),
+ {{T,NewReturn},[{Mod,Func}],[]};
+ NewReturn ->
+ {{T,NewReturn},Loc,[]}
+ end
+ end;
+ skip_init ->
+ set_tc_state(running, hd(Args)),
+ %% call user callback function if defined
+ Args1 = user_callback(TCCallback, Mod, Func, init, Args),
+ ensure_timetrap(Args1),
+ %% ts_tc does a catch
+ %% if this is a named conf group, the test case (init or end conf)
+ %% should be called with the name as the first argument
+ Args2 = if Name == undefined -> Args1;
+ true -> [Name | Args1]
+ end,
+ %% execute the conf test case
+ {{T,Return},Loc} = {ts_tc(Mod, Func, Args2),get_loc()},
+ %% call user callback function if defined
+ Return1 = user_callback(TCCallback, Mod, Func, 'end', Return),
+ {Return2,Opts} = process_return_val([Return1], Mod, Func,
+ Args1, [{Mod,Func}], Return1),
+ {{T,Return2},Loc,Opts}
+ end.
+
+do_init_tc_call(Mod, Func, Res, Return) ->
+ test_server_sup:framework_call(init_tc,[Mod,Func,Res],Return).
+
+do_end_tc_call(Mod, IPTC={init_per_testcase,Func}, Res, Return) ->
+ case Return of
+ {NOk,_} when NOk == auto_skip; NOk == fail;
+ NOk == skip ; NOk == skipped ->
+ {_,Args} = Res,
+ IPTCEndRes =
+ case do_end_tc_call1(Mod, IPTC, Res, Return) of
+ IPTCEndConfig when is_list(IPTCEndConfig) ->
+ IPTCEndConfig;
+ _ ->
+ Args
+ end,
+ EPTCInitRes =
+ case do_init_tc_call(Mod,{end_per_testcase,Func},
+ IPTCEndRes,Return) of
+ {ok,EPTCInitConfig} when is_list(EPTCInitConfig) ->
+ {Return,EPTCInitConfig};
+ _ ->
+ Return
+ end,
+ do_end_tc_call1(Mod, {end_per_testcase,Func},
+ EPTCInitRes, Return);
+ _Ok ->
+ do_end_tc_call1(Mod, IPTC, Res, Return)
+ end;
+do_end_tc_call(Mod, Func, Res, Return) ->
+ do_end_tc_call1(Mod, Func, Res, Return).
+
+do_end_tc_call1(Mod, Func, Res, Return) ->
+ FwMod = os:getenv("TEST_SERVER_FRAMEWORK"),
+ Ref = make_ref(),
+ if FwMod == "ct_framework" ; FwMod == "undefined"; FwMod == false ->
+ case test_server_sup:framework_call(
+ end_tc, [Mod,Func,Res, Return], ok) of
+ {fail,FWReason} ->
+ {failed,FWReason};
+ ok ->
+ case Return of
+ {fail,Reason} ->
+ {failed,Reason};
+ Return ->
+ Return
+ end;
+ NewReturn ->
+ NewReturn
+ end;
+ true ->
+ case test_server_sup:framework_call(FwMod, end_tc,
+ [Mod,Func,Res], Ref) of
+ {fail,FWReason} ->
+ {failed,FWReason};
+ _Else ->
+ Return
+ end
+ end.
+
+%% the return value is a list and we have to check if it contains
+%% the result of an end conf case or if it's a Config list
+process_return_val([Return], M,F,A, Loc, Final) when is_list(Return) ->
+ ReturnTags = [skip,skip_and_save,save_config,comment,return_group_result],
+ %% check if all elements in the list are valid end conf return value tuples
+ case lists:all(fun(Val) when is_tuple(Val) ->
+ lists:any(fun(T) -> T == element(1, Val) end,
+ ReturnTags);
+ (ok) ->
+ true;
+ (_) ->
+ false
+ end, Return) of
+ true -> % must be return value from end conf case
+ process_return_val1(Return, M,F,A, Loc, Final, []);
+ false -> % must be Config value from init conf case
+ case do_end_tc_call(M, F, {ok,A}, Return) of
+ {failed, FWReason} = Failed ->
+ fw_error_notify(M,F,A, FWReason),
+ {Failed, []};
+ NewReturn ->
+ {NewReturn, []}
+ end
+ end;
+%% the return value is not a list, so it's the return value from an
+%% end conf case or it's a dummy value that can be ignored
+process_return_val(Return, M,F,A, Loc, Final) ->
+ process_return_val1(Return, M,F,A, Loc, Final, []).
+
+process_return_val1([Failed={E,TCError}|_], M,F,A=[Args], Loc, _, SaveOpts)
+ when E=='EXIT';
+ E==failed ->
+ fw_error_notify(M,F,A, TCError, Loc),
+ case do_end_tc_call(M,F, {{error,TCError},
+ [[{tc_status,{failed,TCError}}|Args]]},
+ Failed) of
+ {failed,FWReason} ->
+ {{failed,FWReason},SaveOpts};
+ NewReturn ->
+ {NewReturn,SaveOpts}
+ end;
+process_return_val1([SaveCfg={save_config,_}|Opts], M,F,[Args],
+ Loc, Final, SaveOpts) ->
+ process_return_val1(Opts, M,F,[[SaveCfg|Args]], Loc, Final, SaveOpts);
+process_return_val1([{skip_and_save,Why,SaveCfg}|Opts], M,F,[Args],
+ Loc, _, SaveOpts) ->
+ process_return_val1(Opts, M,F,[[{save_config,SaveCfg}|Args]],
+ Loc, {skip,Why}, SaveOpts);
+process_return_val1([GR={return_group_result,_}|Opts], M,F,A,
+ Loc, Final, SaveOpts) ->
+ process_return_val1(Opts, M,F,A, Loc, Final, [GR|SaveOpts]);
+process_return_val1([RetVal={Tag,_}|Opts], M,F,A,
+ Loc, _, SaveOpts) when Tag==skip;
+ Tag==comment ->
+ process_return_val1(Opts, M,F,A, Loc, RetVal, SaveOpts);
+process_return_val1([_|Opts], M,F,A, Loc, Final, SaveOpts) ->
+ process_return_val1(Opts, M,F,A, Loc, Final, SaveOpts);
+process_return_val1([], M,F,A, _Loc, Final, SaveOpts) ->
+ case do_end_tc_call(M,F, {Final,A}, Final) of
+ {failed,FWReason} ->
+ {{failed,FWReason},SaveOpts};
+ NewReturn ->
+ {NewReturn,lists:reverse(SaveOpts)}
+ end.
+
+user_callback(undefined, _, _, _, Args) ->
+ Args;
+user_callback({CBMod,CBFunc}, Mod, Func, InitOrEnd,
+ [Args]) when is_list(Args) ->
+ case catch apply(CBMod, CBFunc, [InitOrEnd,Mod,Func,Args]) of
+ Args1 when is_list(Args1) ->
+ [Args1];
+ _ ->
+ [Args]
+ end;
+user_callback({CBMod,CBFunc}, Mod, Func, InitOrEnd, Args) ->
+ case catch apply(CBMod, CBFunc, [InitOrEnd,Mod,Func,Args]) of
+ Args1 when is_list(Args1) ->
+ Args1;
+ _ ->
+ Args
+ end.
+
+init_per_testcase(Mod, Func, Args) ->
+ case code:is_loaded(Mod) of
+ false -> code:load_file(Mod);
+ _ -> ok
+ end,
+ case erlang:function_exported(Mod, init_per_testcase, 2) of
+ true ->
+ do_init_per_testcase(Mod, [Func|Args]);
+ false ->
+ %% Optional init_per_testcase is not defined -- keep quiet.
+ [Config] = Args,
+ {ok, Config}
+ end.
+
+do_init_per_testcase(Mod, Args) ->
+ try apply(Mod, init_per_testcase, Args) of
+ {Skip,Reason} when Skip =:= skip; Skip =:= skipped ->
+ {skip,Reason};
+ {skip_and_save,_,_}=Res ->
+ Res;
+ NewConf when is_list(NewConf) ->
+ case lists:filter(fun(T) when is_tuple(T) -> false;
+ (_) -> true end, NewConf) of
+ [] ->
+ {ok,NewConf};
+ Bad ->
+ group_leader() ! {printout,12,
+ "ERROR! init_per_testcase has returned "
+ "bad elements in Config: ~tp\n",[Bad]},
+ {skip,{failed,{Mod,init_per_testcase,bad_return}}}
+ end;
+ {fail,_Reason}=Res ->
+ Res;
+ _Other ->
+ group_leader() ! {printout,12,
+ "ERROR! init_per_testcase did not return "
+ "a Config list.\n",[]},
+ {skip,{failed,{Mod,init_per_testcase,bad_return}}}
+ catch
+ throw:{Skip,Reason} when Skip =:= skip; Skip =:= skipped ->
+ {skip,Reason};
+ exit:{Skip,Reason} when Skip =:= skip; Skip =:= skipped ->
+ {skip,Reason};
+ throw:Other ->
+ set_loc(erlang:get_stacktrace()),
+ Line = get_loc(),
+ print_init_conf_result(Line,"thrown",Other),
+ {skip,{failed,{Mod,init_per_testcase,Other}}};
+ _:Reason0 ->
+ Stk = erlang:get_stacktrace(),
+ Reason = {Reason0,Stk},
+ set_loc(Stk),
+ Line = get_loc(),
+ print_init_conf_result(Line,"crashed",Reason),
+ {skip,{failed,{Mod,init_per_testcase,Reason}}}
+ end.
+
+print_init_conf_result(Line,Cause,Reason) ->
+ FormattedLoc = test_server_sup:format_loc(Line),
+ Str2Print =
+ fun(NoHTML) when NoHTML == stdout; NoHTML == major ->
+ io_lib:format("ERROR! init_per_testcase ~s!\n"
+ "\tLocation: ~p\n\tReason: ~tp\n",
+ [Cause,Line,Reason]);
+ (minor) ->
+ ReasonStr = test_server_ctrl:escape_chars(Reason),
+ io_lib:format("ERROR! init_per_testcase ~s!\n"
+ "\tLocation: ~ts\n\tReason: ~ts\n",
+ [Cause,FormattedLoc,ReasonStr])
+ end,
+ group_leader() ! {printout,12,Str2Print}.
+
+
+end_per_testcase(Mod, Func, Conf) ->
+ case erlang:function_exported(Mod,end_per_testcase,2) of
+ true ->
+ do_end_per_testcase(Mod,end_per_testcase,Func,Conf);
+ false ->
+ %% Backwards compatibility!
+ case erlang:function_exported(Mod,fin_per_testcase,2) of
+ true ->
+ do_end_per_testcase(Mod,fin_per_testcase,Func,Conf);
+ false ->
+ ok
+ end
+ end.
+
+do_end_per_testcase(Mod,EndFunc,Func,Conf) ->
+ set_tc_state(end_per_testcase, Conf),
+ try Mod:EndFunc(Func, Conf) of
+ {save_config,_}=SaveCfg ->
+ SaveCfg;
+ {fail,_}=Fail ->
+ Fail;
+ _ ->
+ ok
+ catch
+ throw:Other ->
+ Comment0 = case read_comment() of
+ "" -> "";
+ Cmt -> Cmt ++ test_server_ctrl:xhtml("<br>",
+ "<br />")
+ end,
+ set_loc(erlang:get_stacktrace()),
+ comment(io_lib:format("~ts<font color=\"red\">"
+ "WARNING: ~w thrown!"
+ "</font>\n",[Comment0,EndFunc])),
+ print_end_tc_warning(EndFunc,Other,"thrown",get_loc()),
+ {failed,{Mod,end_per_testcase,Other}};
+ Class:Reason ->
+ Stk = erlang:get_stacktrace(),
+ set_loc(Stk),
+ Why = case Class of
+ exit -> {'EXIT',Reason};
+ error -> {'EXIT',{Reason,Stk}}
+ end,
+ Comment0 = case read_comment() of
+ "" -> "";
+ Cmt -> Cmt ++ test_server_ctrl:xhtml("<br>",
+ "<br />")
+ end,
+ comment(io_lib:format("~ts<font color=\"red\">"
+ "WARNING: ~w crashed!"
+ "</font>\n",[Comment0,EndFunc])),
+ print_end_tc_warning(EndFunc,Reason,"crashed",get_loc()),
+ {failed,{Mod,end_per_testcase,Why}}
+ end.
+
+print_end_tc_warning(EndFunc,Reason,Cause,Loc) ->
+ FormattedLoc = test_server_sup:format_loc(Loc),
+ Str2Print =
+ fun(NoHTML) when NoHTML == stdout; NoHTML == major ->
+ io_lib:format("WARNING: ~w ~s!\n"
+ "Reason: ~tp\nLine: ~p\n",
+ [EndFunc,Cause,Reason,Loc]);
+ (minor) ->
+ ReasonStr = test_server_ctrl:escape_chars(Reason),
+ io_lib:format("WARNING: ~w ~s!\n"
+ "Reason: ~ts\nLine: ~ts\n",
+ [EndFunc,Cause,ReasonStr,FormattedLoc])
+ end,
+ group_leader() ! {printout,12,Str2Print}.
+
+get_loc() ->
+ get(test_server_loc).
+
+get_loc(Pid) ->
+ [{current_stacktrace,Stk0},{dictionary,Dict}] =
+ process_info(Pid, [current_stacktrace,dictionary]),
+ lists:foreach(fun({Key,Val}) -> put(Key, Val) end, Dict),
+ Stk = [rewrite_loc_item(Loc) || Loc <- Stk0],
+ case get(test_server_loc) of
+ [{Suite,Case}] ->
+ %% Location info unknown, check if {Suite,Case,Line}
+ %% is available in stacktrace and if so, use stacktrace
+ %% instead of current test_server_loc.
+ %% If location is the last expression in a test case
+ %% function, the info is not available due to tail call
+ %% elimination. We need to check if the test case has been
+ %% called by ts_tc/3 and, if so, insert the test case info
+ %% at that position.
+ case [match || {S,C,_L} <- Stk, S == Suite, C == Case] of
+ [match|_] ->
+ put(test_server_loc, Stk);
+ _ ->
+ {PreTC,PostTC} =
+ lists:splitwith(fun({test_server,ts_tc,_}) ->
+ false;
+ (_) ->
+ true
+ end, Stk),
+ if PostTC == [] ->
+ ok;
+ true ->
+ put(test_server_loc,
+ PreTC++[{Suite,Case,last_expr} | PostTC])
+ end
+ end;
+ _ ->
+ put(test_server_loc, Stk)
+ end,
+ get_loc().
+
+fw_error_notify(Mod, Func, Args, Error) ->
+ test_server_sup:framework_call(error_notification,
+ [Mod,Func,[Args],
+ {Error,unknown}]).
+fw_error_notify(Mod, Func, Args, Error, Loc) ->
+ test_server_sup:framework_call(error_notification,
+ [Mod,Func,[Args],
+ {Error,Loc}]).
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% print(Detail,Format,Args,Printer) -> ok
+%% Detail = integer()
+%% Format = string()
+%% Args = [term()]
+%%
+%% Just like io:format, except that depending on the Detail value, the output
+%% is directed to console, major and/or minor log files.
+
+%% print(Detail,Format,Args) ->
+%% test_server_ctrl:print(Detail, Format, Args).
+
+print(Detail,Format,Args,Printer) ->
+ test_server_ctrl:print(Detail, Format, Args, Printer).
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% print_timsteamp(Detail,Leader) -> ok
+%%
+%% Prints Leader followed by a time stamp (date and time). Depending on
+%% the Detail value, the output is directed to console, major and/or minor
+%% log files.
+
+print_timestamp(Detail,Leader) ->
+ test_server_ctrl:print_timestamp(Detail, Leader).
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% lookup_config(Key,Config) -> {value,{Key,Value}} | undefined
+%% Key = term()
+%% Value = term()
+%% Config = [{Key,Value},...]
+%%
+%% Looks up a specific key in the config list, and returns the value
+%% of the associated key, or undefined if the key doesn't exist.
+
+lookup_config(Key,Config) ->
+ case lists:keysearch(Key,1,Config) of
+ {value,{Key,Val}} ->
+ Val;
+ _ ->
+ io:format("Could not find element ~p in Config.~n",[Key]),
+ undefined
+ end.
+
+%%
+%% IMPORTANT: get_loc/1 uses the name of this function when analysing
+%% stack traces. If the name changes, get_loc/1 must be updated!
+%%
+ts_tc(M, F, A) ->
+ Before = erlang:monotonic_time(),
+ Result = try
+ apply(M, F, A)
+ catch
+ throw:{skip, Reason} -> {skip, Reason};
+ throw:{skipped, Reason} -> {skip, Reason};
+ exit:{skip, Reason} -> {skip, Reason};
+ exit:{skipped, Reason} -> {skip, Reason};
+ Type:Reason ->
+ Stk = erlang:get_stacktrace(),
+ set_loc(Stk),
+ case Type of
+ throw ->
+ {failed,{thrown,Reason}};
+ error ->
+ {'EXIT',{Reason,Stk}};
+ exit ->
+ {'EXIT',Reason}
+ end
+ end,
+ After = erlang:monotonic_time(),
+ Elapsed = erlang:convert_time_unit(After-Before, native, micro_seconds),
+ {Elapsed, Result}.
+
+set_loc(Stk) ->
+ Loc = case [rewrite_loc_item(I) || {_,_,_,_}=I <- Stk] of
+ [{M,F,0}|Stack] ->
+ [{M,F}|Stack];
+ Other ->
+ Other
+ end,
+ put(test_server_loc, Loc).
+
+rewrite_loc_item({M,F,_,Loc}) ->
+ {M,F,proplists:get_value(line, Loc, 0)}.
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% TEST SUITE SUPPORT FUNCTIONS %%
+%% %%
+%% Note: Some of these functions have been moved to test_server_sup %%
+%% in an attempt to keep this modules small (yeah, right!) %%
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% format(Format) -> IoLibReturn
+%% format(Detail,Format) -> IoLibReturn
+%% format(Format,Args) -> IoLibReturn
+%% format(Detail,Format,Args) -> IoLibReturn
+%% Detail = integer()
+%% Format = string()
+%% Args = [term(),...]
+%% IoLibReturn = term()
+%%
+%% Logs the Format string and Args, similar to io:format/1/2 etc. If
+%% Detail is not specified, the default detail level (which is 50) is used.
+%% Which log files the string will be logged in depends on the thresholds
+%% set with set_levels/3. Typically with default detail level, only the
+%% minor log file is used.
+format(Format) ->
+ format(minor, Format, []).
+
+format(major, Format) ->
+ format(major, Format, []);
+format(minor, Format) ->
+ format(minor, Format, []);
+format(Detail, Format) when is_integer(Detail) ->
+ format(Detail, Format, []);
+format(Format, Args) ->
+ format(minor, Format, Args).
+
+format(Detail, Format, Args) ->
+ Str =
+ case catch io_lib:format(Format,Args) of
+ {'EXIT',_} ->
+ io_lib:format("illegal format; ~p with args ~p.\n",
+ [Format,Args]);
+ Valid -> Valid
+ end,
+ log({Detail, Str}).
+
+log(Msg) ->
+ group_leader() ! {structured_io, self(), Msg},
+ ok.
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% capture_start() -> ok
+%% capture_stop() -> ok
+%%
+%% Starts/stops capturing all output from io:format, and similar. Capturing
+%% output doesn't stop output from happening. It just makes it possible
+%% to retrieve the output using capture_get/0.
+%% Starting and stopping capture doesn't affect already captured output.
+%% All output is stored as messages in the message queue until retrieved
+
+capture_start() ->
+ group_leader() ! {capture,self()},
+ ok.
+
+capture_stop() ->
+ group_leader() ! {capture,false},
+ ok.
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% capture_get() -> Output
+%% Output = [string(),...]
+%%
+%% Retrieves all the captured output since last call to capture_get/0.
+%% Note that since output arrive as messages to the process, it takes
+%% a short while from the call to io:format until all output is available
+%% by capture_get/0. It is not necessary to call capture_stop/0 before
+%% retreiving the output.
+capture_get() ->
+ test_server_sup:capture_get([]).
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% messages_get() -> Messages
+%% Messages = [term(),...]
+%%
+%% Returns all messages in the message queue.
+messages_get() ->
+ test_server_sup:messages_get([]).
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% permit_io(GroupLeader, FromPid) -> ok
+%%
+%% Make sure proceeding IO from FromPid won't get rejected
+permit_io(GroupLeader, FromPid) ->
+ GroupLeader ! {permit_io,FromPid}.
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% sleep(Time) -> ok
+%% Time = integer() | float() | infinity
+%%
+%% Sleeps the specified number of milliseconds. This sleep also accepts
+%% floating point numbers (which are truncated) and the atom 'infinity'.
+sleep(infinity) ->
+ receive
+ after infinity ->
+ ok
+ end;
+sleep(MSecs) ->
+ receive
+ after trunc(MSecs) ->
+ ok
+ end,
+ ok.
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% adjusted_sleep(Time) -> ok
+%% Time = integer() | float() | infinity
+%%
+%% Sleeps the specified number of milliseconds, multiplied by the
+%% 'multiply_timetraps' value (if set) and possibly also automatically scaled
+%% up if 'scale_timetraps' is set to true (which is default).
+%% This function also accepts floating point numbers (which are truncated) and
+%% the atom 'infinity'.
+adjusted_sleep(infinity) ->
+ receive
+ after infinity ->
+ ok
+ end;
+adjusted_sleep(MSecs) ->
+ {Multiplier,ScaleFactor} =
+ case test_server_ctrl:get_timetrap_parameters() of
+ {undefined,undefined} ->
+ {1,1};
+ {undefined,false} ->
+ {1,1};
+ {undefined,true} ->
+ {1,timetrap_scale_factor()};
+ {infinity,_} ->
+ {infinity,1};
+ {Mult,undefined} ->
+ {Mult,1};
+ {Mult,false} ->
+ {Mult,1};
+ {Mult,true} ->
+ {Mult,timetrap_scale_factor()}
+ end,
+ receive
+ after trunc(MSecs*Multiplier*ScaleFactor) ->
+ ok
+ end,
+ ok.
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% fail(Reason) -> exit({suite_failed,Reason})
+%%
+%% Immediately calls exit. Included because test suites are easier
+%% to read when using this function, rather than exit directly.
+fail(Reason) ->
+ comment(cast_to_list(Reason)),
+ try
+ exit({suite_failed,Reason})
+ catch
+ Class:R ->
+ case erlang:get_stacktrace() of
+ [{?MODULE,fail,1,_}|Stk] -> ok;
+ Stk -> ok
+ end,
+ erlang:raise(Class, R, Stk)
+ end.
+
+cast_to_list(X) when is_list(X) -> X;
+cast_to_list(X) when is_atom(X) -> atom_to_list(X);
+cast_to_list(X) -> lists:flatten(io_lib:format("~p", [X])).
+
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% fail() -> exit(suite_failed)
+%%
+%% Immediately calls exit. Included because test suites are easier
+%% to read when using this function, rather than exit directly.
+fail() ->
+ try
+ exit(suite_failed)
+ catch
+ Class:R ->
+ case erlang:get_stacktrace() of
+ [{?MODULE,fail,0,_}|Stk] -> ok;
+ Stk -> ok
+ end,
+ erlang:raise(Class, R, Stk)
+ end.
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% break(Comment) -> ok
+%%
+%% Break a test case so part of the test can be done manually.
+%% Use continue/0 to continue.
+break(Comment) ->
+ break(?MODULE, Comment).
+
+break(CBM, Comment) ->
+ break(CBM, '', Comment).
+
+break(CBM, TestCase, Comment) ->
+ timetrap_cancel(),
+ {TCName,CntArg,PName} =
+ if TestCase == '' ->
+ {"", "", test_server_break_process};
+ true ->
+ Str = atom_to_list(TestCase),
+ {[32 | Str], Str,
+ list_to_atom("test_server_break_process_" ++ Str)}
+ end,
+ io:format(user,
+ "\n\n\n--- SEMIAUTOMATIC TESTING ---"
+ "\nThe test case~ts executes on process ~w"
+ "\n\n\n~ts"
+ "\n\n\n-----------------------------\n\n"
+ "Continue with --> ~w:continue(~ts).\n",
+ [TCName,self(),Comment,CBM,CntArg]),
+ case whereis(PName) of
+ undefined ->
+ spawn_break_process(self(), PName);
+ OldBreakProcess ->
+ OldBreakProcess ! cancel,
+ spawn_break_process(self(), PName)
+ end,
+ receive continue -> ok end.
+
+spawn_break_process(Pid, PName) ->
+ spawn(fun() ->
+ register(PName, self()),
+ receive
+ continue -> continue(Pid);
+ cancel -> ok
+ end
+ end).
+
+continue() ->
+ case whereis(test_server_break_process) of
+ undefined -> ok;
+ BreakProcess -> BreakProcess ! continue
+ end.
+
+continue(TestCase) when is_atom(TestCase) ->
+ PName = list_to_atom("test_server_break_process_" ++
+ atom_to_list(TestCase)),
+ case whereis(PName) of
+ undefined -> ok;
+ BreakProcess -> BreakProcess ! continue
+ end;
+
+continue(Pid) when is_pid(Pid) ->
+ Pid ! continue.
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% timetrap_scale_factor() -> Factor
+%%
+%% Returns the amount to scale timetraps with.
+
+%% {X, fun() -> check() end} <- multiply scale with X if Fun() is true
+timetrap_scale_factor() ->
+ timetrap_scale_factor([
+ { 2, fun() -> has_lock_checking() end},
+ { 3, fun() -> has_superfluous_schedulers() end},
+ { 5, fun() -> purify_is_running() end},
+ { 6, fun() -> is_debug() end},
+ {10, fun() -> is_cover() end}
+ ]).
+
+timetrap_scale_factor(Scales) ->
+ %% The fun in {S, Fun} a filter input to the list comprehension
+ lists:foldl(fun(S,O) -> O*S end, 1, [ S || {S,F} <- Scales, F()]).
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% timetrap(Timeout) -> Handle
+%% Handle = term()
+%%
+%% Creates a time trap, that will kill the calling process if the
+%% trap is not cancelled with timetrap_cancel/1, within Timeout milliseconds.
+timetrap(Timeout) ->
+ MultAndScale =
+ case get(test_server_multiply_timetraps) of
+ undefined -> {fun(T) -> T end, true};
+ {undefined,false} -> {fun(T) -> T end, false};
+ {undefined,_} -> {fun(T) -> T end, true};
+ {infinity,_} -> {fun(_) -> infinity end, false};
+ {Int,Scale} -> {fun(infinity) -> infinity;
+ (T) -> T*Int end, Scale}
+ end,
+ timetrap(Timeout, Timeout, self(), MultAndScale).
+
+%% when the function is called from different process than
+%% the test case, the test_server_multiply_timetraps data
+%% is unknown and must be passed as argument
+timetrap(Timeout, TCPid, MultAndScale) ->
+ timetrap(Timeout, Timeout, TCPid, MultAndScale).
+
+timetrap(Timeout0, TimeToReport0, TCPid, MultAndScale = {Multiplier,Scale}) ->
+ %% the time_ms call will either convert Timeout to ms or spawn a
+ %% user timetrap which sends the result to the IO server process
+ Timeout = time_ms(Timeout0, TCPid, MultAndScale),
+ Timeout1 = Multiplier(Timeout),
+ TimeToReport = if Timeout0 == TimeToReport0 ->
+ Timeout1;
+ true ->
+ %% only convert to ms, don't start a
+ %% user timetrap
+ time_ms_check(TimeToReport0)
+ end,
+ cancel_default_timetrap(self() == TCPid),
+ Handle = case Timeout1 of
+ infinity ->
+ infinity;
+ _ ->
+ spawn_link(test_server_sup,timetrap,[Timeout1,TimeToReport,
+ Scale,TCPid])
+ end,
+
+ %% ERROR! This sets dict on IO process instead of testcase process
+ %% if Timeout is return value from previous user timetrap!!
+
+ case get(test_server_timetraps) of
+ undefined ->
+ put(test_server_timetraps,[{Handle,TCPid,{TimeToReport,Scale}}]);
+ List ->
+ List1 = lists:delete({infinity,TCPid,{infinity,false}}, List),
+ put(test_server_timetraps,[{Handle,TCPid,
+ {TimeToReport,Scale}}|List1])
+ end,
+ Handle.
+
+ensure_timetrap(Config) ->
+ case get(test_server_timetraps) of
+ [_|_] ->
+ ok;
+ _ ->
+ case get(test_server_default_timetrap) of
+ undefined -> ok;
+ Garbage ->
+ erase(test_server_default_timetrap),
+ format("=== WARNING: garbage in "
+ "test_server_default_timetrap: ~p~n",
+ [Garbage])
+ end,
+ DTmo = case lists:keysearch(default_timeout,1,Config) of
+ {value,{default_timeout,Tmo}} -> Tmo;
+ _ -> ?DEFAULT_TIMETRAP_SECS
+ end,
+ format("=== test_server setting default "
+ "timetrap of ~p seconds~n",
+ [DTmo]),
+ put(test_server_default_timetrap, timetrap(seconds(DTmo)))
+ end.
+
+%% executing on IO process, no default timetrap ever set here
+cancel_default_timetrap(false) ->
+ ok;
+cancel_default_timetrap(true) ->
+ case get(test_server_default_timetrap) of
+ undefined ->
+ ok;
+ TimeTrap when is_pid(TimeTrap) ->
+ timetrap_cancel(TimeTrap),
+ erase(test_server_default_timetrap),
+ format("=== test_server canceled default timetrap "
+ "since another timetrap was set~n"),
+ ok;
+ Garbage ->
+ erase(test_server_default_timetrap),
+ format("=== WARNING: garbage in "
+ "test_server_default_timetrap: ~p~n",
+ [Garbage]),
+ error
+ end.
+
+time_ms({hours,N}, _, _) -> hours(N);
+time_ms({minutes,N}, _, _) -> minutes(N);
+time_ms({seconds,N}, _, _) -> seconds(N);
+time_ms({Other,_N}, _, _) ->
+ format("=== ERROR: Invalid time specification: ~p. "
+ "Should be seconds, minutes, or hours.~n", [Other]),
+ exit({invalid_time_format,Other});
+time_ms(Ms, _, _) when is_integer(Ms) -> Ms;
+time_ms(infinity, _, _) -> infinity;
+time_ms(Fun, TCPid, MultAndScale) when is_function(Fun) ->
+ time_ms_apply(Fun, TCPid, MultAndScale);
+time_ms({M,F,A}=MFA, TCPid, MultAndScale) when is_atom(M),
+ is_atom(F),
+ is_list(A) ->
+ time_ms_apply(MFA, TCPid, MultAndScale);
+time_ms(Other, _, _) -> exit({invalid_time_format,Other}).
+
+time_ms_check(MFA = {M,F,A}) when is_atom(M), is_atom(F), is_list(A) ->
+ MFA;
+time_ms_check(Fun) when is_function(Fun) ->
+ Fun;
+time_ms_check(Other) ->
+ time_ms(Other, undefined, undefined).
+
+time_ms_apply(Func, TCPid, MultAndScale) ->
+ {_,GL} = process_info(TCPid, group_leader),
+ WhoAmI = self(), % either TC or IO server
+ T0 = erlang:monotonic_time(),
+ UserTTSup =
+ spawn(fun() ->
+ user_timetrap_supervisor(Func, WhoAmI, TCPid,
+ GL, T0, MultAndScale)
+ end),
+ receive
+ {UserTTSup,infinity} ->
+ %% remember the user timetrap so that it can be cancelled
+ save_user_timetrap(TCPid, UserTTSup, T0),
+ %% we need to make sure the user timetrap function
+ %% gets time to execute and return
+ timetrap(infinity, TCPid, MultAndScale)
+ after 5000 ->
+ exit(UserTTSup, kill),
+ if WhoAmI /= GL ->
+ exit({user_timetrap_error,time_ms_apply});
+ true ->
+ format("=== ERROR: User timetrap execution failed!", []),
+ ignore
+ end
+ end.
+
+user_timetrap_supervisor(Func, Spawner, TCPid, GL, T0, MultAndScale) ->
+ process_flag(trap_exit, true),
+ Spawner ! {self(),infinity},
+ MonRef = monitor(process, TCPid),
+ UserTTSup = self(),
+ group_leader(GL, UserTTSup),
+ UserTT = spawn_link(fun() -> call_user_timetrap(Func, UserTTSup) end),
+ receive
+ {UserTT,Result} ->
+ demonitor(MonRef, [flush]),
+ T1 = erlang:monotonic_time(),
+ Elapsed = erlang:convert_time_unit(T1-T0, native, milli_seconds),
+ try time_ms_check(Result) of
+ TimeVal ->
+ %% this is the new timetrap value to set (return value
+ %% from a fun or an MFA)
+ GL ! {user_timetrap,TCPid,TimeVal,T0,Elapsed,MultAndScale}
+ catch _:_ ->
+ %% when other than a legal timetrap value is returned
+ %% which will be the normal case for user timetraps
+ GL ! {user_timetrap,TCPid,0,T0,Elapsed,MultAndScale}
+ end;
+ {'EXIT',UserTT,Error} when Error /= normal ->
+ demonitor(MonRef, [flush]),
+ GL ! {user_timetrap,TCPid,0,T0,{user_timetrap_error,Error},
+ MultAndScale};
+ {'DOWN',MonRef,_,_,_} ->
+ demonitor(MonRef, [flush]),
+ exit(UserTT, kill)
+ end.
+
+call_user_timetrap(Func, Sup) when is_function(Func) ->
+ try Func() of
+ Result ->
+ Sup ! {self(),Result}
+ catch _:Error ->
+ exit({Error,erlang:get_stacktrace()})
+ end;
+call_user_timetrap({M,F,A}, Sup) ->
+ try apply(M,F,A) of
+ Result ->
+ Sup ! {self(),Result}
+ catch _:Error ->
+ exit({Error,erlang:get_stacktrace()})
+ end.
+
+save_user_timetrap(TCPid, UserTTSup, StartTime) ->
+ %% save pid of user timetrap supervisor process so that
+ %% it may be stopped even before the timetrap func has returned
+ NewUserTT = {TCPid,{UserTTSup,StartTime}},
+ case get(test_server_user_timetrap) of
+ undefined ->
+ put(test_server_user_timetrap, [NewUserTT]);
+ UserTTSups ->
+ case proplists:get_value(TCPid, UserTTSups) of
+ undefined ->
+ put(test_server_user_timetrap,
+ [NewUserTT | UserTTSups]);
+ PrevTTSup ->
+ %% remove prev user timetrap
+ remove_user_timetrap(PrevTTSup),
+ put(test_server_user_timetrap,
+ [NewUserTT | proplists:delete(TCPid,
+ UserTTSups)])
+ end
+ end.
+
+update_user_timetraps(TCPid, StartTime) ->
+ %% called when a user timetrap is triggered
+ case get(test_server_user_timetrap) of
+ undefined ->
+ proceed;
+ UserTTs ->
+ case proplists:get_value(TCPid, UserTTs) of
+ {_UserTTSup,StartTime} -> % same timetrap
+ put(test_server_user_timetrap,
+ proplists:delete(TCPid, UserTTs)),
+ proceed;
+ {OtherUserTTSup,OtherStartTime} ->
+ case OtherStartTime - StartTime of
+ Diff when Diff >= 0 ->
+ ignore;
+ _ ->
+ exit(OtherUserTTSup, kill),
+ put(test_server_user_timetrap,
+ proplists:delete(TCPid, UserTTs)),
+ proceed
+ end;
+ undefined ->
+ proceed
+ end
+ end.
+
+remove_user_timetrap(TTSup) ->
+ exit(TTSup, kill).
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% timetrap_cancel(Handle) -> ok
+%% Handle = term()
+%%
+%% Cancels a time trap.
+timetrap_cancel(Handle) ->
+ timetrap_cancel_one(Handle, true).
+
+timetrap_cancel_one(infinity, _SendToServer) ->
+ ok;
+timetrap_cancel_one(Handle, SendToServer) ->
+ case get(test_server_timetraps) of
+ undefined ->
+ ok;
+ [{Handle,_,_}] ->
+ erase(test_server_timetraps);
+ Timers ->
+ case lists:keysearch(Handle, 1, Timers) of
+ {value,_} ->
+ put(test_server_timetraps,
+ lists:keydelete(Handle, 1, Timers));
+ false when SendToServer == true ->
+ group_leader() ! {timetrap_cancel_one,Handle,self()};
+ false ->
+ ok
+ end
+ end,
+ test_server_sup:timetrap_cancel(Handle).
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% timetrap_cancel() -> ok
+%%
+%% Cancels timetrap for current test case.
+timetrap_cancel() ->
+ timetrap_cancel_all(self(), true).
+
+timetrap_cancel_all(TCPid, SendToServer) ->
+ case get(test_server_timetraps) of
+ undefined ->
+ ok;
+ Timers ->
+ [timetrap_cancel_one(Handle, false) ||
+ {Handle,Pid,_} <- Timers, Pid == TCPid]
+ end,
+ case get(test_server_user_timetrap) of
+ undefined ->
+ ok;
+ UserTTs ->
+ case proplists:get_value(TCPid, UserTTs) of
+ {UserTTSup,_StartTime} ->
+ remove_user_timetrap(UserTTSup),
+ put(test_server_user_timetrap,
+ proplists:delete(TCPid, UserTTs));
+ undefined ->
+ ok
+ end
+ end,
+ if SendToServer == true ->
+ group_leader() ! {timetrap_cancel_all,TCPid,self()};
+ true ->
+ ok
+ end,
+ ok.
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% get_timetrap_info() -> {Timeout,Scale} | undefined
+%%
+%% Read timetrap info for current test case
+get_timetrap_info() ->
+ get_timetrap_info(self(), true).
+
+get_timetrap_info(TCPid, SendToServer) ->
+ case get(test_server_timetraps) of
+ undefined ->
+ undefined;
+ Timers ->
+ case [Info || {Handle,Pid,Info} <- Timers,
+ Pid == TCPid, Handle /= infinity] of
+ [I|_] ->
+ I;
+ [] when SendToServer == true ->
+ tc_supervisor_req({get_timetrap_info,TCPid});
+ [] ->
+ undefined
+ end
+ end.
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% hours(N) -> Milliseconds
+%% minutes(N) -> Milliseconds
+%% seconds(N) -> Milliseconds
+%% N = integer() | float()
+%% Milliseconds = integer()
+%%
+%% Transforms the named units to milliseconds. Fractions in the input
+%% are accepted. The output is an integer.
+hours(N) -> trunc(N * 1000 * 60 * 60).
+minutes(N) -> trunc(N * 1000 * 60).
+seconds(N) -> trunc(N * 1000).
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% tc_supervisor_req(Tag) -> Result
+%% tc_supervisor_req(Tag, Msg) -> Result
+%%
+
+tc_supervisor_req(Tag) ->
+ Pid = test_server_gl:get_tc_supervisor(group_leader()),
+ Pid ! {Tag,self()},
+ receive
+ {Pid,Tag,Result} ->
+ Result
+ after 5000 ->
+ error(no_answer_from_tc_supervisor)
+ end.
+
+tc_supervisor_req(Tag, Msg) ->
+ Pid = test_server_gl:get_tc_supervisor(group_leader()),
+ Pid ! {Tag,self(),Msg},
+ receive
+ {Pid,Tag,Result} ->
+ Result
+ after 5000 ->
+ error(no_answer_from_tc_supervisor)
+ end.
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% timecall(M,F,A) -> {Time,Val}
+%% Time = float()
+%%
+%% Measures the time spent evaluating MFA. The measurement is done with
+%% erlang:now/0, and should have pretty good accuracy on most platforms.
+%% The function is not evaluated in a catch context.
+timecall(M, F, A) ->
+ test_server_sup:timecall(M,F,A).
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% do_times(N,M,F,A) -> ok
+%% do_times(N,Fun) ->
+%% N = integer()
+%% Fun = fun() -> void()
+%%
+%% Evaluates MFA or Fun N times, and returns ok.
+do_times(N,M,F,A) when N>0 ->
+ apply(M,F,A),
+ do_times(N-1,M,F,A);
+do_times(0,_,_,_) ->
+ ok.
+
+do_times(N,Fun) when N>0 ->
+ Fun(),
+ do_times(N-1,Fun);
+do_times(0,_) ->
+ ok.
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% m_out_of_n(M,N,Fun) -> ok | exit({m_out_of_n_failed,{R,left_to_do}})
+%% M = integer()
+%% N = integer()
+%% Fun = fun() -> void()
+%% R = integer()
+%%
+%% Repeats evaluating the given function until it succeeded (didn't crash)
+%% M times. If, after N times, M successful attempts have not been
+%% accomplished, the process crashes with reason {m_out_of_n_failed
+%% {R,left_to_do}}, where R indicates how many cases that remained to be
+%% successfully completed.
+%%
+%% For example:
+%% m_out_of_n(1,4,fun() -> tricky_test_case() end)
+%% Tries to run tricky_test_case() up to 4 times,
+%% and is happy if it succeeds once.
+%%
+%% m_out_of_n(7,8,fun() -> clock_sanity_check() end)
+%% Tries running clock_sanity_check() up to 8
+%% times and allows the function to fail once.
+%% This might be useful if clock_sanity_check/0
+%% is known to fail if the clock crosses an hour
+%% boundary during the test (and the up to 8
+%% test runs could never cross 2 boundaries)
+m_out_of_n(0,_,_) ->
+ ok;
+m_out_of_n(M,0,_) ->
+ exit({m_out_of_n_failed,{M,left_to_do}});
+m_out_of_n(M,N,Fun) ->
+ case catch Fun() of
+ {'EXIT',_} ->
+ m_out_of_n(M,N-1,Fun);
+ _Other ->
+ m_out_of_n(M-1,N-1,Fun)
+ end.
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%%call_crash(M,F,A)
+%%call_crash(Time,M,F,A)
+%%call_crash(Time,Crash,M,F,A)
+%% M - atom()
+%% F - atom()
+%% A - [term()]
+%% Time - integer() in milliseconds.
+%% Crash - term()
+%%
+%% Spaws a new process that calls MFA. The call is considered
+%% successful if the call crashes with the given reason (Crash),
+%% or any other reason if Crash is not specified.
+%% ** The call must terminate withing the given Time (defaults
+%% to infinity), or it is considered a failure (exit with reason
+%% 'call_crash_timeout' is generated).
+
+call_crash(M,F,A) ->
+ call_crash(infinity,M,F,A).
+call_crash(Time,M,F,A) ->
+ call_crash(Time,any,M,F,A).
+call_crash(Time,Crash,M,F,A) ->
+ test_server_sup:call_crash(Time,Crash,M,F,A).
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% start_node(SlaveName, Type, Options) ->
+%% {ok, Slave} | {error, Reason}
+%%
+%% SlaveName = string(), atom().
+%% Type = slave | peer
+%% Options = [{tuple(), term()}]
+%%
+%% OptionList is a tuplelist wich may contain one
+%% or more of these members:
+%%
+%% Slave and Peer:
+%% {remote, true} - Start the node on a remote host. If not specified,
+%% the node will be started on the local host (with
+%% some exceptions, for instance VxWorks,
+%% where all nodes are started on a remote host).
+%% {args, Arguments} - Arguments passed directly to the node.
+%% {cleanup, false} - Nodes started with this option will not be killed
+%% by the test server after completion of the test case
+%% Therefore it is IMPORTANT that the USER terminates
+%% the node!!
+%% {erl, ReleaseList} - Use an Erlang emulator determined by ReleaseList
+%% when starting nodes, instead of the same emulator
+%% as the test server is running. ReleaseList is a list
+%% of specifiers, where a specifier is either
+%% {release, Rel}, {prog, Prog}, or 'this'. Rel is
+%% either the name of a release, e.g., "r7a" or
+%% 'latest'. 'this' means using the same emulator as
+%% the test server. Prog is the name of an emulator
+%% executable. If the list has more than one element,
+%% one of them is picked randomly. (Only
+%% works on Solaris and Linux, and the test
+%% server gives warnings when it notices that
+%% nodes are not of the same version as
+%% itself.)
+%%
+%% Peer only:
+%% {wait, false} - Don't wait for the node to be started.
+%% {fail_on_error, false} - Returns {error, Reason} rather than failing
+%% the test case. This option can only be used with
+%% peer nodes.
+%% Note that slave nodes always act as if they had
+%% fail_on_error==false.
+%%
+
+start_node(Name, Type, Options) ->
+ lists:foreach(
+ fun(N) ->
+ case firstname(N) of
+ Name ->
+ format("=== WARNING: Trying to start node \'~w\' when node"
+ " with same first name exists: ~w", [Name, N]);
+ _other -> ok
+ end
+ end,
+ nodes()),
+
+ group_leader() ! {sync_apply,
+ self(),
+ {test_server_ctrl,start_node,[Name,Type,Options]}},
+ Result = receive {sync_result,R} -> R end,
+
+ case Result of
+ {ok,Node} ->
+
+ %% Cannot run cover on shielded node or on a node started
+ %% by a shielded node.
+ Cover = case is_cover(Node) of
+ true ->
+ proplists:get_value(start_cover,Options,true);
+ false ->
+ false
+ end,
+
+ net_adm:ping(Node),
+ case Cover of
+ true ->
+ do_cover_for_node(Node,start);
+ _ ->
+ ok
+ end,
+ {ok,Node};
+ {fail,Reason} -> fail(Reason);
+ Error -> Error
+ end.
+
+firstname(N) ->
+ list_to_atom(upto($@,atom_to_list(N))).
+
+%% This should!!! crash if H is not member in list.
+upto(H, [H | _T]) -> [];
+upto(H, [X | T]) -> [X | upto(H,T)].
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% wait_for_node(Name) -> ok | {error,timeout}
+%%
+%% If a node is started with the options {wait,false}, this function
+%% can be used to wait for the node to come up from the
+%% test server point of view (i.e. wait until it has contacted
+%% the test server controller after startup)
+wait_for_node(Slave) ->
+ group_leader() ! {sync_apply,
+ self(),
+ {test_server_ctrl,wait_for_node,[Slave]}},
+ Result = receive {sync_result,R} -> R end,
+ case Result of
+ ok ->
+ net_adm:ping(Slave),
+ case is_cover(Slave) of
+ true ->
+ do_cover_for_node(Slave,start);
+ _ ->
+ ok
+ end;
+ _ ->
+ ok
+ end,
+ Result.
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% stop_node(Name) -> true|false
+%%
+%% Kills a (remote) node.
+%% Also inform test_server_ctrl so it can clean up!
+stop_node(Slave) ->
+ Cover = is_cover(Slave),
+ if Cover -> do_cover_for_node(Slave,flush,false);
+ true -> ok
+ end,
+ group_leader() ! {sync_apply,self(),{test_server_ctrl,stop_node,[Slave]}},
+ Result = receive {sync_result,R} -> R end,
+ case Result of
+ ok ->
+ erlang:monitor_node(Slave, true),
+ slave:stop(Slave),
+ receive
+ {nodedown, Slave} ->
+ format(minor, "Stopped slave node: ~w", [Slave]),
+ format(major, "=node_stop ~w", [Slave]),
+ if Cover -> do_cover_for_node(Slave,stop,false);
+ true -> ok
+ end,
+ true
+ after 30000 ->
+ format("=== WARNING: Node ~w does not seem to terminate.",
+ [Slave]),
+ erlang:monitor_node(Slave, false),
+ receive {nodedown, Slave} -> ok after 0 -> ok end,
+ false
+ end;
+ {error, _Reason} ->
+ %% Either, the node is already dead or it was started
+ %% with the {cleanup,false} option, or it was started
+ %% in some other way than test_server:start_node/3
+ format("=== WARNING: Attempt to stop a nonexisting slavenode (~w)~n"
+ "=== Trying to kill it anyway!!!",
+ [Slave]),
+ case net_adm:ping(Slave)of
+ pong ->
+ erlang:monitor_node(Slave, true),
+ slave:stop(Slave),
+ receive
+ {nodedown, Slave} ->
+ format(minor, "Stopped slave node: ~w", [Slave]),
+ format(major, "=node_stop ~w", [Slave]),
+ if Cover -> do_cover_for_node(Slave,stop,false);
+ true -> ok
+ end,
+ true
+ after 30000 ->
+ format("=== WARNING: Node ~w does not seem to terminate.",
+ [Slave]),
+ erlang:monitor_node(Slave, false),
+ receive {nodedown, Slave} -> ok after 0 -> ok end,
+ false
+ end;
+ pang ->
+ if Cover -> do_cover_for_node(Slave,stop,false);
+ true -> ok
+ end,
+ false
+ end
+ end.
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% is_release_available(Release) -> true | false
+%% Release -> string()
+%%
+%% Test if a release (such as "r10b") is available to be
+%% started using start_node/3.
+
+is_release_available(Release) ->
+ group_leader() ! {sync_apply,
+ self(),
+ {test_server_ctrl,is_release_available,[Release]}},
+ receive {sync_result,R} -> R end.
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% run_on_shielded_node(Fun, CArgs) -> term()
+%% Fun -> function()
+%% CArg -> list()
+%%
+%%
+%% Fun is executed in a process on a temporarily created
+%% hidden node. Communication with the job process goes
+%% via a job proxy process on the hidden node, i.e. the
+%% group leader of the test case process is the job proxy
+%% process. This makes it possible to start nodes from the
+%% hidden node that are unaware of the test server node.
+%% Without the job proxy process all processes would have
+%% a process residing on the test_server node as group_leader.
+%%
+%% Fun - Function to execute
+%% CArg - Extra command line arguments to use when starting
+%% the shielded node.
+%%
+%% If Fun is successfully executed, the result is returned.
+%%
+
+run_on_shielded_node(Fun, CArgs) when is_function(Fun), is_list(CArgs) ->
+ Nr = erlang:unique_integer([positive]),
+ Name = "shielded_node-" ++ integer_to_list(Nr),
+ Node = case start_node(Name, slave, [{args, "-hidden " ++ CArgs}]) of
+ {ok, N} -> N;
+ Err -> fail({failed_to_start_shielded_node, Err})
+ end,
+ Master = self(),
+ Ref = make_ref(),
+ Slave = spawn(Node, start_job_proxy_fun(Master, Fun)),
+ MRef = erlang:monitor(process, Slave),
+ Slave ! Ref,
+ receive
+ {'DOWN', MRef, _, _, Info} ->
+ stop_node(Node),
+ fail(Info);
+ {Ref, Res} ->
+ stop_node(Node),
+ receive
+ {'DOWN', MRef, _, _, _} ->
+ Res
+ end
+ end.
+
+-spec start_job_proxy_fun(_, _) -> fun(() -> no_return()).
+start_job_proxy_fun(Master, Fun) ->
+ fun () ->
+ start_job_proxy(),
+ receive
+ Ref ->
+ Master ! {Ref, Fun()}
+ end,
+ receive after infinity -> infinity end
+ end.
+
+%% Return true if Name or node() is a shielded node
+is_shielded(Name) ->
+ case {cast_to_list(Name),atom_to_list(node())} of
+ {"shielded_node"++_,_} -> true;
+ {_,"shielded_node"++_} -> true;
+ _ -> false
+ end.
+
+same_version(Name) ->
+ ThisVersion = erlang:system_info(version),
+ OtherVersion = rpc:call(Name, erlang, system_info, [version]),
+ ThisVersion =:= OtherVersion.
+
+is_cover(Name) ->
+ case is_cover() of
+ true ->
+ not is_shielded(Name) andalso same_version(Name);
+ false ->
+ false
+ end.
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% temp_name(Stem) -> string()
+%% Stem = string()
+%%
+%% Create a unique file name, based on (starting with) Stem.
+%% A filename of the form <Stem><Number> is generated, and the
+%% function checks that that file doesn't already exist.
+temp_name(Stem) ->
+ Num = erlang:unique_integer([positive]),
+ RandomName = Stem ++ integer_to_list(Num),
+ {ok,Files} = file:list_dir(filename:dirname(Stem)),
+ case lists:member(RandomName,Files) of
+ true ->
+ %% oh, already exists - bad luck. Try again.
+ temp_name(Stem); %% recursively try again
+ false ->
+ RandomName
+ end.
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% app_test/1
+%%
+app_test(App) ->
+ app_test(App, pedantic).
+app_test(App, Mode) ->
+ test_server_sup:app_test(App, Mode).
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% appup_test/1
+%%
+appup_test(App) ->
+ test_server_sup:appup_test(App).
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% is_native(Mod) -> true | false
+%%
+%% Checks wether the module is natively compiled or not.
+
+is_native(Mod) ->
+ (catch Mod:module_info(native)) =:= true.
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% comment(String) -> ok
+%%
+%% The given String will occur in the comment field
+%% of the table on the test suite result page. If
+%% called several times, only the last comment is
+%% printed.
+%% comment/1 is also overwritten by the return value
+%% {comment,Comment} or fail/1 (which prints Reason
+%% as a comment).
+comment(String) ->
+ group_leader() ! {comment,String},
+ ok.
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% read_comment() -> string()
+%%
+%% Read the current comment string stored in
+%% state during test case execution.
+read_comment() ->
+ tc_supervisor_req(read_comment).
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% make_priv_dir() -> ok
+%%
+%% Order test server to create the private directory
+%% for the current test case.
+make_priv_dir() ->
+ tc_supervisor_req(make_priv_dir).
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% os_type() -> OsType
+%%
+%% Returns the OsType of the target node. OsType is
+%% the same as returned from os:type()
+os_type() ->
+ os:type().
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% is_cover() -> boolean()
+%%
+%% Returns true if cover is running, else false
+is_cover() ->
+ case whereis(cover_server) of
+ undefined -> false;
+ _ -> true
+ end.
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% is_debug() -> boolean()
+%%
+%% Returns true if the emulator is debug-compiled, false otherwise.
+is_debug() ->
+ case catch erlang:system_info(debug_compiled) of
+ {'EXIT', _} ->
+ case string:str(erlang:system_info(system_version), "debug") of
+ Int when is_integer(Int), Int > 0 -> true;
+ _ -> false
+ end;
+ Res ->
+ Res
+ end.
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% has_lock_checking() -> boolean()
+%%
+%% Returns true if the emulator has lock checking enabled, false otherwise.
+has_lock_checking() ->
+ case catch erlang:system_info(lock_checking) of
+ {'EXIT', _} -> false;
+ Res -> Res
+ end.
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% has_superfluous_schedulers() -> boolean()
+%%
+%% Returns true if the emulator has more scheduler threads than logical
+%% processors, false otherwise.
+has_superfluous_schedulers() ->
+ case catch {erlang:system_info(schedulers),
+ erlang:system_info(logical_processors)} of
+ {S, P} when is_integer(S), is_integer(P), S > P -> true;
+ _ -> false
+ end.
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% is_commercial_build() -> boolean()
+%%
+%% Returns true if the current emulator is commercially supported.
+%% (The emulator will not have "[source]" in its start-up message.)
+%% We might want to do more tests on a commercial platform, for instance
+%% ensuring that all applications have documentation).
+is_commercial() ->
+ case string:str(erlang:system_info(system_version), "source") of
+ Int when is_integer(Int), Int > 0 -> false;
+ _ -> true
+ end.
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% DEBUGGER INTERFACE %%
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% purify_is_running() -> false|true
+%%
+%% Tests if Purify is currently running.
+
+purify_is_running() ->
+ case catch erlang:system_info({error_checker, running}) of
+ {'EXIT', _} -> false;
+ Res -> Res
+ end.
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% purify_new_leaks() -> false|BytesLeaked
+%% BytesLeaked = integer()
+%%
+%% Checks for new memory leaks if Purify is active.
+%% Returns the number of bytes leaked, or false if Purify
+%% is not running.
+purify_new_leaks() ->
+ case catch erlang:system_info({error_checker, memory}) of
+ {'EXIT', _} -> false;
+ Leaked when is_integer(Leaked) -> Leaked
+ end.
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% purify_new_fds_inuse() -> false|FdsInuse
+%% FdsInuse = integer()
+%%
+%% Checks for new file descriptors in use.
+%% Returns the number of new file descriptors in use, or false
+%% if Purify is not running.
+purify_new_fds_inuse() ->
+ case catch erlang:system_info({error_checker, fd}) of
+ {'EXIT', _} -> false;
+ Inuse when is_integer(Inuse) -> Inuse
+ end.
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% purify_format(Format, Args) -> ok
+%% Format = string()
+%% Args = lists()
+%%
+%% Outputs the formatted string to Purify's logfile,if Purify is active.
+purify_format(Format, Args) ->
+ (catch erlang:system_info({error_checker, io_lib:format(Format, Args)})),
+ ok.
+
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%%
+%% Apply given function and reply to caller or proxy.
+%%
+do_sync_apply(Proxy, From, {M,F,A}) ->
+ Result = apply(M, F, A),
+ if is_pid(Proxy) -> Proxy ! {sync_result_proxy,From,Result};
+ true -> From ! {sync_result,Result}
+ end.
diff --git a/lib/common_test/src/test_server_ctrl.erl b/lib/common_test/src/test_server_ctrl.erl
new file mode 100644
index 0000000000..833d99907e
--- /dev/null
+++ b/lib/common_test/src/test_server_ctrl.erl
@@ -0,0 +1,5692 @@
+%%
+%% %CopyrightBegin%
+%%
+%% Copyright Ericsson AB 2002-2014. All Rights Reserved.
+%%
+%% Licensed under the Apache License, Version 2.0 (the "License");
+%% you may not use this file except in compliance with the License.
+%% You may obtain a copy of the License at
+%%
+%% http://www.apache.org/licenses/LICENSE-2.0
+%%
+%% Unless required by applicable law or agreed to in writing, software
+%% distributed under the License is distributed on an "AS IS" BASIS,
+%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+%% See the License for the specific language governing permissions and
+%% limitations under the License.
+%%
+%% %CopyrightEnd%
+%%
+-module(test_server_ctrl).
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% %%
+%% The Erlang Test Server %%
+%% %%
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%%
+%% MODULE DEPENDENCIES:
+%% HARD TO REMOVE: erlang, lists, io_lib, gen_server, file, io, string,
+%% code, ets, rpc, gen_tcp, inet, erl_tar, sets,
+%% test_server, test_server_sup, test_server_node
+%% EASIER TO REMOVE: filename, filelib, lib, re
+%%
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+%%% SUPERVISOR INTERFACE %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+-export([start/0, start/1, start_link/1, stop/0]).
+
+%%% OPERATOR INTERFACE %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+-export([add_spec/1, add_dir/2, add_dir/3]).
+-export([add_module/1, add_module/2,
+ add_conf/3,
+ add_case/2, add_case/3, add_cases/2, add_cases/3]).
+-export([add_dir_with_skip/3, add_dir_with_skip/4, add_tests_with_skip/3]).
+-export([add_module_with_skip/2, add_module_with_skip/3,
+ add_conf_with_skip/4,
+ add_case_with_skip/3, add_case_with_skip/4,
+ add_cases_with_skip/3, add_cases_with_skip/4]).
+-export([jobs/0, run_test/1, wait_finish/0, idle_notify/1,
+ abort_current_testcase/1, abort/0]).
+-export([start_get_totals/1, stop_get_totals/0]).
+-export([reject_io_reqs/1, get_levels/0, set_levels/3]).
+-export([multiply_timetraps/1, scale_timetraps/1, get_timetrap_parameters/0]).
+-export([create_priv_dir/1]).
+-export([cover/1, cover/2, cover/3,
+ cover_compile/7, cover_analyse/2, cross_cover_analyse/2,
+ trc/1, stop_trace/0]).
+-export([testcase_callback/1]).
+-export([set_random_seed/1]).
+-export([kill_slavenodes/0]).
+
+%%% TEST_SERVER INTERFACE %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+-export([print/2, print/3, print/4, print_timestamp/2]).
+-export([start_node/3, stop_node/1, wait_for_node/1, is_release_available/1]).
+-export([format/1, format/2, format/3, to_string/1]).
+-export([get_target_info/0]).
+-export([get_hosts/0]).
+-export([node_started/1]).
+-export([uri_encode/1,uri_encode/2]).
+
+%%% DEBUGGER INTERFACE %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+-export([i/0, p/1, p/3, pi/2, pi/4, t/0, t/1]).
+
+%%% PRIVATE EXPORTED %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+-export([init/1, terminate/2]).
+-export([handle_call/3, handle_cast/2, handle_info/2]).
+-export([do_test_cases/4]).
+-export([do_spec/2, do_spec_list/2]).
+-export([xhtml/2, escape_chars/1]).
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+-include("test_server_internal.hrl").
+-include_lib("kernel/include/file.hrl").
+-define(suite_ext, "_SUITE").
+-define(log_ext, ".log.html").
+-define(src_listing_ext, ".src.html").
+-define(logdir_ext, ".logs").
+-define(data_dir_suffix, "_data/").
+-define(suitelog_name, "suite.log").
+-define(coverlog_name, "cover.html").
+-define(raw_coverlog_name, "cover.log").
+-define(cross_coverlog_name, "cross_cover.html").
+-define(raw_cross_coverlog_name, "cross_cover.log").
+-define(cross_cover_info, "cross_cover.info").
+-define(cover_total, "total_cover.log").
+-define(unexpected_io_log, "unexpected_io.log.html").
+-define(last_file, "last_name").
+-define(last_link, "last_link").
+-define(last_test, "last_test").
+-define(html_ext, ".html").
+-define(now, os:timestamp()).
+
+-define(void_fun, fun() -> ok end).
+-define(mod_result(X), if X == skip -> skipped;
+ X == auto_skip -> skipped;
+ true -> X end).
+
+-define(auto_skip_color, "#FFA64D").
+-define(user_skip_color, "#FF8000").
+-define(sortable_table_name, "SortableTable").
+
+-record(state,{jobs=[], levels={1,19,10}, reject_io_reqs=false,
+ multiply_timetraps=1, scale_timetraps=true,
+ create_priv_dir=auto_per_run, finish=false,
+ target_info, trc=false, cover=false, wait_for_node=[],
+ testcase_callback=undefined, idle_notify=[],
+ get_totals=false, random_seed=undefined}).
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% OPERATOR INTERFACE
+
+add_dir(Name, Job=[Dir|_Dirs]) when is_list(Dir) ->
+ add_job(cast_to_list(Name),
+ lists:map(fun(D)-> {dir,cast_to_list(D)} end, Job));
+add_dir(Name, Dir) ->
+ add_job(cast_to_list(Name), {dir,cast_to_list(Dir)}).
+
+add_dir(Name, Job=[Dir|_Dirs], Pattern) when is_list(Dir) ->
+ add_job(cast_to_list(Name),
+ lists:map(fun(D)-> {dir,cast_to_list(D),
+ cast_to_list(Pattern)} end, Job));
+add_dir(Name, Dir, Pattern) ->
+ add_job(cast_to_list(Name), {dir,cast_to_list(Dir),cast_to_list(Pattern)}).
+
+add_module(Mod) when is_atom(Mod) ->
+ add_job(atom_to_list(Mod), {Mod,all}).
+
+add_module(Name, Mods) when is_list(Mods) ->
+ add_job(cast_to_list(Name), lists:map(fun(Mod) -> {Mod,all} end, Mods)).
+
+add_conf(Name, Mod, Conf) when is_tuple(Conf) ->
+ add_job(cast_to_list(Name), {Mod,[Conf]});
+
+add_conf(Name, Mod, Confs) when is_list(Confs) ->
+ add_job(cast_to_list(Name), {Mod,Confs}).
+
+add_case(Mod, Case) when is_atom(Mod), is_atom(Case) ->
+ add_job(atom_to_list(Mod), {Mod,Case}).
+
+add_case(Name, Mod, Case) when is_atom(Mod), is_atom(Case) ->
+ add_job(Name, {Mod,Case}).
+
+add_cases(Mod, Cases) when is_atom(Mod), is_list(Cases) ->
+ add_job(atom_to_list(Mod), {Mod,Cases}).
+
+add_cases(Name, Mod, Cases) when is_atom(Mod), is_list(Cases) ->
+ add_job(Name, {Mod,Cases}).
+
+add_spec(Spec) ->
+ Name = filename:rootname(Spec, ".spec"),
+ case filelib:is_file(Spec) of
+ true -> add_job(Name, {spec,Spec});
+ false -> {error,nofile}
+ end.
+
+%% This version of the interface is to be used if there are
+%% suites or cases that should be skipped.
+
+add_dir_with_skip(Name, Job=[Dir|_Dirs], Skip) when is_list(Dir) ->
+ add_job(cast_to_list(Name),
+ lists:map(fun(D)-> {dir,cast_to_list(D)} end, Job),
+ Skip);
+add_dir_with_skip(Name, Dir, Skip) ->
+ add_job(cast_to_list(Name), {dir,cast_to_list(Dir)}, Skip).
+
+add_dir_with_skip(Name, Job=[Dir|_Dirs], Pattern, Skip) when is_list(Dir) ->
+ add_job(cast_to_list(Name),
+ lists:map(fun(D)-> {dir,cast_to_list(D),
+ cast_to_list(Pattern)} end, Job),
+ Skip);
+add_dir_with_skip(Name, Dir, Pattern, Skip) ->
+ add_job(cast_to_list(Name),
+ {dir,cast_to_list(Dir),cast_to_list(Pattern)}, Skip).
+
+add_module_with_skip(Mod, Skip) when is_atom(Mod) ->
+ add_job(atom_to_list(Mod), {Mod,all}, Skip).
+
+add_module_with_skip(Name, Mods, Skip) when is_list(Mods) ->
+ add_job(cast_to_list(Name), lists:map(fun(Mod) -> {Mod,all} end, Mods), Skip).
+
+add_conf_with_skip(Name, Mod, Conf, Skip) when is_tuple(Conf) ->
+ add_job(cast_to_list(Name), {Mod,[Conf]}, Skip);
+
+add_conf_with_skip(Name, Mod, Confs, Skip) when is_list(Confs) ->
+ add_job(cast_to_list(Name), {Mod,Confs}, Skip).
+
+add_case_with_skip(Mod, Case, Skip) when is_atom(Mod), is_atom(Case) ->
+ add_job(atom_to_list(Mod), {Mod,Case}, Skip).
+
+add_case_with_skip(Name, Mod, Case, Skip) when is_atom(Mod), is_atom(Case) ->
+ add_job(Name, {Mod,Case}, Skip).
+
+add_cases_with_skip(Mod, Cases, Skip) when is_atom(Mod), is_list(Cases) ->
+ add_job(atom_to_list(Mod), {Mod,Cases}, Skip).
+
+add_cases_with_skip(Name, Mod, Cases, Skip) when is_atom(Mod), is_list(Cases) ->
+ add_job(Name, {Mod,Cases}, Skip).
+
+add_tests_with_skip(LogDir, Tests, Skip) ->
+ add_job(LogDir,
+ lists:map(fun({Dir,all,all}) ->
+ {Dir,{dir,Dir}};
+ ({Dir,Mods,all}) ->
+ {Dir,lists:map(fun(M) -> {M,all} end, Mods)};
+ ({Dir,Mod,Cases}) ->
+ {Dir,{Mod,Cases}}
+ end, Tests),
+ Skip).
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% COMMAND LINE INTERFACE
+
+parse_cmd_line(Cmds) ->
+ parse_cmd_line(Cmds, [], [], local, false, false, undefined).
+
+parse_cmd_line(['SPEC',Spec|Cmds], SpecList, Names, Param, Trc, Cov, TCCB) ->
+ case file:consult(Spec) of
+ {ok, TermList} ->
+ Name = filename:rootname(Spec),
+ parse_cmd_line(Cmds, TermList++SpecList, [Name|Names], Param,
+ Trc, Cov, TCCB);
+ {error,Reason} ->
+ io:format("Can't open ~w: ~p\n",[Spec, file:format_error(Reason)]),
+ parse_cmd_line(Cmds, SpecList, Names, Param, Trc, Cov, TCCB)
+ end;
+parse_cmd_line(['NAME',Name|Cmds], SpecList, Names, Param, Trc, Cov, TCCB) ->
+ parse_cmd_line(Cmds, SpecList, [{name,atom_to_list(Name)}|Names],
+ Param, Trc, Cov, TCCB);
+parse_cmd_line(['SKIPMOD',Mod|Cmds], SpecList, Names, Param, Trc, Cov, TCCB) ->
+ parse_cmd_line(Cmds, [{skip,{Mod,"by command line"}}|SpecList], Names,
+ Param, Trc, Cov, TCCB);
+parse_cmd_line(['SKIPCASE',Mod,Case|Cmds], SpecList, Names, Param, Trc, Cov, TCCB) ->
+ parse_cmd_line(Cmds, [{skip,{Mod,Case,"by command line"}}|SpecList], Names,
+ Param, Trc, Cov, TCCB);
+parse_cmd_line(['DIR',Dir|Cmds], SpecList, Names, Param, Trc, Cov, TCCB) ->
+ Name = filename:basename(Dir),
+ parse_cmd_line(Cmds, [{topcase,{dir,Name}}|SpecList], [Name|Names],
+ Param, Trc, Cov, TCCB);
+parse_cmd_line(['MODULE',Mod|Cmds], SpecList, Names, Param, Trc, Cov, TCCB) ->
+ parse_cmd_line(Cmds,[{topcase,{Mod,all}}|SpecList],[atom_to_list(Mod)|Names],
+ Param, Trc, Cov, TCCB);
+parse_cmd_line(['CASE',Mod,Case|Cmds], SpecList, Names, Param, Trc, Cov, TCCB) ->
+ parse_cmd_line(Cmds,[{topcase,{Mod,Case}}|SpecList],[atom_to_list(Mod)|Names],
+ Param, Trc, Cov, TCCB);
+parse_cmd_line(['TRACE',Trc|Cmds], SpecList, Names, Param, _Trc, Cov, TCCB) ->
+ parse_cmd_line(Cmds, SpecList, Names, Param, Trc, Cov, TCCB);
+parse_cmd_line(['COVER',App,CF,Analyse|Cmds], SpecList, Names, Param, Trc, _Cov, TCCB) ->
+ parse_cmd_line(Cmds, SpecList, Names, Param, Trc, {{App,CF}, Analyse}, TCCB);
+parse_cmd_line(['TESTCASE_CALLBACK',Mod,Func|Cmds], SpecList, Names, Param, Trc, Cov, _) ->
+ parse_cmd_line(Cmds, SpecList, Names, Param, Trc, Cov, {Mod,Func});
+parse_cmd_line([Obj|_Cmds], _SpecList, _Names, _Param, _Trc, _Cov, _TCCB) ->
+ io:format("~w: Bad argument: ~w\n", [?MODULE,Obj]),
+ io:format(" Use the `ts' module to start tests.\n", []),
+ io:format(" (If you ARE using `ts', there is a bug in `ts'.)\n", []),
+ halt(1);
+parse_cmd_line([], SpecList, Names, Param, Trc, Cov, TCCB) ->
+ NameList = lists:reverse(Names, ["suite"]),
+ Name = case lists:keysearch(name, 1, NameList) of
+ {value,{name,N}} -> N;
+ false -> hd(NameList)
+ end,
+ {lists:reverse(SpecList), Name, Param, Trc, Cov, TCCB}.
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% cast_to_list(X) -> string()
+%% X = list() | atom() | void()
+%% Returns a string representation of whatever was input
+
+cast_to_list(X) when is_list(X) -> X;
+cast_to_list(X) when is_atom(X) -> atom_to_list(X);
+cast_to_list(X) -> lists:flatten(io_lib:format("~w", [X])).
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% START INTERFACE
+
+%% Kept for backwards compatibility
+start(_) ->
+ start().
+start_link(_) ->
+ start_link().
+
+
+start() ->
+ case gen_server:start({local,?MODULE}, ?MODULE, [], []) of
+ {ok, Pid} ->
+ {ok, Pid};
+ Other ->
+ Other
+ end.
+
+start_link() ->
+ case gen_server:start_link({local,?MODULE}, ?MODULE, [], []) of
+ {ok, Pid} ->
+ {ok, Pid};
+ Other ->
+ Other
+ end.
+
+run_test(CommandLine) ->
+ process_flag(trap_exit,true),
+ {SpecList,Name,Param,Trc,Cov,TCCB} = parse_cmd_line(CommandLine),
+ {ok,_TSPid} = start_link(Param),
+ case Trc of
+ false -> ok;
+ File -> trc(File)
+ end,
+ case Cov of
+ false -> ok;
+ {{App,CoverFile},Analyse} -> cover(App, maybe_file(CoverFile), Analyse)
+ end,
+ testcase_callback(TCCB),
+ add_job(Name, {command_line,SpecList}),
+
+ wait_finish().
+
+%% Converted CoverFile to a string unless it is 'none'
+maybe_file(none) ->
+ none;
+maybe_file(CoverFile) ->
+ atom_to_list(CoverFile).
+
+idle_notify(Fun) ->
+ {ok, Pid} = controller_call({idle_notify,Fun}),
+ Pid.
+
+start_get_totals(Fun) ->
+ {ok, Pid} = controller_call({start_get_totals,Fun}),
+ Pid.
+
+stop_get_totals() ->
+ ok = controller_call(stop_get_totals),
+ ok.
+
+wait_finish() ->
+ OldTrap = process_flag(trap_exit, true),
+ {ok, Pid} = finish(true),
+ link(Pid),
+ receive
+ {'EXIT',Pid,_} ->
+ ok
+ end,
+ process_flag(trap_exit, OldTrap),
+ ok.
+
+abort_current_testcase(Reason) ->
+ controller_call({abort_current_testcase,Reason}).
+
+abort() ->
+ OldTrap = process_flag(trap_exit, true),
+ {ok, Pid} = finish(abort),
+ link(Pid),
+ receive
+ {'EXIT',Pid,_} ->
+ ok
+ end,
+ process_flag(trap_exit, OldTrap),
+ ok.
+
+finish(Abort) ->
+ controller_call({finish,Abort}).
+
+stop() ->
+ controller_call(stop).
+
+jobs() ->
+ controller_call(jobs).
+
+get_levels() ->
+ controller_call(get_levels).
+
+set_levels(Show, Major, Minor) ->
+ controller_call({set_levels,Show,Major,Minor}).
+
+reject_io_reqs(Bool) ->
+ controller_call({reject_io_reqs,Bool}).
+
+multiply_timetraps(N) ->
+ controller_call({multiply_timetraps,N}).
+
+scale_timetraps(Bool) ->
+ controller_call({scale_timetraps,Bool}).
+
+get_timetrap_parameters() ->
+ controller_call(get_timetrap_parameters).
+
+create_priv_dir(Value) ->
+ controller_call({create_priv_dir,Value}).
+
+trc(TraceFile) ->
+ controller_call({trace,TraceFile}, 2*?ACCEPT_TIMEOUT).
+
+stop_trace() ->
+ controller_call(stop_trace).
+
+node_started(Node) ->
+ gen_server:cast(?MODULE, {node_started,Node}).
+
+cover(App, Analyse) when is_atom(App) ->
+ cover(App, none, Analyse);
+cover(CoverFile, Analyse) ->
+ cover(none, CoverFile, Analyse).
+cover(App, CoverFile, Analyse) ->
+ {Excl,Incl,Cross} = read_cover_file(CoverFile),
+ CoverInfo = #cover{app=App,
+ file=CoverFile,
+ excl=Excl,
+ incl=Incl,
+ cross=Cross,
+ level=Analyse},
+ controller_call({cover,CoverInfo}).
+
+cover(CoverInfo) ->
+ controller_call({cover,CoverInfo}).
+
+cover_compile(App,File,Excl,Incl,Cross,Analyse,Stop) ->
+ cover_compile(#cover{app=App,
+ file=File,
+ excl=Excl,
+ incl=Incl,
+ cross=Cross,
+ level=Analyse,
+ stop=Stop}).
+
+testcase_callback(ModFunc) ->
+ controller_call({testcase_callback,ModFunc}).
+
+set_random_seed(Seed) ->
+ controller_call({set_random_seed,Seed}).
+
+kill_slavenodes() ->
+ controller_call(kill_slavenodes).
+
+get_hosts() ->
+ get(test_server_hosts).
+
+%%--------------------------------------------------------------------
+
+add_job(Name, TopCase) ->
+ add_job(Name, TopCase, []).
+
+add_job(Name, TopCase, Skip) ->
+ SuiteName =
+ case Name of
+ "." -> "current_dir";
+ ".." -> "parent_dir";
+ Other -> Other
+ end,
+ Dir = filename:absname(SuiteName),
+ controller_call({add_job,Dir,SuiteName,TopCase,Skip}).
+
+controller_call(Arg) ->
+ case catch gen_server:call(?MODULE, Arg, infinity) of
+ {'EXIT',{{badarg,_},{gen_server,call,_}}} ->
+ exit(test_server_ctrl_not_running);
+ {'EXIT',Reason} ->
+ exit(Reason);
+ Other ->
+ Other
+ end.
+controller_call(Arg, Timeout) ->
+ case catch gen_server:call(?MODULE, Arg, Timeout) of
+ {'EXIT',{{badarg,_},{gen_server,call,_}}} ->
+ exit(test_server_ctrl_not_running);
+ {'EXIT',Reason} ->
+ exit(Reason);
+ Other ->
+ Other
+ end.
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% init([])
+%%
+%% init() is the init function of the test_server's gen_server.
+%%
+init([]) ->
+ case os:getenv("TEST_SERVER_CALL_TRACE") of
+ false ->
+ ok;
+ "" ->
+ ok;
+ TraceSpec ->
+ test_server_sup:call_trace(TraceSpec)
+ end,
+ process_flag(trap_exit, true),
+ %% copy format_exception setting from init arg to application environment
+ case init:get_argument(test_server_format_exception) of
+ {ok,[[TSFE]]} ->
+ application:set_env(test_server, format_exception, list_to_atom(TSFE));
+ _ ->
+ ok
+ end,
+ test_server_sup:cleanup_crash_dumps(),
+ test_server_sup:util_start(),
+ State = #state{jobs=[],finish=false},
+ TI0 = test_server:init_target_info(),
+ TargetHost = test_server_sup:hoststr(),
+ TI = TI0#target_info{host=TargetHost,
+ naming=naming(),
+ master=TargetHost},
+ ets:new(slave_tab, [named_table,set,public,{keypos,2}]),
+ set_hosts([TI#target_info.host]),
+ {ok,State#state{target_info=TI}}.
+
+naming() ->
+ case lists:member($., test_server_sup:hoststr()) of
+ true -> "-name";
+ false -> "-sname"
+ end.
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% handle_call(kill_slavenodes, From, State) -> ok
+%%
+%% Kill all slave nodes that remain after a test case
+%% is completed.
+%%
+handle_call(kill_slavenodes, _From, State) ->
+ Nodes = test_server_node:kill_nodes(),
+ {reply, Nodes, State};
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% handle_call({set_hosts, HostList}, From, State) -> ok
+%%
+%% Set the global hostlist.
+%%
+handle_call({set_hosts, Hosts}, _From, State) ->
+ set_hosts(Hosts),
+ {reply, ok, State};
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% handle_call(get_hosts, From, State) -> [Hosts]
+%%
+%% Returns the lists of hosts that the test server
+%% can use for slave nodes. This is primarily used
+%% for nodename generation.
+%%
+handle_call(get_hosts, _From, State) ->
+ Hosts = get_hosts(),
+ {reply, Hosts, State};
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% handle_call({add_job,Dir,Name,TopCase,Skip}, _, State) ->
+%% ok | {error,Reason}
+%%
+%% Dir = string()
+%% Name = string()
+%% TopCase = term()
+%% Skip = [SkipItem]
+%% SkipItem = {Mod,Comment} | {Mod,Case,Comment} | {Mod,Cases,Comment}
+%% Mod = Case = atom()
+%% Comment = string()
+%% Cases = [Case]
+%%
+%% Adds a job to the job queue. The name of the job is Name. A log directory
+%% will be created in Dir/Name.logs. TopCase may be anything that
+%% collect_cases/3 accepts, plus the following:
+%%
+%% {spec,SpecName} executes the named test suite specification file. Commands
+%% in the file should be in the format accepted by do_spec_list/1.
+%%
+%% {command_line,SpecList} executes the list of specification instructions
+%% supplied, which should be in the format accepted by do_spec_list/1.
+
+handle_call({add_job,Dir,Name,TopCase,Skip}, _From, State) ->
+ LogDir = Dir ++ ?logdir_ext,
+ ExtraTools =
+ case State#state.cover of
+ false -> [];
+ CoverInfo -> [{cover,CoverInfo}]
+ end,
+ ExtraTools1 =
+ case State#state.random_seed of
+ undefined -> ExtraTools;
+ Seed -> [{random_seed,Seed}|ExtraTools]
+ end,
+ case lists:keysearch(Name, 1, State#state.jobs) of
+ false ->
+ case TopCase of
+ {spec,SpecName} ->
+ Pid = spawn_tester(
+ ?MODULE, do_spec,
+ [SpecName,{State#state.multiply_timetraps,
+ State#state.scale_timetraps}],
+ LogDir, Name, State#state.levels,
+ State#state.reject_io_reqs,
+ State#state.create_priv_dir,
+ State#state.testcase_callback, ExtraTools1),
+ NewJobs = [{Name,Pid}|State#state.jobs],
+ {reply, ok, State#state{jobs=NewJobs}};
+ {command_line,SpecList} ->
+ Pid = spawn_tester(
+ ?MODULE, do_spec_list,
+ [SpecList,{State#state.multiply_timetraps,
+ State#state.scale_timetraps}],
+ LogDir, Name, State#state.levels,
+ State#state.reject_io_reqs,
+ State#state.create_priv_dir,
+ State#state.testcase_callback, ExtraTools1),
+ NewJobs = [{Name,Pid}|State#state.jobs],
+ {reply, ok, State#state{jobs=NewJobs}};
+ TopCase ->
+ case State#state.get_totals of
+ {CliPid,Fun} ->
+ Result = count_test_cases(TopCase, Skip),
+ Fun(CliPid, Result),
+ {reply, ok, State};
+ _ ->
+ Cfg = make_config([]),
+ Pid = spawn_tester(
+ ?MODULE, do_test_cases,
+ [TopCase,Skip,Cfg,
+ {State#state.multiply_timetraps,
+ State#state.scale_timetraps}],
+ LogDir, Name, State#state.levels,
+ State#state.reject_io_reqs,
+ State#state.create_priv_dir,
+ State#state.testcase_callback, ExtraTools1),
+ NewJobs = [{Name,Pid}|State#state.jobs],
+ {reply, ok, State#state{jobs=NewJobs}}
+ end
+ end;
+ _ ->
+ {reply,{error,name_already_in_use},State}
+ end;
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% handle_call(jobs, _, State) -> JobList
+%% JobList = [{Name,Pid}, ...]
+%% Name = string()
+%% Pid = pid()
+%%
+%% Return the list of current jobs.
+
+handle_call(jobs, _From, State) ->
+ {reply,State#state.jobs,State};
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% handle_call({abort_current_testcase,Reason}, _, State) -> Result
+%% Reason = term()
+%% Result = ok | {error,no_testcase_running}
+%%
+%% Attempts to abort the test case that's currently running.
+
+handle_call({abort_current_testcase,Reason}, _From, State) ->
+ case State#state.jobs of
+ [{_,Pid}|_] ->
+ Pid ! {abort_current_testcase,Reason,self()},
+ receive
+ {Pid,abort_current_testcase,Result} ->
+ {reply, Result, State}
+ after 10000 ->
+ {reply, {error,no_testcase_running}, State}
+ end;
+ _ ->
+ {reply, {error,no_testcase_running}, State}
+ end;
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% handle_call({finish,Fini}, _, State) -> {ok,Pid}
+%% Fini = true | abort
+%%
+%% Tells the test_server to stop as soon as there are no test suites
+%% running. Immediately if none are running. Abort is handled as soon
+%% as current test finishes.
+
+handle_call({finish,Fini}, _From, State) ->
+ case State#state.jobs of
+ [] ->
+ lists:foreach(fun({Cli,Fun}) -> Fun(Cli,Fini) end,
+ State#state.idle_notify),
+ State2 = State#state{finish=false},
+ {stop,shutdown,{ok,self()}, State2};
+ _SomeJobs ->
+ State2 = State#state{finish=Fini},
+ {reply, {ok,self()}, State2}
+ end;
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% handle_call({idle_notify,Fun}, From, State) -> {ok,Pid}
+%%
+%% Lets a test client subscribe to receive a notification when the
+%% test server becomes idle (can be used to syncronize jobs).
+%% test_server calls Fun(From) when idle.
+
+handle_call({idle_notify,Fun}, {Cli,_Ref}, State) ->
+ case State#state.jobs of
+ [] -> self() ! report_idle;
+ _ -> ok
+ end,
+ Subscribed = State#state.idle_notify,
+ {reply, {ok,self()}, State#state{idle_notify=[{Cli,Fun}|Subscribed]}};
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% handle_call(start_get_totals, From, State) -> {ok,Pid}
+%%
+%% Switch on the mode where the test server will only
+%% report back the number of tests it would execute
+%% given some subsequent jobs.
+
+handle_call({start_get_totals,Fun}, {Cli,_Ref}, State) ->
+ {reply, {ok,self()}, State#state{get_totals={Cli,Fun}}};
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% handle_call(stop_get_totals, From, State) -> ok
+%%
+%% Lets a test client subscribe to receive a notification when the
+%% test server becomes idle (can be used to syncronize jobs).
+%% test_server calls Fun(From) when idle.
+
+handle_call(stop_get_totals, {_Cli,_Ref}, State) ->
+ {reply, ok, State#state{get_totals=false}};
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% handle_call(get_levels, _, State) -> {Show,Major,Minor}
+%% Show = integer()
+%% Major = integer()
+%% Minor = integer()
+%%
+%% Returns a 3-tuple with the logging thresholds.
+%% All output and information from a test suite is tagged with a detail
+%% level. Lower values are more "important". Text that is output using
+%% io:format or similar is automatically tagged with detail level 50.
+%%
+%% All output with detail level:
+%% less or equal to Show is displayed on the screen (default 1)
+%% less or equal to Major is logged in the major log file (default 19)
+%% greater or equal to Minor is logged in the minor log files (default 10)
+
+handle_call(get_levels, _From, State) ->
+ {reply,State#state.levels,State};
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% handle_call({set_levels,Show,Major,Minor}, _, State) -> ok
+%% Show = integer()
+%% Major = integer()
+%% Minor = integer()
+%%
+%% Sets the logging thresholds, see handle_call(get_levels,...) above.
+
+handle_call({set_levels,Show,Major,Minor}, _From, State) ->
+ {reply,ok,State#state{levels={Show,Major,Minor}}};
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% handle_call({reject_io_reqs,Bool}, _, State) -> ok
+%% Bool = bool()
+%%
+%% May be used to switch off stdout printouts to the minor log file
+
+handle_call({reject_io_reqs,Bool}, _From, State) ->
+ {reply,ok,State#state{reject_io_reqs=Bool}};
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% handle_call({multiply_timetraps,N}, _, State) -> ok
+%% N = integer() | infinity
+%%
+%% Multiplies all timetraps set by test cases with N
+
+handle_call({multiply_timetraps,N}, _From, State) ->
+ {reply,ok,State#state{multiply_timetraps=N}};
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% handle_call({scale_timetraps,Bool}, _, State) -> ok
+%% Bool = true | false
+%%
+%% Specifies if test_server should scale the timetrap value
+%% automatically if e.g. cover is running.
+
+handle_call({scale_timetraps,Bool}, _From, State) ->
+ {reply,ok,State#state{scale_timetraps=Bool}};
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% handle_call(get_timetrap_parameters, _, State) -> {Multiplier,Scale}
+%% Multiplier = integer() | infinity
+%% Scale = true | false
+%%
+%% Returns the parameter values that affect timetraps.
+
+handle_call(get_timetrap_parameters, _From, State) ->
+ {reply,{State#state.multiply_timetraps,State#state.scale_timetraps},State};
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% handle_call({trace,TraceFile}, _, State) -> ok | {error,Reason}
+%%
+%% Starts a separate node (trace control node) which
+%% starts tracing on target and all slave nodes
+%%
+%% TraceFile is a text file with elements of type
+%% {Trace,Mod,TracePattern}.
+%% {Trace,Mod,Func,TracePattern}.
+%% {Trace,Mod,Func,Arity,TracePattern}.
+%%
+%% Trace = tp | tpl; local or global call trace
+%% Mod,Func = atom(), Arity=integer(); defines what to trace
+%% TracePattern = [] | match_spec()
+%%
+%% The 'call' trace flag is set on all processes, and then
+%% the given trace patterns are set.
+
+handle_call({trace,TraceFile}, _From, State=#state{trc=false}) ->
+ TI = State#state.target_info,
+ case test_server_node:start_tracer_node(TraceFile, TI) of
+ {ok,Tracer} -> {reply,ok,State#state{trc=Tracer}};
+ Error -> {reply,Error,State}
+ end;
+handle_call({trace,_TraceFile}, _From, State) ->
+ {reply,{error,already_tracing},State};
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% handle_call(stop_trace, _, State) -> ok | {error,Reason}
+%%
+%% Stops tracing on target and all slave nodes and
+%% terminates trace control node
+
+handle_call(stop_trace, _From, State=#state{trc=false}) ->
+ {reply,{error,not_tracing},State};
+handle_call(stop_trace, _From, State) ->
+ R = test_server_node:stop_tracer_node(State#state.trc),
+ {reply,R,State#state{trc=false}};
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% handle_call({cover,CoverInfo}, _, State) -> ok | {error,Reason}
+%%
+%% Set specification of cover analysis to be used when running tests
+%% (see start_extra_tools/1 and stop_extra_tools/1)
+
+handle_call({cover,CoverInfo}, _From, State) ->
+ {reply,ok,State#state{cover=CoverInfo}};
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% handle_call({create_priv_dir,Value}, _, State) -> ok | {error,Reason}
+%%
+%% Set create_priv_dir to either auto_per_run (create common priv dir once
+%% per test run), manual_per_tc (the priv dir name will be unique for each
+%% test case, but the user has to call test_server:make_priv_dir/0 to create
+%% it), or auto_per_tc (unique priv dir created automatically for each test
+%% case).
+
+handle_call({create_priv_dir,Value}, _From, State) ->
+ {reply,ok,State#state{create_priv_dir=Value}};
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% handle_call({testcase_callback,{Mod,Func}}, _, State) -> ok | {error,Reason}
+%%
+%% Add a callback function that will be called before and after every
+%% test case (on the test case process):
+%%
+%% Mod:Func(Suite,TestCase,InitOrEnd,Config)
+%%
+%% InitOrEnd = init | 'end'.
+
+handle_call({testcase_callback,ModFunc}, _From, State) ->
+ case ModFunc of
+ {Mod,Func} ->
+ case code:is_loaded(Mod) of
+ {file,_} ->
+ ok;
+ false ->
+ code:load_file(Mod)
+ end,
+ case erlang:function_exported(Mod,Func,4) of
+ true ->
+ ok;
+ false ->
+ io:format(user,
+ "WARNING! Callback function ~w:~w/4 undefined.~n~n",
+ [Mod,Func])
+ end;
+ _ ->
+ ok
+ end,
+ {reply,ok,State#state{testcase_callback=ModFunc}};
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% handle_call({set_random_seed,Seed}, _, State) -> ok | {error,Reason}
+%%
+%% Let operator set a random seed value to be used e.g. for shuffling
+%% test cases.
+
+handle_call({set_random_seed,Seed}, _From, State) ->
+ {reply,ok,State#state{random_seed=Seed}};
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% handle_call(stop, _, State) -> ok
+%%
+%% Stops the test server immediately.
+%% Some cleanup is done by terminate/2
+
+handle_call(stop, _From, State) ->
+ {stop, shutdown, ok, State};
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% handle_call(get_target_info, _, State) -> TI
+%%
+%% TI = #target_info{}
+%%
+%% Returns information about target
+
+handle_call(get_target_info, _From, State) ->
+ {reply, State#state.target_info, State};
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% handle_call({start_node,Name,Type,Options}, _, State) ->
+%% ok | {error,Reason}
+%%
+%% Starts a new node (slave or peer)
+
+handle_call({start_node, Name, Type, Options}, From, State) ->
+ %% test_server_ctrl does gen_server:reply/2 explicitly
+ test_server_node:start_node(Name, Type, Options, From,
+ State#state.target_info),
+ {noreply,State};
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% handle_call({wait_for_node,Node}, _, State) -> ok
+%%
+%% Waits for a new node to take contact. Used if
+%% node is started with option {wait,false}
+
+handle_call({wait_for_node, Node}, From, State) ->
+ NewWaitList =
+ case ets:lookup(slave_tab,Node) of
+ [] ->
+ [{Node,From}|State#state.wait_for_node];
+ _ ->
+ gen_server:reply(From,ok),
+ State#state.wait_for_node
+ end,
+ {noreply,State#state{wait_for_node=NewWaitList}};
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% handle_call({stop_node,Name}, _, State) -> ok | {error,Reason}
+%%
+%% Stops a slave or peer node. This is actually only some cleanup
+%% - the node is really stopped by test_server when this returns.
+
+handle_call({stop_node, Name}, _From, State) ->
+ R = test_server_node:stop_node(Name),
+ {reply, R, State};
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% handle_call({is_release_available,Name}, _, State) -> ok | {error,Reason}
+%%
+%% Tests if the release is available.
+
+handle_call({is_release_available, Release}, _From, State) ->
+ R = test_server_node:is_release_available(Release),
+ {reply, R, State}.
+
+%%--------------------------------------------------------------------
+set_hosts(Hosts) ->
+ put(test_server_hosts, Hosts).
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% handle_cast({node_started,Name}, _, State)
+%%
+%% Called by test_server_node when a slave/peer node is fully started.
+
+handle_cast({node_started,Node}, State) ->
+ case State#state.trc of
+ false -> ok;
+ Trc -> test_server_node:trace_nodes(Trc, [Node])
+ end,
+ NewWaitList =
+ case lists:keysearch(Node,1,State#state.wait_for_node) of
+ {value,{Node,From}} ->
+ gen_server:reply(From, ok),
+ lists:keydelete(Node, 1, State#state.wait_for_node);
+ false ->
+ State#state.wait_for_node
+ end,
+ {noreply, State#state{wait_for_node=NewWaitList}}.
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% handle_info({'EXIT',Pid,Reason}, State)
+%% Pid = pid()
+%% Reason = term()
+%%
+%% Handles exit messages from linked processes. Only test suites are
+%% expected to be linked. When a test suite terminates, it is removed
+%% from the job queue.
+
+handle_info(report_idle, State) ->
+ Finish = State#state.finish,
+ lists:foreach(fun({Cli,Fun}) -> Fun(Cli,Finish) end,
+ State#state.idle_notify),
+ {noreply,State#state{idle_notify=[]}};
+
+
+handle_info({'EXIT',Pid,Reason}, State) ->
+ case lists:keysearch(Pid,2,State#state.jobs) of
+ false ->
+ %% not our problem
+ {noreply,State};
+ {value,{Name,_}} ->
+ NewJobs = lists:keydelete(Pid, 2, State#state.jobs),
+ case Reason of
+ normal ->
+ fine;
+ killed ->
+ io:format("Suite ~ts was killed\n", [Name]);
+ _Other ->
+ io:format("Suite ~ts was killed with reason ~p\n",
+ [Name,Reason])
+ end,
+ State2 = State#state{jobs=NewJobs},
+ Finish = State2#state.finish,
+ case NewJobs of
+ [] ->
+ lists:foreach(fun({Cli,Fun}) -> Fun(Cli,Finish) end,
+ State2#state.idle_notify),
+ case Finish of
+ false ->
+ {noreply,State2#state{idle_notify=[]}};
+ _ -> % true | abort
+ %% test_server:finish() has been called and
+ %% there are no jobs in the job queue =>
+ %% stop the test_server_ctrl
+ {stop,shutdown,State2#state{finish=false}}
+ end;
+ _ -> % pending jobs
+ case Finish of
+ abort -> % abort test now!
+ lists:foreach(fun({Cli,Fun}) -> Fun(Cli,Finish) end,
+ State2#state.idle_notify),
+ {stop,shutdown,State2#state{finish=false}};
+ _ -> % true | false
+ {noreply, State2}
+ end
+ end
+ end;
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% handle_info({tcp_closed,Sock}, State)
+%%
+%% A Socket was closed. This indicates that a node died.
+%% This can be
+%% *Slave or peer node started by a test suite
+%% *Trace controll node
+
+handle_info({tcp_closed,Sock}, State=#state{trc=Sock}) ->
+ %% Tracer node died - can't really do anything
+ %%! Maybe print something???
+ {noreply,State#state{trc=false}};
+handle_info({tcp_closed,Sock}, State) ->
+ test_server_node:nodedown(Sock),
+ {noreply,State};
+handle_info(_, State) ->
+ %% dummy; accept all, do nothing.
+ {noreply, State}.
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% terminate(Reason, State) -> ok
+%% Reason = term()
+%%
+%% Cleans up when the test_server is terminating. Kills the running
+%% test suites (if any) and any possible remainting slave node
+
+terminate(_Reason, State) ->
+ test_server_sup:util_stop(),
+ case State#state.trc of
+ false -> ok;
+ Sock -> test_server_node:stop_tracer_node(Sock)
+ end,
+ kill_all_jobs(State#state.jobs),
+ test_server_node:kill_nodes(),
+ ok.
+
+kill_all_jobs([{_Name,JobPid}|Jobs]) ->
+ exit(JobPid, kill),
+ kill_all_jobs(Jobs);
+kill_all_jobs([]) ->
+ ok.
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%%----------------------- INTERNAL FUNCTIONS -----------------------%%
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% spawn_tester(Mod, Func, Args, Dir, Name, Levels, RejectIoReqs,
+%% CreatePrivDir, TestCaseCallback, ExtraTools) -> Pid
+%% Mod = atom()
+%% Func = atom()
+%% Args = [term(),...]
+%% Dir = string()
+%% Name = string()
+%% Levels = {integer(),integer(),integer()}
+%% RejectIoReqs = bool()
+%% CreatePrivDir = auto_per_run | manual_per_tc | auto_per_tc
+%% TestCaseCallback = {CBMod,CBFunc} | undefined
+%% ExtraTools = [ExtraTool,...]
+%% ExtraTool = CoverInfo | TraceInfo | RandomSeed
+%%
+%% Spawns a test suite execute-process, just an ordinary spawn, except
+%% that it will set a lot of dictionary information before starting the
+%% named function. Also, the execution is timed and protected by a catch.
+%% When the named function is done executing, a summary of the results
+%% is printed to the log files.
+
+spawn_tester(Mod, Func, Args, Dir, Name, Levels, RejectIoReqs,
+ CreatePrivDir, TCCallback, ExtraTools) ->
+ spawn_link(fun() ->
+ init_tester(Mod, Func, Args, Dir, Name, Levels, RejectIoReqs,
+ CreatePrivDir, TCCallback, ExtraTools)
+ end).
+
+init_tester(Mod, Func, Args, Dir, Name, {_,_,MinLev}=Levels,
+ RejectIoReqs, CreatePrivDir, TCCallback, ExtraTools) ->
+ process_flag(trap_exit, true),
+ test_server_io:start_link(),
+ put(test_server_name, Name),
+ put(test_server_dir, Dir),
+ put(test_server_total_time, 0),
+ put(test_server_ok, 0),
+ put(test_server_failed, 0),
+ put(test_server_skipped, {0,0}),
+ put(test_server_minor_level, MinLev),
+ put(test_server_create_priv_dir, CreatePrivDir),
+ put(test_server_random_seed, proplists:get_value(random_seed, ExtraTools)),
+ put(test_server_testcase_callback, TCCallback),
+ case os:getenv("TEST_SERVER_FRAMEWORK") of
+ FW when FW =:= false; FW =:= "undefined" ->
+ put(test_server_framework, '$none');
+ FW ->
+ put(test_server_framework_name, list_to_atom(FW)),
+ case os:getenv("TEST_SERVER_FRAMEWORK_NAME") of
+ FWName when FWName =:= false; FWName =:= "undefined" ->
+ put(test_server_framework_name, '$none');
+ FWName ->
+ put(test_server_framework_name, list_to_atom(FWName))
+ end
+ end,
+
+ %% before first print, read and set logging options
+ LogOpts = test_server_sup:framework_call(get_logopts, [], []),
+ put(test_server_logopts, LogOpts),
+
+ StartedExtraTools = start_extra_tools(ExtraTools),
+
+ test_server_io:set_job_name(Name),
+ test_server_io:set_gl_props([{levels,Levels},
+ {auto_nl,not lists:member(no_nl, LogOpts)},
+ {reject_io_reqs,RejectIoReqs}]),
+ group_leader(test_server_io:get_gl(true), self()),
+ {TimeMy,Result} = ts_tc(Mod, Func, Args),
+ set_io_buffering(undefined),
+ test_server_io:set_job_name(undefined),
+ catch stop_extra_tools(StartedExtraTools),
+ case Result of
+ {'EXIT',test_suites_done} ->
+ ok;
+ {'EXIT',_Pid,Reason} ->
+ print(1, "EXIT, reason ~p", [Reason]);
+ {'EXIT',Reason} ->
+ report_severe_error(Reason),
+ print(1, "EXIT, reason ~p", [Reason])
+ end,
+ Time = TimeMy/1000000,
+ SuccessStr =
+ case get(test_server_failed) of
+ 0 -> "Ok";
+ _ -> "FAILED"
+ end,
+ {SkippedN,SkipStr} =
+ case get(test_server_skipped) of
+ {0,0} ->
+ {0,""};
+ {USkipped,ASkipped} ->
+ Skipped = USkipped+ASkipped,
+ {Skipped,io_lib:format(", ~w Skipped", [Skipped])}
+ end,
+ OkN = get(test_server_ok),
+ FailedN = get(test_server_failed),
+ print(html,"\n</tbody>\n<tfoot>\n"
+ "<tr><td></td><td><b>TOTAL</b></td><td></td><td></td><td></td>"
+ "<td>~.3fs</td><td><b>~ts</b></td><td>~w Ok, ~w Failed~ts of ~w</td></tr>\n"
+ "</tfoot>\n",
+ [Time,SuccessStr,OkN,FailedN,SkipStr,OkN+FailedN+SkippedN]),
+
+ test_server_io:stop([major,html,unexpected_io]),
+ {UnexpectedIoName,UnexpectedIoFooter} = get(test_server_unexpected_footer),
+ {ok,UnexpectedIoFd} = open_html_file(UnexpectedIoName, [append]),
+ io:put_chars(UnexpectedIoFd, "\n</pre>\n"++UnexpectedIoFooter),
+ file:close(UnexpectedIoFd),
+ ok.
+
+report_severe_error(Reason) ->
+ test_server_sup:framework_call(report, [severe_error,Reason]).
+
+ts_tc(M,F,A) ->
+ Before = erlang:monotonic_time(),
+ Result = (catch apply(M, F, A)),
+ After = erlang:monotonic_time(),
+ Elapsed = erlang:convert_time_unit(After-Before,
+ native,
+ micro_seconds),
+ {Elapsed, Result}.
+
+start_extra_tools(ExtraTools) ->
+ start_extra_tools(ExtraTools, []).
+start_extra_tools([{cover,CoverInfo} | ExtraTools], Started) ->
+ case start_cover(CoverInfo) of
+ {ok,NewCoverInfo} ->
+ start_extra_tools(ExtraTools,[{cover,NewCoverInfo}|Started]);
+ {error,_} ->
+ start_extra_tools(ExtraTools, Started)
+ end;
+start_extra_tools([_ | ExtraTools], Started) ->
+ start_extra_tools(ExtraTools, Started);
+start_extra_tools([], Started) ->
+ Started.
+
+stop_extra_tools(ExtraTools) ->
+ TestDir = get(test_server_log_dir_base),
+ case lists:keymember(cover, 1, ExtraTools) of
+ false ->
+ write_default_coverlog(TestDir);
+ true ->
+ ok
+ end,
+ stop_extra_tools(ExtraTools, TestDir).
+
+stop_extra_tools([{cover,CoverInfo}|ExtraTools], TestDir) ->
+ stop_cover(CoverInfo,TestDir),
+ stop_extra_tools(ExtraTools, TestDir);
+%%stop_extra_tools([_ | ExtraTools], TestDir) ->
+%% stop_extra_tools(ExtraTools, TestDir);
+stop_extra_tools([], _) ->
+ ok.
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% do_spec(SpecName, TimetrapSpec) -> {error,Reason} | exit(Result)
+%% SpecName = string()
+%% TimetrapSpec = MultiplyTimetrap | {MultiplyTimetrap,ScaleTimetrap}
+%% MultiplyTimetrap = integer() | infinity
+%% ScaleTimetrap = bool()
+%%
+%% Reads the named test suite specification file, and executes it.
+%%
+%% This function is meant to be called by a process created by
+%% spawn_tester/10, which sets up some necessary dictionary values.
+
+do_spec(SpecName, TimetrapSpec) when is_list(SpecName) ->
+ case file:consult(SpecName) of
+ {ok,TermList} ->
+ do_spec_list(TermList,TimetrapSpec);
+ {error,Reason} ->
+ io:format("Can't open ~ts: ~p\n", [SpecName,Reason]),
+ {error,{cant_open_spec,Reason}}
+ end.
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% do_spec_list(TermList, TimetrapSpec) -> exit(Result)
+%% TermList = [term()|...]
+%% TimetrapSpec = MultiplyTimetrap | {MultiplyTimetrap,ScaleTimetrap}
+%% MultiplyTimetrap = integer() | infinity
+%% ScaleTimetrap = bool()
+%%
+%% Executes a list of test suite specification commands. The following
+%% commands are available, and may occur zero or more times (if several,
+%% the contents is appended):
+%%
+%% {topcase,TopCase} Specifies top level test goals. TopCase has the syntax
+%% specified by collect_cases/3.
+%%
+%% {skip,Skip} Specifies test cases to skip, and lists requirements that
+%% cannot be granted during the test run. Skip has the syntax specified
+%% by collect_cases/3.
+%%
+%% {nodes,Nodes} Lists node names avaliable to the test suites. Nodes have
+%% the syntax specified by collect_cases/3.
+%%
+%% {require_nodenames, Num} Specifies how many nodenames the test suite will
+%% need. Theese are automaticly generated and inserted into the Config by the
+%% test_server. The caller may specify other hosts to run theese nodes by
+%% using the {hosts, Hosts} option. If there are no hosts specified, all
+%% nodenames will be generated from the local host.
+%%
+%% {hosts, Hosts} Specifies a list of available hosts on which to start
+%% slave nodes. It is used when the {remote, true} option is given to the
+%% test_server:start_node/3 function. Also, if {require_nodenames, Num} is
+%% contained in the TermList, the generated nodenames will be spread over
+%% all hosts given in this Hosts list. The hostnames are given as atoms or
+%% strings.
+%%
+%% {diskless, true}</c></tag> is kept for backwards compatiblilty and
+%% should not be used. Use a configuration test case instead.
+%%
+%% This function is meant to be called by a process created by
+%% spawn_tester/10, which sets up some necessary dictionary values.
+
+do_spec_list(TermList0, TimetrapSpec) ->
+ Nodes = [],
+ TermList =
+ case lists:keysearch(hosts, 1, TermList0) of
+ {value, {hosts, Hosts0}} ->
+ Hosts = lists:map(fun(H) -> cast_to_list(H) end, Hosts0),
+ controller_call({set_hosts, Hosts}),
+ lists:keydelete(hosts, 1, TermList0);
+ _ ->
+ TermList0
+ end,
+ DefaultConfig = make_config([{nodes,Nodes}]),
+ {TopCases,SkipList,Config} = do_spec_terms(TermList, [], [], DefaultConfig),
+ do_test_cases(TopCases, SkipList, Config, TimetrapSpec).
+
+do_spec_terms([], TopCases, SkipList, Config) ->
+ {TopCases,SkipList,Config};
+do_spec_terms([{topcase,TopCase}|Terms], TopCases, SkipList, Config) ->
+ do_spec_terms(Terms,[TopCase|TopCases], SkipList, Config);
+do_spec_terms([{skip,Skip}|Terms], TopCases, SkipList, Config) ->
+ do_spec_terms(Terms, TopCases, [Skip|SkipList], Config);
+do_spec_terms([{nodes,Nodes}|Terms], TopCases, SkipList, Config) ->
+ do_spec_terms(Terms, TopCases, SkipList,
+ update_config(Config, {nodes,Nodes}));
+do_spec_terms([{diskless,How}|Terms], TopCases, SkipList, Config) ->
+ do_spec_terms(Terms, TopCases, SkipList,
+ update_config(Config, {diskless,How}));
+do_spec_terms([{config,MoreConfig}|Terms], TopCases, SkipList, Config) ->
+ do_spec_terms(Terms, TopCases, SkipList, Config++MoreConfig);
+do_spec_terms([{default_timeout,Tmo}|Terms], TopCases, SkipList, Config) ->
+ do_spec_terms(Terms, TopCases, SkipList,
+ update_config(Config, {default_timeout,Tmo}));
+
+do_spec_terms([{require_nodenames,NumNames}|Terms], TopCases, SkipList, Config) ->
+ NodeNames0=generate_nodenames(NumNames),
+ NodeNames=lists:delete([], NodeNames0),
+ do_spec_terms(Terms, TopCases, SkipList,
+ update_config(Config, {nodenames,NodeNames}));
+do_spec_terms([Other|Terms], TopCases, SkipList, Config) ->
+ io:format("** WARNING: Spec file contains unknown directive ~p\n",
+ [Other]),
+ do_spec_terms(Terms, TopCases, SkipList, Config).
+
+
+
+generate_nodenames(Num) ->
+ Hosts = case controller_call(get_hosts) of
+ [] ->
+ TI = controller_call(get_target_info),
+ [TI#target_info.host];
+ List ->
+ List
+ end,
+ generate_nodenames2(Num, Hosts, []).
+
+generate_nodenames2(0, _Hosts, Acc) ->
+ Acc;
+generate_nodenames2(N, Hosts, Acc) ->
+ Host=lists:nth((N rem (length(Hosts)))+1, Hosts),
+ Name=list_to_atom(temp_nodename("nod", []) ++ "@" ++ Host),
+ generate_nodenames2(N-1, Hosts, [Name|Acc]).
+
+temp_nodename([], Acc) ->
+ lists:flatten(Acc);
+temp_nodename([Chr|Base], Acc) ->
+ {A,B,C} = ?now,
+ New = [Chr | integer_to_list(Chr bxor A bxor B+A bxor C+B)],
+ temp_nodename(Base, [New|Acc]).
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% count_test_cases(TopCases, SkipCases) -> {Suites,NoOfCases} | error
+%% TopCases = term() (See collect_cases/3)
+%% SkipCases = term() (See collect_cases/3)
+%% Suites = list()
+%% NoOfCases = integer() | unknown
+%%
+%% Counts the test cases that are about to run and returns that number.
+%% If there's a conf group in TestSpec with a repeat property, the total number
+%% of cases can not be calculated and NoOfCases = unknown.
+count_test_cases(TopCases, SkipCases) when is_list(TopCases) ->
+ case collect_all_cases(TopCases, SkipCases) of
+ {error,_Why} = Error ->
+ Error;
+ TestSpec ->
+ {get_suites(TestSpec, []),
+ case remove_conf(TestSpec) of
+ {repeats,_} ->
+ unknown;
+ TestSpec1 ->
+ length(TestSpec1)
+ end}
+ end;
+
+count_test_cases(TopCase, SkipCases) ->
+ count_test_cases([TopCase], SkipCases).
+
+
+remove_conf(Cases) ->
+ remove_conf(Cases, [], false).
+
+remove_conf([{conf, _Ref, Props, _MF}|Cases], NoConf, Repeats) ->
+ case get_repeat(Props) of
+ undefined ->
+ remove_conf(Cases, NoConf, Repeats);
+ {_RepType,1} ->
+ remove_conf(Cases, NoConf, Repeats);
+ _ ->
+ remove_conf(Cases, NoConf, true)
+ end;
+remove_conf([{make,_Ref,_MF}|Cases], NoConf, Repeats) ->
+ remove_conf(Cases, NoConf, Repeats);
+remove_conf([{skip_case,{{_M,all},_Cmt},_Mode}|Cases], NoConf, Repeats) ->
+ remove_conf(Cases, NoConf, Repeats);
+remove_conf([{skip_case,{Type,_Ref,_MF,_Cmt}}|Cases],
+ NoConf, Repeats) when Type==conf;
+ Type==make ->
+ remove_conf(Cases, NoConf, Repeats);
+remove_conf([{skip_case,{Type,_Ref,_MF,_Cmt},_Mode}|Cases],
+ NoConf, Repeats) when Type==conf;
+ Type==make ->
+ remove_conf(Cases, NoConf, Repeats);
+remove_conf([C={Mod,error_in_suite,_}|Cases], NoConf, Repeats) ->
+ FwMod = get_fw_mod(?MODULE),
+ if Mod == FwMod ->
+ remove_conf(Cases, NoConf, Repeats);
+ true ->
+ remove_conf(Cases, [C|NoConf], Repeats)
+ end;
+remove_conf([C|Cases], NoConf, Repeats) ->
+ remove_conf(Cases, [C|NoConf], Repeats);
+remove_conf([], NoConf, true) ->
+ {repeats,lists:reverse(NoConf)};
+remove_conf([], NoConf, false) ->
+ lists:reverse(NoConf).
+
+get_suites([{skip_case,{{Mod,_F},_Cmt},_Mode}|Tests], Mods) when is_atom(Mod) ->
+ case add_mod(Mod, Mods) of
+ true -> get_suites(Tests, [Mod|Mods]);
+ false -> get_suites(Tests, Mods)
+ end;
+get_suites([{Mod,_Case}|Tests], Mods) when is_atom(Mod) ->
+ case add_mod(Mod, Mods) of
+ true -> get_suites(Tests, [Mod|Mods]);
+ false -> get_suites(Tests, Mods)
+ end;
+get_suites([{Mod,_Func,_Args}|Tests], Mods) when is_atom(Mod) ->
+ case add_mod(Mod, Mods) of
+ true -> get_suites(Tests, [Mod|Mods]);
+ false -> get_suites(Tests, Mods)
+ end;
+get_suites([_|Tests], Mods) ->
+ get_suites(Tests, Mods);
+
+get_suites([], Mods) ->
+ lists:reverse(Mods).
+
+add_mod(Mod, Mods) ->
+ case string:rstr(atom_to_list(Mod), "_SUITE") of
+ 0 -> false;
+ _ -> % test suite
+ case lists:member(Mod, Mods) of
+ true -> false;
+ false -> true
+ end
+ end.
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% do_test_cases(TopCases, SkipCases, Config, TimetrapSpec) ->
+%% exit(Result)
+%%
+%% TopCases = term() (See collect_cases/3)
+%% SkipCases = term() (See collect_cases/3)
+%% Config = term() (See collect_cases/3)
+%% TimetrapSpec = MultiplyTimetrap | {MultiplyTimetrap,ScaleTimetrap}
+%% MultiplyTimetrap = integer() | infinity
+%% ScaleTimetrap = bool()
+%%
+%% Initializes and starts the test run, for "ordinary" test suites.
+%% Creates log directories and log files, inserts initial timestamps and
+%% configuration information into the log files.
+%%
+%% This function is meant to be called by a process created by
+%% spawn_tester/10, which sets up some necessary dictionary values.
+do_test_cases(TopCases, SkipCases,
+ Config, MultiplyTimetrap) when is_integer(MultiplyTimetrap);
+ MultiplyTimetrap == infinity ->
+ do_test_cases(TopCases, SkipCases, Config, {MultiplyTimetrap,true});
+
+do_test_cases(TopCases, SkipCases,
+ Config, TimetrapData) when is_list(TopCases),
+ is_tuple(TimetrapData) ->
+ {ok,TestDir} = start_log_file(),
+ FwMod = get_fw_mod(?MODULE),
+ case collect_all_cases(TopCases, SkipCases) of
+ {error,Why} ->
+ print(1, "Error starting: ~p", [Why]),
+ exit(test_suites_done);
+ TestSpec0 ->
+ N = case remove_conf(TestSpec0) of
+ {repeats,_} -> unknown;
+ TS -> length(TS)
+ end,
+ put(test_server_cases, N),
+ put(test_server_case_num, 0),
+
+ TestSpec =
+ add_init_and_end_per_suite(TestSpec0, undefined, undefined, FwMod),
+
+ TI = get_target_info(),
+ print(1, "Starting test~ts",
+ [print_if_known(N, {", ~w test cases",[N]},
+ {" (with repeated test cases)",[]})]),
+ Test = get(test_server_name),
+ TestName = if is_list(Test) ->
+ lists:flatten(io_lib:format("~ts", [Test]));
+ true ->
+ lists:flatten(io_lib:format("~tp", [Test]))
+ end,
+ TestDescr = "Test " ++ TestName ++ " results",
+
+ test_server_sup:framework_call(report, [tests_start,{Test,N}]),
+
+ {Header,Footer} =
+ case test_server_sup:framework_call(get_html_wrapper,
+ [TestDescr,true,TestDir,
+ {[],[2,3,4,7,8],[1,6]}], "") of
+ Empty when (Empty == "") ; (element(2,Empty) == "") ->
+ put(basic_html, true),
+ {[html_header(TestDescr),
+ "<h2>Results for test ", TestName, "</h2>\n"],
+ "\n</body>\n</html>\n"};
+ {basic_html,Html0,Html1} ->
+ put(basic_html, true),
+ {Html0++["<h1>Results for <i>",TestName,"</i></h1>\n"],
+ Html1};
+ {xhtml,Html0,Html1} ->
+ put(basic_html, false),
+ {Html0++["<h1>Results for <i>",TestName,"</i></h1>\n"],
+ Html1}
+ end,
+
+ print(html, Header),
+
+ print(html, xhtml("<p>", "<h4>")),
+ print_timestamp(html, "Test started at "),
+ print(html, xhtml("</p>", "</h4>")),
+
+ print(html, xhtml("\n<p><b>Host info:</b><br>\n",
+ "\n<p><b>Host info:</b><br />\n")),
+ print_who(test_server_sup:hoststr(), test_server_sup:get_username()),
+ print(html, xhtml("<br>Used Erlang v~ts in <tt>~ts</tt></p>\n",
+ "<br />Used Erlang v~ts in \"~ts\"</p>\n"),
+ [erlang:system_info(version), code:root_dir()]),
+
+ if FwMod == ?MODULE ->
+ print(html, xhtml("\n<p><b>Target Info:</b><br>\n",
+ "\n<p><b>Target Info:</b><br />\n")),
+ print_who(TI#target_info.host, TI#target_info.username),
+ print(html,xhtml("<br>Used Erlang v~ts in <tt>~ts</tt></p>\n",
+ "<br />Used Erlang v~ts in \"~ts\"</p>\n"),
+ [TI#target_info.version, TI#target_info.root_dir]);
+ true ->
+ case test_server_sup:framework_call(target_info, []) of
+ TargetInfo when is_list(TargetInfo),
+ length(TargetInfo) > 0 ->
+ print(html, xhtml("\n<p><b>Target info:</b><br>\n",
+ "\n<p><b>Target info:</b><br />\n")),
+ print(html, "~ts</p>\n", [TargetInfo]);
+ _ ->
+ ok
+ end
+ end,
+ CoverLog =
+ case get(test_server_cover_log_dir) of
+ undefined ->
+ ?coverlog_name;
+ AbsLogDir ->
+ AbsLog = filename:join(AbsLogDir,?coverlog_name),
+ make_relative(AbsLog, TestDir)
+ end,
+ print(html,
+ "<p><ul>\n"
+ "<li><a href=\"~ts\">Full textual log</a></li>\n"
+ "<li><a href=\"~ts\">Coverage log</a></li>\n"
+ "<li><a href=\"~ts\">Unexpected I/O log</a></li>\n</ul></p>\n",
+ [?suitelog_name,CoverLog,?unexpected_io_log]),
+ print(html,
+ "<p>~ts</p>\n" ++
+ xhtml(["<table bgcolor=\"white\" border=\"3\" cellpadding=\"5\">\n",
+ "<thead>\n"],
+ ["<table id=\"",?sortable_table_name,"\">\n",
+ "<thead>\n"]) ++
+ "<tr><th>Num</th><th>Module</th><th>Group</th>" ++
+ "<th>Case</th><th>Log</th><th>Time</th><th>Result</th>" ++
+ "<th>Comment</th></tr>\n</thead>\n<tbody>\n",
+ [print_if_known(N, {"<i>Executing <b>~w</b> test cases...</i>"
+ ++ xhtml("\n<br>\n", "\n<br />\n"),[N]},
+ {"",[]})]),
+
+ print(major, "=cases ~w", [get(test_server_cases)]),
+ print(major, "=user ~ts", [TI#target_info.username]),
+ print(major, "=host ~ts", [TI#target_info.host]),
+
+ %% If there are no hosts specified,use only the local host
+ case controller_call(get_hosts) of
+ [] ->
+ print(major, "=hosts ~ts", [TI#target_info.host]),
+ controller_call({set_hosts, [TI#target_info.host]});
+ Hosts ->
+ Str = lists:flatten(lists:map(fun(X) -> [X," "] end, Hosts)),
+ print(major, "=hosts ~ts", [Str])
+ end,
+ print(major, "=emulator_vsn ~ts", [TI#target_info.version]),
+ print(major, "=emulator ~ts", [TI#target_info.emulator]),
+ print(major, "=otp_release ~ts", [TI#target_info.otp_release]),
+ print(major, "=started ~s",
+ [lists:flatten(timestamp_get(""))]),
+
+ test_server_io:set_footer(Footer),
+
+ run_test_cases(TestSpec, Config, TimetrapData)
+ end;
+
+do_test_cases(TopCase, SkipCases, Config, TimetrapSpec) ->
+ %% when not list(TopCase)
+ do_test_cases([TopCase], SkipCases, Config, TimetrapSpec).
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% start_log_file() -> {ok,TestDirName} | exit({Error,Reason})
+%% Stem = string()
+%%
+%% Creates the log directories, the major log file and the html log file.
+%% The log files are initialized with some header information.
+%%
+%% The name of the log directory will be <Name>.logs/run.<Date>/ where
+%% Name is the test suite name and Date is the current date and time.
+
+start_log_file() ->
+ Dir = get(test_server_dir),
+ case file:make_dir(Dir) of
+ ok ->
+ ok;
+ {error, eexist} ->
+ ok;
+ MkDirError ->
+ log_file_error(MkDirError, Dir)
+ end,
+ TestDir = timestamp_filename_get(filename:join(Dir, "run.")),
+ TestDir1 =
+ case file:make_dir(TestDir) of
+ ok ->
+ TestDir;
+ {error,eexist} ->
+ timer:sleep(1000),
+ %% we need min 1 second between timestamps unfortunately
+ TestDirX = timestamp_filename_get(filename:join(Dir, "run.")),
+ case file:make_dir(TestDirX) of
+ ok ->
+ TestDirX;
+ MkDirError2 ->
+ log_file_error(MkDirError2, TestDirX)
+ end;
+ MkDirError2 ->
+ log_file_error(MkDirError2, TestDir)
+ end,
+ FilenameMode = file:native_name_encoding(),
+ ok = write_file(filename:join(Dir, ?last_file),
+ TestDir1 ++ "\n",
+ FilenameMode),
+ ok = write_file(?last_file, TestDir1 ++ "\n", FilenameMode),
+ put(test_server_log_dir_base,TestDir1),
+
+ MajorName = filename:join(TestDir1, ?suitelog_name),
+ HtmlName = MajorName ++ ?html_ext,
+ UnexpectedName = filename:join(TestDir1, ?unexpected_io_log),
+
+ {ok,Major} = open_utf8_file(MajorName),
+ {ok,Html} = open_html_file(HtmlName),
+
+ {UnexpHeader,UnexpFooter} =
+ case test_server_sup:framework_call(get_html_wrapper,
+ ["Unexpected I/O log",false,
+ TestDir, undefined],"") of
+ UEmpty when (UEmpty == "") ; (element(2,UEmpty) == "") ->
+ {html_header("Unexpected I/O log"),"\n</body>\n</html>\n"};
+ {basic_html,UH,UF} ->
+ {UH,UF};
+ {xhtml,UH,UF} ->
+ {UH,UF}
+ end,
+
+ {ok,Unexpected} = open_html_file(UnexpectedName),
+ io:put_chars(Unexpected, [UnexpHeader,
+ xhtml("<br>\n<h2>Unexpected I/O</h2>",
+ "<br />\n<h3>Unexpected I/O</h3>"),
+ "\n<pre>\n"]),
+ put(test_server_unexpected_footer,{UnexpectedName,UnexpFooter}),
+
+ test_server_io:set_fd(major, Major),
+ test_server_io:set_fd(html, Html),
+ test_server_io:set_fd(unexpected_io, Unexpected),
+
+ make_html_link(filename:absname(?last_test ++ ?html_ext),
+ HtmlName, filename:basename(Dir)),
+ LinkName = filename:join(Dir, ?last_link),
+ make_html_link(LinkName ++ ?html_ext, HtmlName,
+ filename:basename(Dir)),
+
+ PrivDir = filename:join(TestDir1, ?priv_dir),
+ ok = file:make_dir(PrivDir),
+ put(test_server_priv_dir,PrivDir++"/"),
+ print_timestamp(major, "Suite started at "),
+
+ LogInfo = [{topdir,Dir},{rundir,lists:flatten(TestDir1)}],
+ test_server_sup:framework_call(report, [loginfo,LogInfo]),
+ {ok,TestDir1}.
+
+log_file_error(Error, Dir) ->
+ exit({cannot_create_log_dir,{Error,lists:flatten(Dir)}}).
+
+make_html_link(LinkName, Target, Explanation) ->
+ %% if possible use a relative reference to Target.
+ TargetL = filename:split(Target),
+ PwdL = filename:split(filename:dirname(LinkName)),
+ Href = case lists:prefix(PwdL, TargetL) of
+ true ->
+ uri_encode(filename:join(lists:nthtail(length(PwdL),TargetL)));
+ false ->
+ "file:" ++ uri_encode(Target)
+ end,
+ H = [html_header(Explanation),
+ "<h1>Last test</h1>\n"
+ "<a href=\"",Href,"\">",Explanation,"</a>\n"
+ "</body>\n</html>\n"],
+ ok = write_html_file(LinkName, H).
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% start_minor_log_file(Mod, Func, ParallelTC) -> AbsName
+%% Mod = atom()
+%% Func = atom()
+%% ParallelTC = bool()
+%% AbsName = string()
+%%
+%% Create a minor log file for the test case Mod,Func,Args. The log file
+%% will be stored in the log directory under the name <Mod>.<Func>.html.
+%% Some header info will also be inserted into the log file. If the test
+%% case runs in a parallel group, then to avoid clashing file names if the
+%% case is executed more than once, the name <Mod>.<Func>.<Timestamp>.html
+%% is used.
+
+start_minor_log_file(Mod, Func, ParallelTC) ->
+ MFA = {Mod,Func,1},
+ LogDir = get(test_server_log_dir_base),
+ Name0 = lists:flatten(io_lib:format("~w.~w~ts", [Mod,Func,?html_ext])),
+ Name = downcase(Name0),
+ AbsName = filename:join(LogDir, Name),
+ case (ParallelTC orelse (element(1,file:read_file_info(AbsName))==ok)) of
+ false -> %% normal case, unique name
+ start_minor_log_file1(Mod, Func, LogDir, AbsName, MFA);
+ true -> %% special case, duplicate names
+ Tag = test_server_sup:unique_name(),
+ Name1_0 =
+ lists:flatten(io_lib:format("~w.~w.~ts~ts", [Mod,Func,Tag,
+ ?html_ext])),
+ Name1 = downcase(Name1_0),
+ AbsName1 = filename:join(LogDir, Name1),
+ start_minor_log_file1(Mod, Func, LogDir, AbsName1, MFA)
+ end.
+
+start_minor_log_file1(Mod, Func, LogDir, AbsName, MFA) ->
+ {ok,Fd} = open_html_file(AbsName),
+ Lev = get(test_server_minor_level)+1000, %% far down in the minor levels
+ put(test_server_minor_fd, Fd),
+ test_server_gl:set_minor_fd(group_leader(), Fd, MFA),
+
+ TestDescr = io_lib:format("Test ~w:~w result", [Mod,Func]),
+ {Header,Footer} =
+ case test_server_sup:framework_call(get_html_wrapper,
+ [TestDescr,false,
+ filename:dirname(AbsName),
+ undefined], "") of
+ Empty when (Empty == "") ; (element(2,Empty) == "") ->
+ put(basic_html, true),
+ {html_header(TestDescr), "\n</body>\n</html>\n"};
+ {basic_html,Html0,Html1} ->
+ put(basic_html, true),
+ {Html0,Html1};
+ {xhtml,Html0,Html1} ->
+ put(basic_html, false),
+ {Html0,Html1}
+ end,
+ put(test_server_minor_footer, Footer),
+ io:put_chars(Fd, Header),
+
+ io:put_chars(Fd, "<a name=\"top\"></a>"),
+ io:put_chars(Fd, "<pre>\n"),
+
+ SrcListing = downcase(atom_to_list(Mod)) ++ ?src_listing_ext,
+
+ case get_fw_mod(?MODULE) of
+ Mod when Func == error_in_suite ->
+ ok;
+ _ ->
+ {Info,Arity} =
+ if Func == init_per_suite; Func == end_per_suite ->
+ {"Config function: ", 1};
+ Func == init_per_group; Func == end_per_group ->
+ {"Config function: ", 2};
+ true ->
+ {"Test case: ", 1}
+ end,
+
+ case {filelib:is_file(filename:join(LogDir, SrcListing)),
+ lists:member(no_src, get(test_server_logopts))} of
+ {true,false} ->
+ print(Lev, ["$tc_html",
+ Info ++ "<a href=\"~ts#~ts\">~w:~w/~w</a> "
+ "(click for source code)\n"],
+ [uri_encode(SrcListing),
+ uri_encode(atom_to_list(Func)++"-1",utf8),
+ Mod,Func,Arity]);
+ _ ->
+ print(Lev, ["$tc_html",Info ++ "~w:~w/~w\n"], [Mod,Func,Arity])
+ end
+ end,
+
+ AbsName.
+
+stop_minor_log_file() ->
+ test_server_gl:unset_minor_fd(group_leader()),
+ Fd = get(test_server_minor_fd),
+ Footer = get(test_server_minor_footer),
+ io:put_chars(Fd, "</pre>\n" ++ Footer),
+ ok = file:close(Fd),
+ put(test_server_minor_fd, undefined).
+
+downcase(S) -> downcase(S, []).
+downcase([Uc|Rest], Result) when $A =< Uc, Uc =< $Z ->
+ downcase(Rest, [Uc-$A+$a|Result]);
+downcase([C|Rest], Result) ->
+ downcase(Rest, [C|Result]);
+downcase([], Result) ->
+ lists:reverse(Result).
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% html_convert_modules(TestSpec, Config) -> ok
+%% Isolate the modules affected by TestSpec and
+%% make sure they are converted to html.
+%%
+%% Errors are silently ignored.
+
+html_convert_modules(TestSpec, _Config, FwMod) ->
+ Mods = html_isolate_modules(TestSpec, FwMod),
+ html_convert_modules(Mods),
+ copy_html_files(get(test_server_dir), get(test_server_log_dir_base)).
+
+%% Retrieve a list of modules out of the test spec.
+html_isolate_modules(List, FwMod) ->
+ html_isolate_modules(List, sets:new(), FwMod).
+
+html_isolate_modules([], Set, _) -> sets:to_list(Set);
+html_isolate_modules([{skip_case,{_Case,_Cmt},_Mode}|Cases], Set, FwMod) ->
+ html_isolate_modules(Cases, Set, FwMod);
+html_isolate_modules([{conf,_Ref,Props,{FwMod,_Func}}|Cases], Set, FwMod) ->
+ Set1 = case proplists:get_value(suite, Props) of
+ undefined -> Set;
+ Mod -> sets:add_element(Mod, Set)
+ end,
+ html_isolate_modules(Cases, Set1, FwMod);
+html_isolate_modules([{conf,_Ref,_Props,{Mod,_Func}}|Cases], Set, FwMod) ->
+ html_isolate_modules(Cases, sets:add_element(Mod, Set), FwMod);
+html_isolate_modules([{skip_case,{conf,_Ref,{FwMod,_Func},_Cmt},Mode}|Cases],
+ Set, FwMod) ->
+ Set1 = case proplists:get_value(suite, get_props(Mode)) of
+ undefined -> Set;
+ Mod -> sets:add_element(Mod, Set)
+ end,
+ html_isolate_modules(Cases, Set1, FwMod);
+html_isolate_modules([{skip_case,{conf,_Ref,{Mod,_Func},_Cmt},_Props}|Cases],
+ Set, FwMod) ->
+ html_isolate_modules(Cases, sets:add_element(Mod, Set), FwMod);
+html_isolate_modules([{Mod,_Case}|Cases], Set, FwMod) ->
+ html_isolate_modules(Cases, sets:add_element(Mod, Set), FwMod);
+html_isolate_modules([{Mod,_Case,_Args}|Cases], Set, FwMod) ->
+ html_isolate_modules(Cases, sets:add_element(Mod, Set), FwMod).
+
+%% Given a list of modules, convert each module's source code to HTML.
+html_convert_modules([Mod|Mods]) ->
+ case code:which(Mod) of
+ Path when is_list(Path) ->
+ SrcFile = filename:rootname(Path) ++ ".erl",
+ FoundSrcFile =
+ case file:read_file_info(SrcFile) of
+ {ok,SInfo} ->
+ {SrcFile,SInfo};
+ {error,_} ->
+ ModInfo = Mod:module_info(compile),
+ case proplists:get_value(source, ModInfo) of
+ undefined ->
+ undefined;
+ OtherSrcFile ->
+ case file:read_file_info(OtherSrcFile) of
+ {ok,SInfo} ->
+ {OtherSrcFile,SInfo};
+ {error,_} ->
+ undefined
+ end
+ end
+ end,
+ case FoundSrcFile of
+ undefined ->
+ html_convert_modules(Mods);
+ {SrcFile1,SrcFileInfo} ->
+ DestDir = get(test_server_dir),
+ Name = atom_to_list(Mod),
+ DestFile = filename:join(DestDir,
+ downcase(Name)++?src_listing_ext),
+ html_possibly_convert(SrcFile1, SrcFileInfo, DestFile),
+ html_convert_modules(Mods)
+ end;
+ _Other ->
+ html_convert_modules(Mods)
+ end;
+html_convert_modules([]) -> ok.
+
+%% Convert source code to HTML if possible and needed.
+html_possibly_convert(Src, SrcInfo, Dest) ->
+ case file:read_file_info(Dest) of
+ {ok,DestInfo} when DestInfo#file_info.mtime >= SrcInfo#file_info.mtime ->
+ ok; % dest file up to date
+ _ ->
+ InclPath = case application:get_env(test_server, include) of
+ {ok,Incls} -> Incls;
+ _ -> []
+ end,
+
+ OutDir = get(test_server_log_dir_base),
+ case test_server_sup:framework_call(get_html_wrapper,
+ ["Module "++Src,false,
+ OutDir,undefined,
+ encoding(Src)], "") of
+ Empty when (Empty == "") ; (element(2,Empty) == "") ->
+ erl2html2:convert(Src, Dest, InclPath);
+ {_,Header,_} ->
+ erl2html2:convert(Src, Dest, InclPath, Header)
+ end
+ end.
+
+%% Copy all HTML files in InDir to OutDir.
+copy_html_files(InDir, OutDir) ->
+ Files = filelib:wildcard(filename:join(InDir, "*" ++ ?src_listing_ext)),
+ lists:foreach(fun (Src) -> copy_html_file(Src, OutDir) end, Files).
+
+copy_html_file(Src, DestDir) ->
+ Dest = filename:join(DestDir, filename:basename(Src)),
+ case file:read_file(Src) of
+ {ok,Bin} ->
+ ok = write_binary_file(Dest, Bin);
+ {error,_Reason} ->
+ io:format("File ~ts: read failed\n", [Src])
+ end.
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% add_init_and_end_per_suite(TestSpec, Mod, Ref, FwMod) -> NewTestSpec
+%%
+%% Expands TestSpec with an initial init_per_suite, and a final
+%% end_per_suite element, per each discovered suite in the list.
+
+add_init_and_end_per_suite([{make,_,_}=Case|Cases], LastMod, LastRef, FwMod) ->
+ [Case|add_init_and_end_per_suite(Cases, LastMod, LastRef, FwMod)];
+add_init_and_end_per_suite([{skip_case,{{Mod,all},_},_}=Case|Cases], LastMod,
+ LastRef, FwMod) when Mod =/= LastMod ->
+ {PreCases, NextMod, NextRef} =
+ do_add_end_per_suite_and_skip(LastMod, LastRef, Mod, FwMod),
+ PreCases ++ [Case|add_init_and_end_per_suite(Cases, NextMod,
+ NextRef, FwMod)];
+add_init_and_end_per_suite([{skip_case,{{Mod,_},_Cmt},_Mode}=Case|Cases],
+ LastMod, LastRef, FwMod) when Mod =/= LastMod ->
+ {PreCases, NextMod, NextRef} =
+ do_add_init_and_end_per_suite(LastMod, LastRef, Mod, FwMod),
+ PreCases ++ [Case|add_init_and_end_per_suite(Cases, NextMod,
+ NextRef, FwMod)];
+add_init_and_end_per_suite([{skip_case,{conf,_,{Mod,_},_},_}=Case|Cases],
+ LastMod, LastRef, FwMod) when Mod =/= LastMod ->
+ {PreCases, NextMod, NextRef} =
+ do_add_init_and_end_per_suite(LastMod, LastRef, Mod, FwMod),
+ PreCases ++ [Case|add_init_and_end_per_suite(Cases, NextMod,
+ NextRef, FwMod)];
+add_init_and_end_per_suite([{skip_case,{conf,_,{Mod,_},_}}=Case|Cases], LastMod,
+ LastRef, FwMod) when Mod =/= LastMod ->
+ {PreCases, NextMod, NextRef} =
+ do_add_init_and_end_per_suite(LastMod, LastRef, Mod, FwMod),
+ PreCases ++ [Case|add_init_and_end_per_suite(Cases, NextMod,
+ NextRef, FwMod)];
+add_init_and_end_per_suite([{conf,Ref,Props,{FwMod,Func}}=Case|Cases], LastMod,
+ LastRef, FwMod) ->
+ %% if Mod == FwMod, this conf test is (probably) a test case group where
+ %% the init- and end-functions are missing in the suite, and if so,
+ %% the suite name should be stored as {suite,Suite} in Props
+ case proplists:get_value(suite, Props) of
+ Suite when Suite =/= undefined, Suite =/= LastMod ->
+ {PreCases, NextMod, NextRef} =
+ do_add_init_and_end_per_suite(LastMod, LastRef, Suite, FwMod),
+ Case1 = {conf,Ref,[{suite,NextMod}|proplists:delete(suite,Props)],
+ {FwMod,Func}},
+ PreCases ++ [Case1|add_init_and_end_per_suite(Cases, NextMod,
+ NextRef, FwMod)];
+ _ ->
+ [Case|add_init_and_end_per_suite(Cases, LastMod, LastRef, FwMod)]
+ end;
+add_init_and_end_per_suite([{conf,_,_,{Mod,_}}=Case|Cases], LastMod,
+ LastRef, FwMod) when Mod =/= LastMod, Mod =/= FwMod ->
+ {PreCases, NextMod, NextRef} =
+ do_add_init_and_end_per_suite(LastMod, LastRef, Mod, FwMod),
+ PreCases ++ [Case|add_init_and_end_per_suite(Cases, NextMod,
+ NextRef, FwMod)];
+add_init_and_end_per_suite([SkipCase|Cases], LastMod, LastRef, FwMod)
+ when element(1,SkipCase) == skip_case; element(1,SkipCase) == auto_skip_case->
+ [SkipCase|add_init_and_end_per_suite(Cases, LastMod, LastRef, FwMod)];
+add_init_and_end_per_suite([{conf,_,_,_}=Case|Cases], LastMod, LastRef, FwMod) ->
+ [Case|add_init_and_end_per_suite(Cases, LastMod, LastRef, FwMod)];
+add_init_and_end_per_suite([{Mod,_}=Case|Cases], LastMod, LastRef, FwMod)
+ when Mod =/= LastMod, Mod =/= FwMod ->
+ {PreCases, NextMod, NextRef} =
+ do_add_init_and_end_per_suite(LastMod, LastRef, Mod, FwMod),
+ PreCases ++ [Case|add_init_and_end_per_suite(Cases, NextMod,
+ NextRef, FwMod)];
+add_init_and_end_per_suite([{Mod,_,_}=Case|Cases], LastMod, LastRef, FwMod)
+ when Mod =/= LastMod, Mod =/= FwMod ->
+ {PreCases, NextMod, NextRef} =
+ do_add_init_and_end_per_suite(LastMod, LastRef, Mod, FwMod),
+ PreCases ++ [Case|add_init_and_end_per_suite(Cases, NextMod,
+ NextRef, FwMod)];
+add_init_and_end_per_suite([Case|Cases], LastMod, LastRef, FwMod)->
+ [Case|add_init_and_end_per_suite(Cases, LastMod, LastRef, FwMod)];
+add_init_and_end_per_suite([], _LastMod, undefined, _FwMod) ->
+ [];
+add_init_and_end_per_suite([], _LastMod, skipped_suite, _FwMod) ->
+ [];
+add_init_and_end_per_suite([], LastMod, LastRef, FwMod) ->
+ %% we'll add end_per_suite here even if it's not exported
+ %% (and simply let the call fail if it's missing)
+ case erlang:function_exported(LastMod, end_per_suite, 1) of
+ true ->
+ [{conf,LastRef,[],{LastMod,end_per_suite}}];
+ false ->
+ %% let's call a "fake" end_per_suite if it exists
+ case erlang:function_exported(FwMod, end_per_suite, 1) of
+ true ->
+ [{conf,LastRef,[{suite,LastMod}],{FwMod,end_per_suite}}];
+ false ->
+ [{conf,LastRef,[],{LastMod,end_per_suite}}]
+ end
+ end.
+
+do_add_init_and_end_per_suite(LastMod, LastRef, Mod, FwMod) ->
+ case code:is_loaded(Mod) of
+ false -> code:load_file(Mod);
+ _ -> ok
+ end,
+ {Init,NextMod,NextRef} =
+ case erlang:function_exported(Mod, init_per_suite, 1) of
+ true ->
+ Ref = make_ref(),
+ {[{conf,Ref,[],{Mod,init_per_suite}}],Mod,Ref};
+ false ->
+ %% let's call a "fake" init_per_suite if it exists
+ case erlang:function_exported(FwMod, init_per_suite, 1) of
+ true ->
+ Ref = make_ref(),
+ {[{conf,Ref,[{suite,Mod}],
+ {FwMod,init_per_suite}}],Mod,Ref};
+ false ->
+ {[],Mod,undefined}
+ end
+
+ end,
+ Cases =
+ if LastRef==undefined ->
+ Init;
+ LastRef==skipped_suite ->
+ Init;
+ true ->
+ %% we'll add end_per_suite here even if it's not exported
+ %% (and simply let the call fail if it's missing)
+ case erlang:function_exported(LastMod, end_per_suite, 1) of
+ true ->
+ [{conf,LastRef,[],{LastMod,end_per_suite}}|Init];
+ false ->
+ %% let's call a "fake" end_per_suite if it exists
+ case erlang:function_exported(FwMod, end_per_suite, 1) of
+ true ->
+ [{conf,LastRef,[{suite,Mod}],
+ {FwMod,end_per_suite}}|Init];
+ false ->
+ [{conf,LastRef,[],{LastMod,end_per_suite}}|Init]
+ end
+ end
+ end,
+ {Cases,NextMod,NextRef}.
+
+do_add_end_per_suite_and_skip(LastMod, LastRef, Mod, FwMod) ->
+ case LastRef of
+ No when No==undefined ; No==skipped_suite ->
+ {[],Mod,skipped_suite};
+ _Ref ->
+ case erlang:function_exported(LastMod, end_per_suite, 1) of
+ true ->
+ {[{conf,LastRef,[],{LastMod,end_per_suite}}],
+ Mod,skipped_suite};
+ false ->
+ case erlang:function_exported(FwMod, end_per_suite, 1) of
+ true ->
+ %% let's call "fake" end_per_suite if it exists
+ {[{conf,LastRef,[],{FwMod,end_per_suite}}],
+ Mod,skipped_suite};
+ false ->
+ {[{conf,LastRef,[],{LastMod,end_per_suite}}],
+ Mod,skipped_suite}
+ end
+ end
+ end.
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% run_test_cases(TestSpec, Config, TimetrapData) -> exit(Result)
+%%
+%% Runs the specified tests, then displays/logs the summary.
+
+run_test_cases(TestSpec, Config, TimetrapData) ->
+ test_server:init_purify(),
+ case lists:member(no_src, get(test_server_logopts)) of
+ true ->
+ ok;
+ false ->
+ FwMod = get_fw_mod(?MODULE),
+ html_convert_modules(TestSpec, Config, FwMod)
+ end,
+
+ run_test_cases_loop(TestSpec, [Config], TimetrapData, [], []),
+
+ {AllSkippedN,UserSkipN,AutoSkipN,SkipStr} =
+ case get(test_server_skipped) of
+ {0,0} -> {0,0,0,""};
+ {US,AS} -> {US+AS,US,AS,io_lib:format(", ~w skipped", [US+AS])}
+ end,
+ OkN = get(test_server_ok),
+ FailedN = get(test_server_failed),
+ print(1, "TEST COMPLETE, ~w ok, ~w failed~ts of ~w test cases\n",
+ [OkN,FailedN,SkipStr,OkN+FailedN+AllSkippedN]),
+ test_server_sup:framework_call(report, [tests_done,
+ {OkN,FailedN,{UserSkipN,AutoSkipN}}]),
+ print(major, "=finished ~s", [lists:flatten(timestamp_get(""))]),
+ print(major, "=failed ~w", [FailedN]),
+ print(major, "=successful ~w", [OkN]),
+ print(major, "=user_skipped ~w", [UserSkipN]),
+ print(major, "=auto_skipped ~w", [AutoSkipN]),
+ exit(test_suites_done).
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% run_test_cases_loop(TestCases, Config, TimetrapData, Mode, Status) -> ok
+%% TestCases = [Test,...]
+%% Config = [[{Key,Val},...],...]
+%% TimetrapData = {MultiplyTimetrap,ScaleTimetrap}
+%% MultiplyTimetrap = integer() | infinity
+%% ScaleTimetrap = bool()
+%% Mode = [{Ref,[Prop,..],StartTime}]
+%% Ref = reference()
+%% Prop = {name,Name} | sequence | parallel |
+%% shuffle | {shuffle,Seed} |
+%% repeat | {repeat,N} |
+%% repeat_until_all_ok | {repeat_until_all_ok,N} |
+%% repeat_until_any_ok | {repeat_until_any_ok,N} |
+%% repeat_until_any_fail | {repeat_until_any_fail,N} |
+%% repeat_until_all_fail | {repeat_until_all_fail,N}
+%% Status = [{Ref,{{Ok,Skipped,Failed},CopiedCases}}]
+%% Ok = Skipped = Failed = [Case,...]
+%%
+%% Execute the TestCases under configuration Config. Config is a list
+%% of lists, where hd(Config) holds the config tuples for the current
+%% conf case and tl(Config) is the data for the higher level conf cases.
+%% Config data is "inherited" from top to nested conf cases, but
+%% never the other way around. if length(Config) == 1, Config contains
+%% only the initial config data for the suite.
+%%
+%% Test may be one of the following:
+%%
+%% {conf,Ref,Props,{Mod,Func}} Mod:Func is a configuration modification
+%% function, call it with the current configuration as argument. It will
+%% return a new configuration.
+%%
+%% {make,Ref,{Mod,Func,Args}} Mod:Func is a make function, and it is called
+%% with the given arguments.
+%%
+%% {Mod,Case} This is a normal test case. Determine the correct
+%% configuration, and insert {Mod,Case,Config} as head of the list,
+%% then reiterate.
+%%
+%% {Mod,Case,Args} A test case with predefined argument (usually a normal
+%% test case which just got a fresh configuration (see above)).
+%%
+%% {skip_case,{conf,Ref,Case,Comment}} An init conf case gets skipped
+%% by the user. This will also cause the end conf case to be skipped.
+%% Note that it is not possible to skip an end conf case directly (it
+%% can only be skipped indirectly by a skipped init conf case). The
+%% comment (which gets printed in the log files) describes why the case
+%% was skipped.
+%%
+%% {skip_case,{Case,Comment},Mode} A normal test case skipped by the user.
+%% The comment (which gets printed in the log files) describes why the
+%% case was skipped.
+%%
+%% {auto_skip_case,{conf,Ref,Case,Comment},Mode} This is the result of
+%% an end conf case being automatically skipped due to a failing init
+%% conf case. It could also be a nested conf case that gets skipped
+%% because of a failed or skipped top level conf.
+%%
+%% {auto_skip_case,{Case,Comment},Mode} This is a normal test case which
+%% gets automatically skipped because of a failing init conf case or
+%% because of a failing previous test case in a sequence.
+%%
+%% -------------------------------------------------------------------
+%% Description of IO handling during execution of parallel test cases:
+%% -------------------------------------------------------------------
+%%
+%% A conf group can have an associated list of properties. If the
+%% parallel property is specified for a group, it means the test cases
+%% should be spawned and run in parallel rather than called sequentially
+%% (which is always the default mode). Test cases that execute in parallel
+%% also write to their respective minor log files in parallel. Printouts
+%% to common log files, such as the summary html file and the major log
+%% file on text format, still have to be processed sequentially. For this
+%% reason, the Mode argument specifies if a parallel group is currently
+%% being executed.
+%%
+%% The low-level mechanism for buffering IO for the common log files
+%% is handled by the test_server_io module. Buffering is turned on by
+%% test_server_io:start_transaction/0 and off by calling
+%% test_server_io:end_transaction/0. The buffered data for the transaction
+%% can printed by calling test_server_io:print_buffered/1.
+%%
+%% This module is responsible for turning on IO buffering and to later
+%% test_server_io:print_buffered/1 to print the data. To help with this,
+%% two variables in the process dictionary are used:
+%% 'test_server_common_io_handler' and 'test_server_queued_io'. The values
+%% are set to as follwing:
+%%
+%% Value Meaning
+%% ----- -------
+%% undefined No parallel test cases running
+%% {tc,Pid} Running test cases in a top-level parallel group
+%% {Ref,Pid} Running sequential test case inside a parallel group
+%%
+%% FIXME: The Pid is no longer used.
+%%
+%% If a conf group nested under a parallel group in the test
+%% specification should be started, the 'test_server_common_io_handler'
+%% value gets set also on the main process.
+%%
+%% During execution of a parallel group (or of a group nested under a
+%% parallel group), *any* new test case being started gets registered
+%% in a list saved in the dictionary with 'test_server_queued_io' as key.
+%% When the top level parallel group is finished (only then can we be
+%% sure all parallel test cases have finished and "reported in"), the
+%% list of test cases is traversed in order and test_server_io:print_buffered/1
+%% can be called for each test case. See handle_test_case_io_and_status/0
+%% for details.
+%%
+%% To be able to handle nested conf groups with different properties,
+%% the Mode argument specifies a list of {Ref,Properties} tuples.
+%% The head of the Mode list at any given time identifies the group
+%% currently being processed. The tail of the list identifies groups
+%% on higher level.
+%%
+%% -------------------------------------------------------------------
+%% Notes on parallel execution of test cases
+%% -------------------------------------------------------------------
+%%
+%% A group nested under a parallel group will start executing in
+%% parallel with previous (parallel) test cases (no matter what
+%% properties the nested group has). Test cases are however never
+%% executed in parallel with the start or end conf case of the same
+%% group! Because of this, the test_server_ctrl loop waits at
+%% the end conf of a group for all parallel cases to finish
+%% before the end conf case actually executes. This has the effect
+%% that it's only after a nested group has finished that any
+%% remaining parallel cases in the previous group get spawned (*).
+%% Example (all parallel cases):
+%%
+%% group1_init |---->
+%% group1_case1 | --------->
+%% group1_case2 | --------------------------------->
+%% group2_init | ---->
+%% group2_case1 | ------>
+%% group2_case2 | ---------->
+%% group2_end | --->
+%% group1_case3 (*)| ---->
+%% group1_case4 (*)| -->
+%% group1_end | --->
+%%
+
+run_test_cases_loop([{SkipTag,CaseData={Type,_Ref,_Case,_Comment}}|Cases],
+ Config, TimetrapData, Mode, Status) when
+ ((SkipTag==auto_skip_case) or (SkipTag==skip_case)) and
+ ((Type==conf) or (Type==make)) ->
+ run_test_cases_loop([{SkipTag,CaseData,Mode}|Cases],
+ Config, TimetrapData, Mode, Status);
+
+run_test_cases_loop([{SkipTag,{Type,Ref,Case,Comment},SkipMode}|Cases],
+ Config, TimetrapData, Mode, Status) when
+ ((SkipTag==auto_skip_case) or (SkipTag==skip_case)) and
+ ((Type==conf) or (Type==make)) ->
+ file:set_cwd(filename:dirname(get(test_server_dir))),
+ CurrIOHandler = get(test_server_common_io_handler),
+ ParentMode = tl(Mode),
+
+ {AutoOrUser,ReportTag} =
+ if SkipTag == auto_skip_case -> {auto,tc_auto_skip};
+ SkipTag == skip_case -> {user,tc_user_skip}
+ end,
+
+ %% check and update the mode for test case execution and io msg handling
+ case {curr_ref(Mode),check_props(parallel, Mode)} of
+ {Ref,Ref} ->
+ case check_props(parallel, ParentMode) of
+ false ->
+ %% this is a skipped end conf for a top level parallel
+ %% group, buffered io can be flushed
+ handle_test_case_io_and_status(),
+ set_io_buffering(undefined),
+ {Mod,Func} = skip_case(AutoOrUser, Ref, 0, Case, Comment,
+ false, SkipMode),
+ ConfData = {Mod,{Func,get_name(SkipMode)},Comment},
+ test_server_sup:framework_call(report,
+ [ReportTag,ConfData]),
+ run_test_cases_loop(Cases, Config, TimetrapData, ParentMode,
+ delete_status(Ref, Status));
+ _ ->
+ %% this is a skipped end conf for a parallel group nested
+ %% under a parallel group (io buffering is active)
+ wait_for_cases(Ref),
+ {Mod,Func} = skip_case(AutoOrUser, Ref, 0, Case, Comment,
+ true, SkipMode),
+ ConfData = {Mod,{Func,get_name(SkipMode)},Comment},
+ test_server_sup:framework_call(report, [ReportTag,ConfData]),
+ case CurrIOHandler of
+ {Ref,_} ->
+ %% current_io_handler was set by start conf of this
+ %% group, so we can unset it now (no more io from main
+ %% process needs to be buffered)
+ set_io_buffering(undefined);
+ _ ->
+ ok
+ end,
+ run_test_cases_loop(Cases, Config,
+ TimetrapData, ParentMode,
+ delete_status(Ref, Status))
+ end;
+ {Ref,false} ->
+ %% this is a skipped end conf for a non-parallel group that's not
+ %% nested under a parallel group
+ {Mod,Func} = skip_case(AutoOrUser, Ref, 0, Case, Comment,
+ false, SkipMode),
+ ConfData = {Mod,{Func,get_name(SkipMode)},Comment},
+ test_server_sup:framework_call(report, [ReportTag,ConfData]),
+
+ %% Check if this group is auto skipped because of error in the
+ %% init conf. If so, check if the parent group is a sequence,
+ %% and if it is, skip all proceeding tests in that group.
+ GrName = get_name(Mode),
+ Cases1 =
+ case get_tc_results(Status) of
+ {_,_,Fails} when length(Fails) > 0 ->
+ case lists:member({group_result,GrName}, Fails) of
+ true ->
+ case check_prop(sequence, ParentMode) of
+ false ->
+ Cases;
+ ParentRef ->
+ Reason = {group_result,GrName,failed},
+ skip_cases_upto(ParentRef, Cases,
+ Reason, tc, ParentMode,
+ SkipTag)
+ end;
+ false ->
+ Cases
+ end;
+ _ ->
+ Cases
+ end,
+ run_test_cases_loop(Cases1, Config, TimetrapData, ParentMode,
+ delete_status(Ref, Status));
+ {Ref,_} ->
+ %% this is a skipped end conf for a non-parallel group nested under
+ %% a parallel group (io buffering is active)
+ {Mod,Func} = skip_case(AutoOrUser, Ref, 0, Case, Comment,
+ true, SkipMode),
+ ConfData = {Mod,{Func,get_name(SkipMode)},Comment},
+ test_server_sup:framework_call(report, [ReportTag,ConfData]),
+ case CurrIOHandler of
+ {Ref,_} ->
+ %% current_io_handler was set by start conf of this
+ %% group, so we can unset it now (no more io from main
+ %% process needs to be buffered)
+ set_io_buffering(undefined);
+ _ ->
+ ok
+ end,
+ run_test_cases_loop(Cases, Config, TimetrapData, tl(Mode),
+ delete_status(Ref, Status));
+ {_,false} ->
+ %% this is a skipped start conf for a group which is not nested
+ %% under a parallel group
+ {Mod,Func} = skip_case(AutoOrUser, Ref, 0, Case, Comment,
+ false, SkipMode),
+ ConfData = {Mod,{Func,get_name(SkipMode)},Comment},
+ test_server_sup:framework_call(report, [ReportTag,ConfData]),
+ run_test_cases_loop(Cases, Config, TimetrapData,
+ [conf(Ref,[])|Mode], Status);
+ {_,Ref0} when is_reference(Ref0) ->
+ %% this is a skipped start conf for a group nested under a parallel
+ %% group and if this is the first nested group, io buffering must
+ %% be activated
+ if CurrIOHandler == undefined ->
+ set_io_buffering({Ref,self()});
+ true ->
+ ok
+ end,
+ {Mod,Func} = skip_case(AutoOrUser, Ref, 0, Case, Comment,
+ true, SkipMode),
+ ConfData = {Mod,{Func,get_name(SkipMode)},Comment},
+ test_server_sup:framework_call(report, [ReportTag,ConfData]),
+ run_test_cases_loop(Cases, Config, TimetrapData,
+ [conf(Ref,[])|Mode], Status)
+ end;
+
+run_test_cases_loop([{auto_skip_case,{Case,Comment},SkipMode}|Cases],
+ Config, TimetrapData, Mode, Status) ->
+ {Mod,Func} = skip_case(auto, undefined, get(test_server_case_num)+1,
+ Case, Comment, is_io_buffered(), SkipMode),
+ test_server_sup:framework_call(report, [tc_auto_skip,
+ {Mod,{Func,get_name(SkipMode)},
+ Comment}]),
+ run_test_cases_loop(Cases, Config, TimetrapData, Mode,
+ update_status(skipped, Mod, Func, Status));
+
+run_test_cases_loop([{skip_case,{{Mod,all}=Case,Comment},SkipMode}|Cases],
+ Config, TimetrapData, Mode, Status) ->
+ skip_case(user, undefined, 0, Case, Comment, false, SkipMode),
+ test_server_sup:framework_call(report, [tc_user_skip,
+ {Mod,{all,get_name(SkipMode)},
+ Comment}]),
+ run_test_cases_loop(Cases, Config, TimetrapData, Mode, Status);
+
+run_test_cases_loop([{skip_case,{Case,Comment},SkipMode}|Cases],
+ Config, TimetrapData, Mode, Status) ->
+ {Mod,Func} = skip_case(user, undefined, get(test_server_case_num)+1,
+ Case, Comment, is_io_buffered(), SkipMode),
+ test_server_sup:framework_call(report, [tc_user_skip,
+ {Mod,{Func,get_name(SkipMode)},
+ Comment}]),
+ run_test_cases_loop(Cases, Config, TimetrapData, Mode,
+ update_status(skipped, Mod, Func, Status));
+
+%% a start *or* end conf case, wrapping test cases or other conf cases
+run_test_cases_loop([{conf,Ref,Props,{Mod,Func}}|_Cases]=Cs0,
+ Config, TimetrapData, Mode0, Status) ->
+ CurrIOHandler = get(test_server_common_io_handler),
+ %% check and update the mode for test case execution and io msg handling
+ {StartConf,Mode,IOHandler,ConfTime,Status1} =
+ case {curr_ref(Mode0),check_props(parallel, Mode0)} of
+ {Ref,Ref} ->
+ case check_props(parallel, tl(Mode0)) of
+ false ->
+ %% this is an end conf for a top level parallel group,
+ %% collect results from the test case processes
+ %% and calc total time
+ OkSkipFail = handle_test_case_io_and_status(),
+ file:set_cwd(filename:dirname(get(test_server_dir))),
+ After = ?now,
+ Before = get(test_server_parallel_start_time),
+ Elapsed = timer:now_diff(After, Before)/1000000,
+ put(test_server_total_time, Elapsed),
+ {false,tl(Mode0),undefined,Elapsed,
+ update_status(Ref, OkSkipFail, Status)};
+ _ ->
+ %% this is an end conf for a parallel group nested under a
+ %% parallel group (io buffering is active)
+ OkSkipFail = wait_for_cases(Ref),
+ queue_test_case_io(Ref, self(), 0, Mod, Func),
+ Elapsed = timer:now_diff(?now, conf_start(Ref, Mode0))/1000000,
+ case CurrIOHandler of
+ {Ref,_} ->
+ %% current_io_handler was set by start conf of this
+ %% group, so we can unset it after this case (no
+ %% more io from main process needs to be buffered)
+ {false,tl(Mode0),undefined,Elapsed,
+ update_status(Ref, OkSkipFail, Status)};
+ _ ->
+ {false,tl(Mode0),CurrIOHandler,Elapsed,
+ update_status(Ref, OkSkipFail, Status)}
+ end
+ end;
+ {Ref,false} ->
+ %% this is an end conf for a non-parallel group that's not
+ %% nested under a parallel group, so no need to buffer io
+ {false,tl(Mode0),undefined,
+ timer:now_diff(?now, conf_start(Ref, Mode0))/1000000, Status};
+ {Ref,_} ->
+ %% this is an end conf for a non-parallel group nested under
+ %% a parallel group (io buffering is active)
+ queue_test_case_io(Ref, self(), 0, Mod, Func),
+ Elapsed = timer:now_diff(?now, conf_start(Ref, Mode0))/1000000,
+ case CurrIOHandler of
+ {Ref,_} ->
+ %% current_io_handler was set by start conf of this
+ %% group, so we can unset it after this case (no
+ %% more io from main process needs to be buffered)
+ {false,tl(Mode0),undefined,Elapsed,Status};
+ _ ->
+ {false,tl(Mode0),CurrIOHandler,Elapsed,Status}
+ end;
+ {_,false} ->
+ %% this is a start conf for a group which is not nested under a
+ %% parallel group, check if this case starts a new parallel group
+ case lists:member(parallel, Props) of
+ true ->
+ %% prepare for execution of parallel group
+ put(test_server_parallel_start_time, ?now),
+ put(test_server_queued_io, []);
+ false ->
+ ok
+ end,
+ {true,[conf(Ref,Props)|Mode0],undefined,0,Status};
+ {_,_Ref0} ->
+ %% this is a start conf for a group nested under a parallel group, the
+ %% parallel_start_time and parallel_test_cases values have already been set
+ queue_test_case_io(Ref, self(), 0, Mod, Func),
+ %% if this is the first nested group under a parallel group, io
+ %% buffering must be activated
+ IOHandler1 = if CurrIOHandler == undefined ->
+ IOH = {Ref,self()},
+ set_io_buffering(IOH),
+ IOH;
+ true ->
+ CurrIOHandler
+ end,
+ {true,[conf(Ref,Props)|Mode0],IOHandler1,0,Status}
+ end,
+
+ %% if this is a start conf we check if cases should be shuffled
+ {[_Conf|Cases1]=Cs1,Shuffle} =
+ if StartConf ->
+ case get_shuffle(Props) of
+ undefined ->
+ {Cs0,undefined};
+ {_,repeated} ->
+ %% if group is repeated, a new seed should not be set every
+ %% turn - last one is saved in dictionary
+ CurrSeed = get(test_server_curr_random_seed),
+ {shuffle_cases(Ref, Cs0, CurrSeed),{shuffle,CurrSeed}};
+ {_,Seed} ->
+ UseSeed=
+ %% Determine which seed to use by:
+ %% 1. check the TS_RANDOM_SEED env variable
+ %% 2. check random_seed in process state
+ %% 3. use value provided with shuffle option
+ %% 4. use timestamp() values for seed
+ case os:getenv("TS_RANDOM_SEED") of
+ Undef when Undef == false ; Undef == "undefined" ->
+ case get(test_server_random_seed) of
+ undefined -> Seed;
+ TSRS -> TSRS
+ end;
+ NumStr ->
+ %% Ex: "123 456 789" or "123,456,789" -> {123,456,789}
+ list_to_tuple([list_to_integer(NS) ||
+ NS <- string:tokens(NumStr, [$ ,$:,$,])])
+ end,
+ {shuffle_cases(Ref, Cs0, UseSeed),{shuffle,UseSeed}}
+ end;
+ not StartConf ->
+ {Cs0,undefined}
+ end,
+
+ %% if this is a start conf we check if Props specifies repeat and if so
+ %% we copy the group and carry the copy until the end conf where we
+ %% decide to perform the repetition or not
+ {Repeating,Status2,Cases,ReportRepeatStop} =
+ if StartConf ->
+ case get_repeat(Props) of
+ undefined ->
+ %% we *must* have a status entry for every conf since we
+ %% will continously update status with test case results
+ %% without knowing the Ref (but update hd(Status))
+ {false,new_status(Ref, Status1),Cases1,?void_fun};
+ {_RepType,N} when N =< 1 ->
+ {false,new_status(Ref, Status1),Cases1,?void_fun};
+ _ ->
+ {Copied,_} = copy_cases(Ref, make_ref(), Cs1),
+ {true,new_status(Ref, Copied, Status1),Cases1,?void_fun}
+ end;
+ not StartConf ->
+ RepVal = get_repeat(get_props(Mode0)),
+ ReportStop =
+ fun() ->
+ print(minor, "~n*** Stopping repeat operation ~w", [RepVal]),
+ print(1, "Stopping repeat operation ~w", [RepVal])
+ end,
+ CopiedCases = get_copied_cases(Status1),
+ EndStatus = delete_status(Ref, Status1),
+ %% check in Mode0 if this is a repeat conf
+ case RepVal of
+ undefined ->
+ {false,EndStatus,Cases1,?void_fun};
+ {_RepType,N} when N =< 1 ->
+ {false,EndStatus,Cases1,?void_fun};
+ {repeat,_} ->
+ {true,EndStatus,CopiedCases++Cases1,?void_fun};
+ {repeat_until_all_ok,_} ->
+ {RestCs,Fun} = case get_tc_results(Status1) of
+ {_,_,[]} ->
+ {Cases1,ReportStop};
+ _ ->
+ {CopiedCases++Cases1,?void_fun}
+ end,
+ {true,EndStatus,RestCs,Fun};
+ {repeat_until_any_ok,_} ->
+ {RestCs,Fun} = case get_tc_results(Status1) of
+ {Ok,_,_Fails} when length(Ok) > 0 ->
+ {Cases1,ReportStop};
+ _ ->
+ {CopiedCases++Cases1,?void_fun}
+ end,
+ {true,EndStatus,RestCs,Fun};
+ {repeat_until_any_fail,_} ->
+ {RestCs,Fun} = case get_tc_results(Status1) of
+ {_,_,Fails} when length(Fails) > 0 ->
+ {Cases1,ReportStop};
+ _ ->
+ {CopiedCases++Cases1,?void_fun}
+ end,
+ {true,EndStatus,RestCs,Fun};
+ {repeat_until_all_fail,_} ->
+ {RestCs,Fun} = case get_tc_results(Status1) of
+ {[],_,_} ->
+ {Cases1,ReportStop};
+ _ ->
+ {CopiedCases++Cases1,?void_fun}
+ end,
+ {true,EndStatus,RestCs,Fun}
+ end
+ end,
+
+ ReportAbortRepeat = fun(What) when Repeating ->
+ print(minor, "~n*** Aborting repeat operation "
+ "(configuration case ~w)", [What]),
+ print(1, "Aborting repeat operation "
+ "(configuration case ~w)", [What]);
+ (_) -> ok
+ end,
+ CfgProps = if StartConf ->
+ if Shuffle == undefined ->
+ [{tc_group_properties,Props}];
+ true ->
+ [{tc_group_properties,
+ [Shuffle|delete_shuffle(Props)]}]
+ end;
+ not StartConf ->
+ {TcOk,TcSkip,TcFail} = get_tc_results(Status1),
+ [{tc_group_properties,get_props(Mode0)},
+ {tc_group_result,[{ok,TcOk},
+ {skipped,TcSkip},
+ {failed,TcFail}]}]
+ end,
+
+ SuiteName = proplists:get_value(suite, Props),
+ case get(test_server_create_priv_dir) of
+ auto_per_run -> % use common priv_dir
+ TSDirs = [{priv_dir,get(test_server_priv_dir)},
+ {data_dir,get_data_dir(Mod, SuiteName)}];
+ _ ->
+ TSDirs = [{data_dir,get_data_dir(Mod, SuiteName)}]
+ end,
+
+ ActualCfg =
+ if not StartConf ->
+ update_config(hd(Config), TSDirs ++ CfgProps);
+ true ->
+ GroupPath = lists:flatmap(fun({_Ref,[],_T}) -> [];
+ ({_Ref,GrProps,_T}) -> [GrProps]
+ end, Mode0),
+ update_config(hd(Config),
+ TSDirs ++ [{tc_group_path,GroupPath} | CfgProps])
+ end,
+
+ CurrMode = curr_mode(Ref, Mode0, Mode),
+ ConfCaseResult = run_test_case(Ref, 0, Mod, Func, [ActualCfg], skip_init,
+ TimetrapData, CurrMode),
+
+ case ConfCaseResult of
+ {_,NewCfg,_} when Func == init_per_suite, is_list(NewCfg) ->
+ %% check that init_per_suite returned data on correct format
+ case lists:filter(fun({_,_}) -> false;
+ (_) -> true end, NewCfg) of
+ [] ->
+ set_io_buffering(IOHandler),
+ stop_minor_log_file(),
+ run_test_cases_loop(Cases, [NewCfg|Config],
+ TimetrapData, Mode, Status2);
+ Bad ->
+ print(minor,
+ "~n*** ~w returned bad elements in Config: ~p.~n",
+ [Func,Bad]),
+ Reason = {failed,{Mod,init_per_suite,bad_return}},
+ Cases2 = skip_cases_upto(Ref, Cases, Reason, conf, CurrMode,
+ auto_skip_case),
+ set_io_buffering(IOHandler),
+ stop_minor_log_file(),
+ run_test_cases_loop(Cases2, Config, TimetrapData, Mode,
+ delete_status(Ref, Status2))
+ end;
+ {_,NewCfg,_} when StartConf, is_list(NewCfg) ->
+ print_conf_time(ConfTime),
+ set_io_buffering(IOHandler),
+ stop_minor_log_file(),
+ run_test_cases_loop(Cases, [NewCfg|Config], TimetrapData, Mode, Status2);
+ {_,{framework_error,{FwMod,FwFunc},Reason},_} ->
+ print(minor, "~n*** ~w failed in ~w. Reason: ~p~n",
+ [FwMod,FwFunc,Reason]),
+ print(1, "~w failed in ~w. Reason: ~p~n", [FwMod,FwFunc,Reason]),
+ exit(framework_error);
+ {_,Fail,_} when element(1,Fail) == 'EXIT';
+ element(1,Fail) == timetrap_timeout;
+ element(1,Fail) == user_timetrap_error;
+ element(1,Fail) == failed ->
+ {Cases2,Config1,Status3} =
+ if StartConf ->
+ ReportAbortRepeat(failed),
+ print(minor, "~n*** ~w failed.~n"
+ " Skipping all cases.", [Func]),
+ Reason = {failed,{Mod,Func,Fail}},
+ {skip_cases_upto(Ref, Cases, Reason, conf, CurrMode,
+ auto_skip_case),
+ Config,
+ update_status(failed, group_result, get_name(Mode),
+ delete_status(Ref, Status2))};
+ not StartConf ->
+ ReportRepeatStop(),
+ print_conf_time(ConfTime),
+ {Cases,tl(Config),delete_status(Ref, Status2)}
+ end,
+ set_io_buffering(IOHandler),
+ stop_minor_log_file(),
+ run_test_cases_loop(Cases2, Config1, TimetrapData, Mode, Status3);
+
+ {_,{auto_skip,SkipReason},_} ->
+ %% this case can only happen if the framework (not the user)
+ %% decides to skip execution of a conf function
+ {Cases2,Config1,Status3} =
+ if StartConf ->
+ ReportAbortRepeat(auto_skipped),
+ print(minor, "~n*** ~w auto skipped.~n"
+ " Skipping all cases.", [Func]),
+ {skip_cases_upto(Ref, Cases, SkipReason, conf, CurrMode,
+ auto_skip_case),
+ Config,
+ delete_status(Ref, Status2)};
+ not StartConf ->
+ ReportRepeatStop(),
+ print_conf_time(ConfTime),
+ {Cases,tl(Config),delete_status(Ref, Status2)}
+ end,
+ set_io_buffering(IOHandler),
+ stop_minor_log_file(),
+ run_test_cases_loop(Cases2, Config1, TimetrapData, Mode, Status3);
+
+ {_,{Skip,Reason},_} when StartConf and ((Skip==skip) or (Skip==skipped)) ->
+ ReportAbortRepeat(skipped),
+ print(minor, "~n*** ~w skipped.~n"
+ " Skipping all cases.", [Func]),
+ set_io_buffering(IOHandler),
+ stop_minor_log_file(),
+ run_test_cases_loop(skip_cases_upto(Ref, Cases, Reason, conf,
+ CurrMode, skip_case),
+ [hd(Config)|Config], TimetrapData, Mode,
+ delete_status(Ref, Status2));
+ {_,{skip_and_save,Reason,_SavedConfig},_} when StartConf ->
+ ReportAbortRepeat(skipped),
+ print(minor, "~n*** ~w skipped.~n"
+ " Skipping all cases.", [Func]),
+ set_io_buffering(IOHandler),
+ stop_minor_log_file(),
+ run_test_cases_loop(skip_cases_upto(Ref, Cases, Reason, conf,
+ CurrMode, skip_case),
+ [hd(Config)|Config], TimetrapData, Mode,
+ delete_status(Ref, Status2));
+ {_,_Other,_} when Func == init_per_suite ->
+ print(minor, "~n*** init_per_suite failed to return a Config list.~n", []),
+ Reason = {failed,{Mod,init_per_suite,bad_return}},
+ Cases2 = skip_cases_upto(Ref, Cases, Reason, conf, CurrMode,
+ auto_skip_case),
+ set_io_buffering(IOHandler),
+ stop_minor_log_file(),
+ run_test_cases_loop(Cases2, Config, TimetrapData, Mode,
+ delete_status(Ref, Status2));
+ {_,_Other,_} when StartConf ->
+ print_conf_time(ConfTime),
+ set_io_buffering(IOHandler),
+ ReportRepeatStop(),
+ stop_minor_log_file(),
+ run_test_cases_loop(Cases, [hd(Config)|Config], TimetrapData,
+ Mode, Status2);
+ {_,_EndConfRetVal,Opts} ->
+ %% Check if return_group_result is set (ok, skipped or failed) and
+ %% if so:
+ %% 1) *If* the parent group is a sequence, skip all proceeding tests
+ %% in that group.
+ %% 2) Return the value to the group "above" so that result may be
+ %% used for evaluating a 'repeat_until_*' property.
+ GrName = get_name(Mode0, Func),
+ {Cases2,Status3} =
+ case lists:keysearch(return_group_result, 1, Opts) of
+ {value,{_,failed}} ->
+ case {curr_ref(Mode),check_prop(sequence, Mode)} of
+ {ParentRef,ParentRef} ->
+ Reason = {group_result,GrName,failed},
+ {skip_cases_upto(ParentRef, Cases, Reason, tc,
+ Mode, auto_skip_case),
+ update_status(failed, group_result, GrName,
+ delete_status(Ref, Status2))};
+ _ ->
+ {Cases,update_status(failed, group_result, GrName,
+ delete_status(Ref, Status2))}
+ end;
+ {value,{_,GroupResult}} ->
+ {Cases,update_status(GroupResult, group_result, GrName,
+ delete_status(Ref, Status2))};
+ false ->
+ {Cases,update_status(ok, group_result, GrName,
+ delete_status(Ref, Status2))}
+ end,
+ print_conf_time(ConfTime),
+ ReportRepeatStop(),
+ set_io_buffering(IOHandler),
+ stop_minor_log_file(),
+ run_test_cases_loop(Cases2, tl(Config), TimetrapData,
+ Mode, Status3)
+ end;
+
+run_test_cases_loop([{make,Ref,{Mod,Func,Args}}|Cases0], Config, TimetrapData,
+ Mode, Status) ->
+ case run_test_case(Ref, 0, Mod, Func, Args, skip_init, TimetrapData) of
+ {_,Why={'EXIT',_},_} ->
+ print(minor, "~n*** ~w failed.~n"
+ " Skipping all cases.", [Func]),
+ Reason = {failed,{Mod,Func,Why}},
+ Cases = skip_cases_upto(Ref, Cases0, Reason, conf, Mode,
+ auto_skip_case),
+ stop_minor_log_file(),
+ run_test_cases_loop(Cases, Config, TimetrapData, Mode, Status);
+ {_,_Whatever,_} ->
+ stop_minor_log_file(),
+ run_test_cases_loop(Cases0, Config, TimetrapData, Mode, Status)
+ end;
+
+run_test_cases_loop([{conf,_Ref,_Props,_X}=Conf|_Cases0],
+ Config, _TimetrapData, _Mode, _Status) ->
+ erlang:error(badarg, [Conf,Config]);
+
+run_test_cases_loop([{Mod,Case}|Cases], Config, TimetrapData, Mode, Status) ->
+ ActualCfg =
+ case get(test_server_create_priv_dir) of
+ auto_per_run ->
+ update_config(hd(Config), [{priv_dir,get(test_server_priv_dir)},
+ {data_dir,get_data_dir(Mod)}]);
+ _ ->
+ update_config(hd(Config), [{data_dir,get_data_dir(Mod)}])
+ end,
+ run_test_cases_loop([{Mod,Case,[ActualCfg]}|Cases], Config,
+ TimetrapData, Mode, Status);
+
+run_test_cases_loop([{Mod,Func,Args}|Cases], Config, TimetrapData, Mode, Status) ->
+ {Num,RunInit} =
+ case FwMod = get_fw_mod(?MODULE) of
+ Mod when Func == error_in_suite ->
+ {-1,skip_init};
+ _ ->
+ {put(test_server_case_num, get(test_server_case_num)+1),
+ run_init}
+ end,
+
+ %% check the current execution mode and save info about the case if
+ %% detected that printouts to common log files is handled later
+
+ case check_prop(parallel, Mode) =:= false andalso is_io_buffered() of
+ true ->
+ %% sequential test case nested in a parallel group;
+ %% io is buffered, so we must queue this test case
+ queue_test_case_io(undefined, self(), Num+1, Mod, Func);
+ false ->
+ ok
+ end,
+
+ case run_test_case(undefined, Num+1, Mod, Func, Args,
+ RunInit, TimetrapData, Mode) of
+ %% callback to framework module failed, exit immediately
+ {_,{framework_error,{FwMod,FwFunc},Reason},_} ->
+ print(minor, "~n*** ~w failed in ~w. Reason: ~p~n",
+ [FwMod,FwFunc,Reason]),
+ print(1, "~w failed in ~w. Reason: ~p~n", [FwMod,FwFunc,Reason]),
+ stop_minor_log_file(),
+ exit(framework_error);
+ %% sequential execution of test case finished
+ {Time,RetVal,_} ->
+ {Failed,Status1} =
+ case Time of
+ died ->
+ {true,update_status(failed, Mod, Func, Status)};
+ _ when is_tuple(RetVal) ->
+ case element(1, RetVal) of
+ R when R=='EXIT'; R==failed ->
+ {true,update_status(failed, Mod, Func, Status)};
+ R when R==skip; R==skipped ->
+ {false,update_status(skipped, Mod, Func, Status)};
+ _ ->
+ {false,update_status(ok, Mod, Func, Status)}
+ end;
+ _ ->
+ {false,update_status(ok, Mod, Func, Status)}
+ end,
+ case check_prop(sequence, Mode) of
+ false ->
+ stop_minor_log_file(),
+ run_test_cases_loop(Cases, Config, TimetrapData, Mode, Status1);
+ Ref ->
+ %% the case is in a sequence; we must check the result and
+ %% determine if the following cases should run or be skipped
+ if not Failed -> % proceed with next case
+ stop_minor_log_file(),
+ run_test_cases_loop(Cases, Config, TimetrapData, Mode, Status1);
+ true -> % skip rest of cases in sequence
+ print(minor, "~n*** ~w failed.~n"
+ " Skipping all other cases in sequence.",
+ [Func]),
+ Reason = {failed,{Mod,Func}},
+ Cases2 = skip_cases_upto(Ref, Cases, Reason, tc,
+ Mode, auto_skip_case),
+ stop_minor_log_file(),
+ run_test_cases_loop(Cases2, Config, TimetrapData, Mode, Status1)
+ end
+ end;
+ %% the test case is being executed in parallel with the main process (and
+ %% other test cases) and Pid is the dedicated process executing the case
+ Pid ->
+ %% io from Pid will be buffered by the test_server_io process and
+ %% handled later, so we have to save info about the case
+ queue_test_case_io(undefined, Pid, Num+1, Mod, Func),
+ run_test_cases_loop(Cases, Config, TimetrapData, Mode, Status)
+ end;
+
+%% TestSpec processing finished
+run_test_cases_loop([], _Config, _TimetrapData, _, _) ->
+ ok.
+
+%%--------------------------------------------------------------------
+%% various help functions
+
+new_status(Ref, Status) ->
+ [{Ref,{{[],[],[]},[]}} | Status].
+
+new_status(Ref, CopiedCases, Status) ->
+ [{Ref,{{[],[],[]},CopiedCases}} | Status].
+
+delete_status(Ref, Status) ->
+ lists:keydelete(Ref, 1, Status).
+
+update_status(ok, Mod, Func, [{Ref,{{Ok,Skip,Fail},Cs}} | Status]) ->
+ [{Ref,{{Ok++[{Mod,Func}],Skip,Fail},Cs}} | Status];
+
+update_status(skipped, Mod, Func, [{Ref,{{Ok,Skip,Fail},Cs}} | Status]) ->
+ [{Ref,{{Ok,Skip++[{Mod,Func}],Fail},Cs}} | Status];
+
+update_status(failed, Mod, Func, [{Ref,{{Ok,Skip,Fail},Cs}} | Status]) ->
+ [{Ref,{{Ok,Skip,Fail++[{Mod,Func}]},Cs}} | Status];
+
+update_status(_, _, _, []) ->
+ [].
+
+update_status(Ref, {Ok,Skip,Fail}, [{Ref,{{Ok0,Skip0,Fail0},Cs}} | Status]) ->
+ [{Ref,{{Ok0++Ok,Skip0++Skip,Fail0++Fail},Cs}} | Status].
+
+get_copied_cases([{_,{_,Cases}} | _Status]) ->
+ Cases.
+
+get_tc_results([{_,{OkSkipFail,_}} | _Status]) ->
+ OkSkipFail;
+get_tc_results([]) -> % in case init_per_suite crashed
+ {[],[],[]}.
+
+conf(Ref, Props) ->
+ {Ref,Props,?now}.
+
+curr_ref([{Ref,_Props,_}|_]) ->
+ Ref;
+curr_ref([]) ->
+ undefined.
+
+curr_mode(Ref, Mode0, Mode1) ->
+ case curr_ref(Mode1) of
+ Ref -> Mode1;
+ _ -> Mode0
+ end.
+
+get_props([{_,Props,_} | _]) ->
+ Props;
+get_props([]) ->
+ [].
+
+check_prop(_Attrib, []) ->
+ false;
+check_prop(Attrib, [{Ref,Props,_}|_]) ->
+ case lists:member(Attrib, Props) of
+ true -> Ref;
+ false -> false
+ end.
+
+check_props(Attrib, Mode) ->
+ case [R || {R,Ps,_} <- Mode, lists:member(Attrib, Ps)] of
+ [] -> false;
+ [Ref|_] -> Ref
+ end.
+
+get_name(Mode, Def) ->
+ case get_name(Mode) of
+ undefined -> Def;
+ Name -> Name
+ end.
+
+get_name([{_Ref,Props,_}|_]) ->
+ proplists:get_value(name, Props);
+get_name([]) ->
+ undefined.
+
+conf_start(Ref, Mode) ->
+ case lists:keysearch(Ref, 1, Mode) of
+ {value,{_,_,T}} -> T;
+ false -> 0
+ end.
+
+
+get_data_dir(Mod) ->
+ get_data_dir(Mod, undefined).
+
+get_data_dir(Mod, Suite) ->
+ UseMod = if Suite == undefined -> Mod;
+ true -> Suite
+ end,
+ case code:which(UseMod) of
+ non_existing ->
+ print(12, "The module ~w is not loaded", [Mod]),
+ [];
+ cover_compiled ->
+ MainCoverNode = cover:get_main_node(),
+ {file,File} = rpc:call(MainCoverNode,cover,is_compiled,[UseMod]),
+ do_get_data_dir(UseMod,File);
+ FullPath ->
+ do_get_data_dir(UseMod,FullPath)
+ end.
+
+do_get_data_dir(Mod,File) ->
+ filename:dirname(File) ++ "/" ++ atom_to_list(Mod) ++ ?data_dir_suffix.
+
+print_conf_time(0) ->
+ ok;
+print_conf_time(ConfTime) ->
+ print(major, "=group_time ~.3fs", [ConfTime]),
+ print(minor, "~n=== Total execution time of group: ~.3fs~n", [ConfTime]).
+
+print_props([]) ->
+ ok;
+print_props(Props) ->
+ print(major, "=group_props ~p", [Props]),
+ print(minor, "Group properties: ~p~n", [Props]).
+
+%% repeat N times: {repeat,N}
+%% repeat N times or until all successful: {repeat_until_all_ok,N}
+%% repeat N times or until at least one successful: {repeat_until_any_ok,N}
+%% repeat N times or until at least one case fails: {repeat_until_any_fail,N}
+%% repeat N times or until all fails: {repeat_until_all_fail,N}
+%% N = integer() | forever
+get_repeat(Props) ->
+ get_prop([repeat,repeat_until_all_ok,repeat_until_any_ok,
+ repeat_until_any_fail,repeat_until_all_fail], forever, Props).
+
+update_repeat(Props) ->
+ case get_repeat(Props) of
+ undefined ->
+ Props;
+ {RepType,N} ->
+ Props1 =
+ if N == forever ->
+ [{RepType,N}|lists:keydelete(RepType, 1, Props)];
+ N < 3 ->
+ lists:keydelete(RepType, 1, Props);
+ N >= 3 ->
+ [{RepType,N-1}|lists:keydelete(RepType, 1, Props)]
+ end,
+ %% if shuffle is used in combination with repeat, a new
+ %% seed shouldn't be set every new turn
+ case get_shuffle(Props1) of
+ undefined ->
+ Props1;
+ _ ->
+ [{shuffle,repeated}|delete_shuffle(Props1)]
+ end
+ end.
+
+get_shuffle(Props) ->
+ get_prop([shuffle], ?now, Props).
+
+delete_shuffle(Props) ->
+ delete_prop([shuffle], Props).
+
+%% Return {Item,Value} if found, else if Item alone
+%% is found, return {Item,Default}
+get_prop([Item|Items], Default, Props) ->
+ case lists:keysearch(Item, 1, Props) of
+ {value,R} ->
+ R;
+ false ->
+ case lists:member(Item, Props) of
+ true ->
+ {Item,Default};
+ false ->
+ get_prop(Items, Default, Props)
+ end
+ end;
+get_prop([], _Def, _Props) ->
+ undefined.
+
+delete_prop([Item|Items], Props) ->
+ Props1 = lists:delete(Item, lists:keydelete(Item, 1, Props)),
+ delete_prop(Items, Props1);
+delete_prop([], Props) ->
+ Props.
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% shuffle_cases(Ref, Cases, Seed) -> Cases1
+%%
+%% Shuffles the order of Cases.
+
+shuffle_cases(Ref, Cases, undefined) ->
+ shuffle_cases(Ref, Cases, rand:seed_s(exsplus));
+
+shuffle_cases(Ref, [{conf,Ref,_,_}=Start | Cases], Seed0) ->
+ {N,CasesToShuffle,Rest} = cases_to_shuffle(Ref, Cases),
+ Seed = case Seed0 of
+ {X,Y,Z} when is_integer(X+Y+Z) ->
+ rand:seed(exsplus, Seed0);
+ _ ->
+ Seed0
+ end,
+ ShuffledCases = random_order(N, rand:uniform_s(N, Seed), CasesToShuffle, []),
+ [Start|ShuffledCases] ++ Rest.
+
+cases_to_shuffle(Ref, Cases) ->
+ cases_to_shuffle(Ref, Cases, 1, []).
+
+cases_to_shuffle(Ref, [{conf,Ref,_,_} | _]=Cs, N, Ix) -> % end
+ {N-1,Ix,Cs};
+cases_to_shuffle(Ref, [{skip_case,{_,Ref,_,_},_} | _]=Cs, N, Ix) -> % end
+ {N-1,Ix,Cs};
+
+cases_to_shuffle(Ref, [{conf,Ref1,_,_}=C | Cs], N, Ix) -> % nested group
+ {Cs1,Rest} = get_subcases(Ref1, Cs, []),
+ cases_to_shuffle(Ref, Rest, N+1, [{N,[C|Cs1]} | Ix]);
+cases_to_shuffle(Ref, [{skip_case,{_,Ref1,_,_},_}=C | Cs], N, Ix) -> % nested group
+ {Cs1,Rest} = get_subcases(Ref1, Cs, []),
+ cases_to_shuffle(Ref, Rest, N+1, [{N,[C|Cs1]} | Ix]);
+
+cases_to_shuffle(Ref, [C | Cs], N, Ix) ->
+ cases_to_shuffle(Ref, Cs, N+1, [{N,[C]} | Ix]).
+
+get_subcases(SubRef, [{conf,SubRef,_,_}=C | Cs], SubCs) ->
+ {lists:reverse([C|SubCs]),Cs};
+get_subcases(SubRef, [{skip_case,{_,SubRef,_,_},_}=C | Cs], SubCs) ->
+ {lists:reverse([C|SubCs]),Cs};
+get_subcases(SubRef, [C|Cs], SubCs) ->
+ get_subcases(SubRef, Cs, [C|SubCs]).
+
+random_order(1, {_Pos,Seed}, [{_Ix,CaseOrGroup}], Shuffled) ->
+ %% save current seed to be used if test cases are repeated
+ put(test_server_curr_random_seed, Seed),
+ Shuffled++CaseOrGroup;
+random_order(N, {Pos,NewSeed}, IxCases, Shuffled) ->
+ {First,[{_Ix,CaseOrGroup}|Rest]} = lists:split(Pos-1, IxCases),
+ random_order(N-1, rand:uniform_s(N-1, NewSeed),
+ First++Rest, Shuffled++CaseOrGroup).
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% skip_case(Type, Ref, CaseNum, Case, Comment, SendSync) -> {Mod,Func}
+%%
+%% Prints info about a skipped case in the major and html log files.
+%% SendSync determines if start and finished messages must be sent so
+%% that the printouts can be buffered and handled in order with io from
+%% parallel processes.
+skip_case(Type, Ref, CaseNum, Case, Comment, SendSync, Mode) ->
+ MF = {Mod,Func} = case Case of
+ {M,F,_A} -> {M,F};
+ {M,F} -> {M,F}
+ end,
+ if SendSync ->
+ queue_test_case_io(Ref, self(), CaseNum, Mod, Func),
+ self() ! {started,Ref,self(),CaseNum,Mod,Func},
+ test_server_io:start_transaction(),
+ skip_case1(Type, CaseNum, Mod, Func, Comment, Mode),
+ test_server_io:end_transaction(),
+ self() ! {finished,Ref,self(),CaseNum,Mod,Func,skipped,{0,skipped,[]}};
+ not SendSync ->
+ skip_case1(Type, CaseNum, Mod, Func, Comment, Mode)
+ end,
+ MF.
+
+skip_case1(Type, CaseNum, Mod, Func, Comment, Mode) ->
+ {{Col0,Col1},_} = get_font_style((CaseNum > 0), Mode),
+ ResultCol = if Type == auto -> ?auto_skip_color;
+ Type == user -> ?user_skip_color
+ end,
+ print(major, "~n=case ~w:~w", [Mod,Func]),
+ GroupName = case get_name(Mode) of
+ undefined ->
+ "";
+ GrName ->
+ GrName1 = cast_to_list(GrName),
+ print(major, "=group_props ~p", [[{name,GrName1}]]),
+ GrName1
+ end,
+ print(major, "=started ~s", [lists:flatten(timestamp_get(""))]),
+ Comment1 = reason_to_string(Comment),
+ if Type == auto ->
+ print(major, "=result auto_skipped: ~ts", [Comment1]);
+ Type == user ->
+ print(major, "=result skipped: ~ts", [Comment1])
+ end,
+ if CaseNum == 0 ->
+ print(2,"*** Skipping ~w ***", [{Mod,Func}]);
+ true ->
+ print(2,"*** Skipping test case #~w ~w ***", [CaseNum,{Mod,Func}])
+ end,
+ TR = xhtml("<tr valign=\"top\">", ["<tr class=\"",odd_or_even(),"\">"]),
+ GroupName = case get_name(Mode) of
+ undefined -> "";
+ Name -> cast_to_list(Name)
+ end,
+ print(html,
+ TR ++ "<td>" ++ Col0 ++ "~ts" ++ Col1 ++ "</td>"
+ "<td>" ++ Col0 ++ "~w" ++ Col1 ++ "</td>"
+ "<td>" ++ Col0 ++ "~ts" ++ Col1 ++ "</td>"
+ "<td>" ++ Col0 ++ "~w" ++ Col1 ++ "</td>"
+ "<td>" ++ Col0 ++ "< >" ++ Col1 ++ "</td>"
+ "<td>" ++ Col0 ++ "0.000s" ++ Col1 ++ "</td>"
+ "<td><font color=\"~ts\">SKIPPED</font></td>"
+ "<td>~ts</td></tr>\n",
+ [num2str(CaseNum),fw_name(Mod),GroupName,Func,ResultCol,Comment1]),
+
+ if CaseNum > 0 ->
+ {US,AS} = get(test_server_skipped),
+ case Type of
+ user -> put(test_server_skipped, {US+1,AS});
+ auto -> put(test_server_skipped, {US,AS+1})
+ end,
+ put(test_server_case_num, CaseNum);
+ true -> % conf
+ ok
+ end.
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% skip_cases_upto(Ref, Cases, Reason, Origin, Mode, SkipType) -> Cases1
+%%
+%% SkipType = skip_case | auto_skip_case
+%% Mark all cases tagged with Ref as skipped.
+
+skip_cases_upto(Ref, Cases, Reason, Origin, Mode, SkipType) ->
+ {_,Modified,Rest} =
+ modify_cases_upto(Ref, {skip,Reason,Origin,Mode,SkipType}, Cases),
+ Modified++Rest.
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% copy_cases(OrigRef, NewRef, Cases) -> Cases1
+%%
+%% Copy the test cases marked with OrigRef and tag the copies with NewRef.
+%% The start conf case copy will also get its repeat property updated.
+
+copy_cases(OrigRef, NewRef, Cases) ->
+ {Original,Altered,Rest} = modify_cases_upto(OrigRef, {copy,NewRef}, Cases),
+ {Altered,Original++Altered++Rest}.
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% modify_cases_upto(Ref, ModOp, Cases) -> {Original,Altered,Remaining}
+%%
+%% ModOp = {skip,Reason,Origin,Mode} | {copy,NewRef}
+%% Origin = conf | tc
+%%
+%% Modifies Cases according to ModOp and returns the original elements,
+%% the modified versions of these elements and the remaining (untouched)
+%% cases.
+
+modify_cases_upto(Ref, ModOp, Cases) ->
+ {Original,Altered,Rest} = modify_cases_upto(Ref, ModOp, Cases, [], []),
+ {lists:reverse(Original),lists:reverse(Altered),Rest}.
+
+%% first case of a copy operation is the start conf
+modify_cases_upto(Ref, {copy,NewRef}=Op, [{conf,Ref,Props,MF}=C|T], Orig, Alt) ->
+ modify_cases_upto(Ref, Op, T, [C|Orig], [{conf,NewRef,update_repeat(Props),MF}|Alt]);
+
+modify_cases_upto(Ref, ModOp, Cases, Orig, Alt) ->
+ %% we need to check if there's an end conf case with the
+ %% same ref in the list, if not, this *is* an end conf case
+ case lists:any(fun({_,R,_,_}) when R == Ref -> true;
+ ({_,R,_}) when R == Ref -> true;
+ ({skip_case,{_,R,_,_},_}) when R == Ref -> true;
+ ({skip_case,{_,R,_,_}}) when R == Ref -> true;
+ (_) -> false
+ end, Cases) of
+ true ->
+ modify_cases_upto1(Ref, ModOp, Cases, Orig, Alt);
+ false ->
+ {[],[],Cases}
+ end.
+
+%% next case is a conf with same ref, must be end conf = we're done
+modify_cases_upto1(Ref, {skip,Reason,conf,Mode,skip_case},
+ [{conf,Ref,_Props,MF}|T], Orig, Alt) ->
+ {Orig,[{skip_case,{conf,Ref,MF,Reason},Mode}|Alt],T};
+modify_cases_upto1(Ref, {skip,Reason,conf,Mode,auto_skip_case},
+ [{conf,Ref,_Props,MF}|T], Orig, Alt) ->
+ {Orig,[{auto_skip_case,{conf,Ref,MF,Reason},Mode}|Alt],T};
+modify_cases_upto1(Ref, {copy,NewRef}, [{conf,Ref,Props,MF}=C|T], Orig, Alt) ->
+ {[C|Orig],[{conf,NewRef,update_repeat(Props),MF}|Alt],T};
+
+%% we've skipped all remaining cases in a sequence
+modify_cases_upto1(Ref, {skip,_,tc,_,_},
+ [{conf,Ref,_Props,_MF}|_]=Cs, Orig, Alt) ->
+ {Orig,Alt,Cs};
+
+%% next is a make case
+modify_cases_upto1(Ref, {skip,Reason,_,Mode,SkipType},
+ [{make,Ref,MF}|T], Orig, Alt) ->
+ {Orig,[{SkipType,{make,Ref,MF,Reason},Mode}|Alt],T};
+modify_cases_upto1(Ref, {copy,NewRef}, [{make,Ref,MF}=M|T], Orig, Alt) ->
+ {[M|Orig],[{make,NewRef,MF}|Alt],T};
+
+%% next case is a user skipped end conf with the same ref = we're done
+modify_cases_upto1(Ref, {skip,Reason,_,Mode,SkipType},
+ [{skip_case,{Type,Ref,MF,_Cmt},_}|T], Orig, Alt) ->
+ {Orig,[{SkipType,{Type,Ref,MF,Reason},Mode}|Alt],T};
+modify_cases_upto1(Ref, {skip,Reason,_,Mode,SkipType},
+ [{skip_case,{Type,Ref,MF,_Cmt}}|T], Orig, Alt) ->
+ {Orig,[{SkipType,{Type,Ref,MF,Reason},Mode}|Alt],T};
+modify_cases_upto1(Ref, {copy,NewRef},
+ [{skip_case,{Type,Ref,MF,Cmt},Mode}=C|T], Orig, Alt) ->
+ {[C|Orig],[{skip_case,{Type,NewRef,MF,Cmt},Mode}|Alt],T};
+modify_cases_upto1(Ref, {copy,NewRef},
+ [{skip_case,{Type,Ref,MF,Cmt}}=C|T], Orig, Alt) ->
+ {[C|Orig],[{skip_case,{Type,NewRef,MF,Cmt}}|Alt],T};
+
+%% next is a skip_case, could be one test case or 'all' in suite, we must proceed
+modify_cases_upto1(Ref, ModOp, [{skip_case,{_F,_Cmt},_Mode}=MF|T], Orig, Alt) ->
+ modify_cases_upto1(Ref, ModOp, T, [MF|Orig], [MF|Alt]);
+
+%% next is a normal case (possibly in a sequence), mark as skipped, or copy, and proceed
+modify_cases_upto1(Ref, {skip,Reason,_,Mode,skip_case}=Op,
+ [{_M,_F}=MF|T], Orig, Alt) ->
+ modify_cases_upto1(Ref, Op, T, Orig, [{skip_case,{MF,Reason},Mode}|Alt]);
+modify_cases_upto1(Ref, {skip,Reason,_,Mode,auto_skip_case}=Op,
+ [{_M,_F}=MF|T], Orig, Alt) ->
+ modify_cases_upto1(Ref, Op, T, Orig, [{auto_skip_case,{MF,Reason},Mode}|Alt]);
+modify_cases_upto1(Ref, CopyOp, [{_M,_F}=MF|T], Orig, Alt) ->
+ modify_cases_upto1(Ref, CopyOp, T, [MF|Orig], [MF|Alt]);
+
+%% next is a conf case, modify the Mode arg to keep track of sub groups
+modify_cases_upto1(Ref, {skip,Reason,FType,Mode,SkipType},
+ [{conf,OtherRef,Props,_MF}|T], Orig, Alt) ->
+ case hd(Mode) of
+ {OtherRef,_,_} -> % end conf
+ modify_cases_upto1(Ref, {skip,Reason,FType,tl(Mode),SkipType},
+ T, Orig, Alt);
+ _ -> % start conf
+ Mode1 = [conf(OtherRef,Props)|Mode],
+ modify_cases_upto1(Ref, {skip,Reason,FType,Mode1,SkipType},
+ T, Orig, Alt)
+ end;
+
+%% next is some other case, ignore or copy
+modify_cases_upto1(Ref, {skip,_,_,_,_}=Op, [_Other|T], Orig, Alt) ->
+ modify_cases_upto1(Ref, Op, T, Orig, Alt);
+modify_cases_upto1(Ref, CopyOp, [C|T], Orig, Alt) ->
+ modify_cases_upto1(Ref, CopyOp, T, [C|Orig], [C|Alt]).
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% set_io_buffering(IOHandler) -> PrevIOHandler
+%%
+%% Save info about current process (always the main process) buffering
+%% io printout messages from parallel test case processes (*and* possibly
+%% also the main process).
+
+set_io_buffering(IOHandler) ->
+ put(test_server_common_io_handler, IOHandler).
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% is_io_buffered() -> true|false
+%%
+%% Test whether is being buffered.
+
+is_io_buffered() ->
+ get(test_server_common_io_handler) =/= undefined.
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% queue_test_case_io(Pid, Num, Mod, Func) -> ok
+%%
+%% Save info about test case that gets its io buffered. This can
+%% be a parallel test case or it can be a test case (conf or normal)
+%% that belongs to a group nested under a parallel group. The queue
+%% is processed after io buffering is disabled. See run_test_cases_loop/4
+%% and handle_test_case_io_and_status/0 for more info.
+
+queue_test_case_io(Ref, Pid, Num, Mod, Func) ->
+ Entry = {Ref,Pid,Num,Mod,Func},
+ %% the order of the test cases is very important!
+ put(test_server_queued_io,
+ get(test_server_queued_io)++[Entry]).
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% wait_for_cases(Ref) -> {Ok,Skipped,Failed}
+%%
+%% At the end of a nested parallel group, we have to wait for the test
+%% cases to terminate before we can go on (since test cases never execute
+%% in parallel with the end conf case of the group). When a top level
+%% parallel group is finished, buffered io messages must be handled and
+%% this is taken care of by handle_test_case_io_and_status/0.
+
+wait_for_cases(Ref) ->
+ case get(test_server_queued_io) of
+ [] ->
+ {[],[],[]};
+ Cases ->
+ [_Start|TCs] =
+ lists:dropwhile(fun({R,_,_,_,_}) when R == Ref -> false;
+ (_) -> true
+ end, Cases),
+ wait_and_resend(Ref, TCs, [],[],[])
+ end.
+
+wait_and_resend(Ref, [{OtherRef,_,0,_,_}|Ps],
+ Ok,Skip,Fail) when is_reference(OtherRef),
+ OtherRef /= Ref ->
+ %% ignore cases that belong to nested group
+ Ps1 = rm_cases_upto(OtherRef, Ps),
+ wait_and_resend(Ref, Ps1, Ok,Skip,Fail);
+
+wait_and_resend(Ref, [{_,CurrPid,CaseNum,Mod,Func}|Ps] = Cases, Ok,Skip,Fail) ->
+ receive
+ {finished,_Ref,CurrPid,CaseNum,Mod,Func,Result,_RetVal} = Msg ->
+ %% resend message to main process so that it can be used
+ %% to test_server_io:print_buffered/1 later
+ self() ! Msg,
+ MF = {Mod,Func},
+ {Ok1,Skip1,Fail1} =
+ case Result of
+ ok -> {[MF|Ok],Skip,Fail};
+ skipped -> {Ok,[MF|Skip],Fail};
+ failed -> {Ok,Skip,[MF|Fail]}
+ end,
+ wait_and_resend(Ref, Ps, Ok1,Skip1,Fail1);
+ {'EXIT',CurrPid,Reason} when Reason /= normal ->
+ %% unexpected termination of test case process
+ {value,{_,_,CaseNum,Mod,Func}} = lists:keysearch(CurrPid, 2, Cases),
+ print(1, "Error! Process for test case #~w (~w:~w) died! Reason: ~p",
+ [CaseNum, Mod, Func, Reason]),
+ exit({unexpected_termination,{CaseNum,Mod,Func},{CurrPid,Reason}})
+ end;
+
+wait_and_resend(_, [], Ok,Skip,Fail) ->
+ {lists:reverse(Ok),lists:reverse(Skip),lists:reverse(Fail)}.
+
+rm_cases_upto(Ref, [{Ref,_,0,_,_}|Ps]) ->
+ Ps;
+rm_cases_upto(Ref, [_|Ps]) ->
+ rm_cases_upto(Ref, Ps).
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% handle_test_case_io_and_status() -> [Ok,Skipped,Failed}
+%%
+%% Each parallel test case process prints to its own minor log file during
+%% execution. The common log files (major, html etc) must however be
+%% written to sequentially. This is handled by calling
+%% test_server_io:start_transaction/0 to tell the test_server_io process
+%% to buffer all print requests.
+%%
+%% An io session is always started with a
+%% {started,Ref,Pid,Num,Mod,Func} message (and
+%% test_server_io:start_transaction/0 will be called) and terminated
+%% with {finished,Ref,Pid,Num,Mod,Func,Result,RetVal} (and
+%% test_server_io:end_transaction/0 will be called). The result
+%% shipped with the finished message from a parallel process is used
+%% to update status data of the current test run. An 'EXIT' message
+%% from each parallel test case process (after finishing and
+%% terminating) is also received and handled here.
+%%
+%% During execution of a parallel group, any cases (conf or normal)
+%% belonging to a nested group will also get its io printouts buffered.
+%% This is necessary to get the major and html log files written in
+%% correct sequence. This function handles also the print messages
+%% generated by nested group cases that have been executed sequentially
+%% by the main process (note that these cases do not generate 'EXIT'
+%% messages, only 'start' and 'finished' messages).
+%%
+%% See the header comment for run_test_cases_loop/4 for more
+%% info about IO handling.
+%%
+%% Note: It is important that the type of messages handled here
+%% do not get consumed by test_server:run_test_case_msgloop/5
+%% during the test case execution (e.g. in the catch clause of
+%% the receive)!
+
+handle_test_case_io_and_status() ->
+ case get(test_server_queued_io) of
+ [] ->
+ {[],[],[]};
+ Cases ->
+ %% Cases = [{Ref,Pid,CaseNum,Mod,Func} | ...]
+ Result = handle_io_and_exit_loop([], Cases, [],[],[]),
+ Main = self(),
+ %% flush normal exit messages
+ lists:foreach(fun({_,Pid,_,_,_}) when Pid /= Main ->
+ receive
+ {'EXIT',Pid,normal} -> ok
+ after
+ 1000 -> ok
+ end;
+ (_) ->
+ ok
+ end, Cases),
+ Result
+ end.
+
+%% Handle cases (without Ref) that belong to the top parallel group (i.e. when Refs = [])
+handle_io_and_exit_loop([], [{undefined,CurrPid,CaseNum,Mod,Func}|Ps] = Cases, Ok,Skip,Fail) ->
+ %% retrieve the start message for the current io session (= testcase)
+ receive
+ {started,_,CurrPid,CaseNum,Mod,Func} ->
+ {Ok1,Skip1,Fail1} =
+ case handle_io_and_exits(self(), CurrPid, CaseNum, Mod, Func, Cases) of
+ {ok,MF} -> {[MF|Ok],Skip,Fail};
+ {skipped,MF} -> {Ok,[MF|Skip],Fail};
+ {failed,MF} -> {Ok,Skip,[MF|Fail]}
+ end,
+ handle_io_and_exit_loop([], Ps, Ok1,Skip1,Fail1)
+ after
+ 1000 ->
+ exit({testcase_failed_to_start,Mod,Func})
+ end;
+
+%% Handle cases that belong to groups nested under top parallel group
+handle_io_and_exit_loop(Refs, [{Ref,CurrPid,CaseNum,Mod,Func}|Ps] = Cases, Ok,Skip,Fail) ->
+ receive
+ {started,_,CurrPid,CaseNum,Mod,Func} ->
+ handle_io_and_exits(self(), CurrPid, CaseNum, Mod, Func, Cases),
+ Refs1 =
+ case Refs of
+ [Ref|Rs] -> % must be end conf case for subgroup
+ Rs;
+ _ when is_reference(Ref) -> % must be start of new subgroup
+ [Ref|Refs];
+ _ -> % must be normal subgroup testcase
+ Refs
+ end,
+ handle_io_and_exit_loop(Refs1, Ps, Ok,Skip,Fail)
+ after
+ 1000 ->
+ exit({testcase_failed_to_start,Mod,Func})
+ end;
+
+handle_io_and_exit_loop(_, [], Ok,Skip,Fail) ->
+ {lists:reverse(Ok),lists:reverse(Skip),lists:reverse(Fail)}.
+
+handle_io_and_exits(Main, CurrPid, CaseNum, Mod, Func, Cases) ->
+ receive
+ {abort_current_testcase=Tag,_Reason,From} ->
+ %% If a parallel group is executing, there is no unique
+ %% current test case, so we must generate an error.
+ From ! {self(),Tag,{error,parallel_group}},
+ handle_io_and_exits(Main, CurrPid, CaseNum, Mod, Func, Cases);
+ %% end of io session from test case executed by main process
+ {finished,_,Main,CaseNum,Mod,Func,Result,_RetVal} ->
+ test_server_io:print_buffered(CurrPid),
+ {Result,{Mod,Func}};
+ %% end of io session from test case executed by parallel process
+ {finished,_,CurrPid,CaseNum,Mod,Func,Result,RetVal} ->
+ test_server_io:print_buffered(CurrPid),
+ case Result of
+ ok ->
+ put(test_server_ok, get(test_server_ok)+1);
+ failed ->
+ put(test_server_failed, get(test_server_failed)+1);
+ skipped ->
+ SkipCounters =
+ update_skip_counters(RetVal, get(test_server_skipped)),
+ put(test_server_skipped, SkipCounters)
+ end,
+ {Result,{Mod,Func}};
+
+ %% unexpected termination of test case process
+ {'EXIT',TCPid,Reason} when Reason /= normal ->
+ test_server_io:print_buffered(CurrPid),
+ {value,{_,_,Num,M,F}} = lists:keysearch(TCPid, 2, Cases),
+ print(1, "Error! Process for test case #~w (~w:~w) died! Reason: ~p",
+ [Num, M, F, Reason]),
+ exit({unexpected_termination,{Num,M,F},{TCPid,Reason}})
+ end.
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% run_test_case(Ref, Num, Mod, Func, Args, RunInit,
+%% TimetrapData, Mode) -> RetVal
+%%
+%% Creates the minor log file and inserts some test case specific headers
+%% and footers into the log files. Then the test case is executed and the
+%% result is printed to the log files (also info about lingering processes
+%% & slave nodes in the system is presented).
+%%
+%% RunInit decides if the per test case init is to be run (true for all
+%% but conf cases).
+%%
+%% Mode specifies if the test case should be executed by a dedicated,
+%% parallel, process rather than sequentially by the main process. If
+%% the former, the new process is spawned and the dictionary of the main
+%% process is copied to the test case process.
+%%
+%% RetVal is the result of executing the test case. It contains info
+%% about the execution time and the return value of the test case function.
+
+run_test_case(Ref, Num, Mod, Func, Args, RunInit, TimetrapData) ->
+ file:set_cwd(filename:dirname(get(test_server_dir))),
+ run_test_case1(Ref, Num, Mod, Func, Args, RunInit,
+ TimetrapData, [], self()).
+
+run_test_case(Ref, Num, Mod, Func, Args, skip_init, TimetrapData, Mode) ->
+ %% a conf case is always executed by the main process
+ run_test_case1(Ref, Num, Mod, Func, Args, skip_init,
+ TimetrapData, Mode, self());
+
+run_test_case(Ref, Num, Mod, Func, Args, RunInit, TimetrapData, Mode) ->
+ file:set_cwd(filename:dirname(get(test_server_dir))),
+ Main = self(),
+ case check_prop(parallel, Mode) of
+ false ->
+ %% this is a sequential test case
+ run_test_case1(Ref, Num, Mod, Func, Args, RunInit,
+ TimetrapData, Mode, Main);
+ _Ref ->
+ %% this a parallel test case, spawn the new process
+ Dictionary = get(),
+ {dictionary,Dictionary} = process_info(self(), dictionary),
+ spawn_link(
+ fun() ->
+ process_flag(trap_exit, true),
+ [put(Key, Val) || {Key,Val} <- Dictionary],
+ set_io_buffering({tc,Main}),
+ run_test_case1(Ref, Num, Mod, Func, Args, RunInit,
+ TimetrapData, Mode, Main)
+ end)
+ end.
+
+run_test_case1(Ref, Num, Mod, Func, Args, RunInit,
+ TimetrapData, Mode, Main) ->
+ group_leader(test_server_io:get_gl(Main == self()), self()),
+
+ %% if io is being buffered, send start io session message
+ %% (no matter if case runs on parallel or main process)
+ case is_io_buffered() of
+ false -> ok;
+ true ->
+ test_server_io:start_transaction(),
+ Main ! {started,Ref,self(),Num,Mod,Func}
+ end,
+ TSDir = get(test_server_dir),
+
+ print(major, "=case ~w:~w", [Mod, Func]),
+ MinorName = start_minor_log_file(Mod, Func, self() /= Main),
+ MinorBase = filename:basename(MinorName),
+ print(major, "=logfile ~ts", [filename:basename(MinorName)]),
+
+ UpdatedArgs =
+ %% maybe create unique private directory for test case or config func
+ case get(test_server_create_priv_dir) of
+ auto_per_run ->
+ update_config(hd(Args), [{tc_logfile,MinorName}]);
+ PrivDirMode ->
+ %% create unique private directory for test case
+ RunDir = filename:dirname(MinorName),
+ Ext =
+ if Num == 0 ->
+ Int = erlang:unique_integer([positive,monotonic]),
+ lists:flatten(io_lib:format(".cfg.~w", [Int]));
+ true ->
+ lists:flatten(io_lib:format(".~w", [Num]))
+ end,
+ PrivDir = filename:join(RunDir, ?priv_dir) ++ Ext,
+ if PrivDirMode == auto_per_tc ->
+ ok = file:make_dir(PrivDir);
+ PrivDirMode == manual_per_tc ->
+ ok
+ end,
+ update_config(hd(Args), [{priv_dir,PrivDir++"/"},
+ {tc_logfile,MinorName}])
+ end,
+ GrName = get_name(Mode),
+ test_server_sup:framework_call(report,
+ [tc_start,{{Mod,{Func,GrName}},
+ MinorName}]),
+
+ {ok,Cwd} = file:get_cwd(),
+ Args2Print = if is_list(UpdatedArgs) ->
+ lists:keydelete(tc_group_result, 1, UpdatedArgs);
+ true ->
+ UpdatedArgs
+ end,
+ if RunInit == skip_init ->
+ print_props(get_props(Mode));
+ true ->
+ ok
+ end,
+
+ print(minor,
+ escape_chars(io_lib:format("Config value:\n\n ~tp\n", [Args2Print])),
+ []),
+ print(minor, "Current directory is ~tp\n", [Cwd]),
+
+ GrNameStr = case GrName of
+ undefined -> "";
+ Name -> cast_to_list(Name)
+ end,
+ print(major, "=started ~s", [lists:flatten(timestamp_get(""))]),
+ {{Col0,Col1},Style} = get_font_style((RunInit==run_init), Mode),
+ TR = xhtml("<tr valign=\"top\">", ["<tr class=\"",odd_or_even(),"\">"]),
+ EncMinorBase = uri_encode(MinorBase),
+ print(html, TR ++ "<td>" ++ Col0 ++ "~ts" ++ Col1 ++ "</td>"
+ "<td>" ++ Col0 ++ "~w" ++ Col1 ++ "</td>"
+ "<td>" ++ Col0 ++ "~ts" ++ Col1 ++ "</td>"
+ "<td><a href=\"~ts\">~w</a></td>"
+ "<td><a href=\"~ts#top\">&lt;</a> <a href=\"~ts#end\">&gt;</a></td>",
+ [num2str(Num),fw_name(Mod),GrNameStr,EncMinorBase,Func,
+ EncMinorBase,EncMinorBase]),
+
+ do_unless_parallel(Main, fun erlang:yield/0),
+
+ %% run the test case
+ {Result,DetectedFail,ProcsBefore,ProcsAfter} =
+ run_test_case_apply(Num, Mod, Func, [UpdatedArgs], GrName,
+ RunInit, TimetrapData),
+ {Time,RetVal,Loc,Opts,Comment} =
+ case Result of
+ Normal={_Time,_RetVal,_Loc,_Opts,_Comment} -> Normal;
+ {died,DReason,DLoc,DCmt} -> {died,DReason,DLoc,[],DCmt}
+ end,
+
+ print(minor, "<a name=\"end\"></a>", [], internal_raw),
+ print(minor, "\n", [], internal_raw),
+ print_timestamp(minor, "Ended at "),
+ print(major, "=ended ~s", [lists:flatten(timestamp_get(""))]),
+
+ do_unless_parallel(Main, fun() -> file:set_cwd(filename:dirname(TSDir)) end),
+
+ %% call the appropriate progress function clause to print the results to log
+ Status =
+ case {Time,RetVal} of
+ {died,{timetrap_timeout,TimetrapTimeout}} ->
+ progress(failed, Num, Mod, Func, GrName, Loc,
+ timetrap_timeout, TimetrapTimeout, Comment, Style);
+ {died,Reason} ->
+ progress(failed, Num, Mod, Func, GrName, Loc, Reason,
+ Time, Comment, Style);
+ {_,{'EXIT',{Skip,Reason}}} when Skip==skip; Skip==skipped;
+ Skip==auto_skip ->
+ progress(skip, Num, Mod, Func, GrName, Loc, Reason,
+ Time, Comment, Style);
+ {_,{'EXIT',_Pid,{Skip,Reason}}} when Skip==skip; Skip==skipped ->
+ progress(skip, Num, Mod, Func, GrName, Loc, Reason,
+ Time, Comment, Style);
+ {_,{'EXIT',_Pid,Reason}} ->
+ progress(failed, Num, Mod, Func, GrName, Loc, Reason,
+ Time, Comment, Style);
+ {_,{'EXIT',Reason}} ->
+ progress(failed, Num, Mod, Func, GrName, Loc, Reason,
+ Time, Comment, Style);
+ {_,{Fail,Reason}} when Fail =:= fail; Fail =:= failed ->
+ progress(failed, Num, Mod, Func, GrName, Loc, Reason,
+ Time, Comment, Style);
+ {_,Reason={auto_skip,_Why}} ->
+ progress(skip, Num, Mod, Func, GrName, Loc, Reason,
+ Time, Comment, Style);
+ {_,{Skip,Reason}} when Skip==skip; Skip==skipped ->
+ progress(skip, Num, Mod, Func, GrName, Loc, Reason,
+ Time, Comment, Style);
+ {Time,RetVal} ->
+ case DetectedFail of
+ [] ->
+ progress(ok, Num, Mod, Func, GrName, Loc, RetVal,
+ Time, Comment, Style);
+
+ Reason ->
+ progress(failed, Num, Mod, Func, GrName, Loc, Reason,
+ Time, Comment, Style)
+ end
+ end,
+ %% if the test case was executed sequentially, this updates the
+ %% status count on the main process (status of parallel test cases
+ %% is updated later by the handle_test_case_io_and_status/0 function)
+ case {RunInit,Status} of
+ {skip_init,_} -> % conf doesn't count
+ ok;
+ {_,ok} ->
+ put(test_server_ok, get(test_server_ok)+1);
+ {_,failed} ->
+ put(test_server_failed, get(test_server_failed)+1);
+ {_,skip} ->
+ {US,AS} = get(test_server_skipped),
+ put(test_server_skipped, {US+1,AS});
+ {_,auto_skip} ->
+ {US,AS} = get(test_server_skipped),
+ put(test_server_skipped, {US,AS+1})
+ end,
+ %% only if test case execution is sequential do we care about the
+ %% remaining processes and slave nodes count
+ case self() of
+ Main ->
+ case test_server_sup:framework_call(warn, [processes], true) of
+ true ->
+ if ProcsBefore < ProcsAfter ->
+ print(minor,
+ "WARNING: ~w more processes in system after test case",
+ [ProcsAfter-ProcsBefore]);
+ ProcsBefore > ProcsAfter ->
+ print(minor,
+ "WARNING: ~w less processes in system after test case",
+ [ProcsBefore-ProcsAfter]);
+ true -> ok
+ end;
+ false ->
+ ok
+ end,
+ case test_server_sup:framework_call(warn, [nodes], true) of
+ true ->
+ case catch controller_call(kill_slavenodes) of
+ {'EXIT',_} = Exit ->
+ print(minor,
+ "WARNING: There might be slavenodes left in the"
+ " system. I tried to kill them, but I failed: ~p\n",
+ [Exit]);
+ [] -> ok;
+ List ->
+ print(minor, "WARNING: ~w slave nodes in system after test"++
+ "case. Tried to killed them.~n"++
+ " Names:~p",
+ [length(List),List])
+ end;
+ false ->
+ ok
+ end;
+ _ ->
+ ok
+ end,
+ %% if the test case was executed sequentially, this updates the execution
+ %% time count on the main process (adding execution time of parallel test
+ %% case groups is done in run_test_cases_loop/4)
+ if is_number(Time) ->
+ put(test_server_total_time, get(test_server_total_time)+Time);
+ true ->
+ ok
+ end,
+ test_server_sup:check_new_crash_dumps(),
+
+ %% if io is being buffered, send finished message
+ %% (no matter if case runs on parallel or main process)
+ case is_io_buffered() of
+ false ->
+ ok;
+ true ->
+ test_server_io:end_transaction(),
+ Main ! {finished,Ref,self(),Num,Mod,Func,
+ ?mod_result(Status),{Time,RetVal,Opts}}
+ end,
+ {Time,RetVal,Opts}.
+
+
+%%--------------------------------------------------------------------
+%% various help functions
+
+%% Call Action if we are running on the main process (not parallel).
+do_unless_parallel(Main, Action) when is_function(Action, 0) ->
+ case self() of
+ Main -> Action();
+ _ -> ok
+ end.
+
+num2str(0) -> "";
+num2str(N) -> integer_to_list(N).
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% progress(Result, CaseNum, Mod, Func, Location, Reason, Time,
+%% Comment, TimeFormat) -> Result
+%%
+%% Prints the result of the test case to log file.
+%% Note: Strings that are to be written to the minor log must
+%% be prefixed with "=== " here, or the indentation will be wrong.
+
+progress(skip, CaseNum, Mod, Func, GrName, Loc, Reason, Time,
+ Comment, {St0,St1}) ->
+ {Reason1,{Color,Ret,ReportTag}} =
+ if_auto_skip(Reason,
+ fun() -> {?auto_skip_color,auto_skip,auto_skipped} end,
+ fun() -> {?user_skip_color,skip,skipped} end),
+ print(major, "=result ~w: ~p", [ReportTag,Reason1]),
+ print(1, "*** SKIPPED ~ts ***",
+ [get_info_str(Mod,Func, CaseNum, get(test_server_cases))]),
+ test_server_sup:framework_call(report, [tc_done,{Mod,{Func,GrName},
+ {ReportTag,Reason1}}]),
+ ReasonStr = escape_chars(reason_to_string(Reason1)),
+ ReasonStr1 = lists:flatten([string:strip(S,left) ||
+ S <- string:tokens(ReasonStr,[$\n])]),
+ ReasonStr2 =
+ if length(ReasonStr1) > 80 ->
+ string:substr(ReasonStr1, 1, 77) ++ "...";
+ true ->
+ ReasonStr1
+ end,
+ Comment1 = case Comment of
+ "" -> "";
+ _ -> xhtml("<br>(","<br />(") ++ to_string(Comment) ++ ")"
+ end,
+ print(html,
+ "<td>" ++ St0 ++ "~.3fs" ++ St1 ++ "</td>"
+ "<td><font color=\"~ts\">SKIPPED</font></td>"
+ "<td>~ts~ts</td></tr>\n",
+ [Time,Color,ReasonStr2,Comment1]),
+ FormatLoc = test_server_sup:format_loc(Loc),
+ print(minor, "=== Location: ~ts", [FormatLoc]),
+ print(minor, "=== Reason: ~ts", [ReasonStr1]),
+ Ret;
+
+progress(failed, CaseNum, Mod, Func, GrName, Loc, timetrap_timeout, T,
+ Comment0, {St0,St1}) ->
+ print(major, "=result failed: timeout, ~p", [Loc]),
+ print(1, "*** FAILED ~ts ***",
+ [get_info_str(Mod,Func, CaseNum, get(test_server_cases))]),
+ test_server_sup:framework_call(report,
+ [tc_done,{Mod,{Func,GrName},
+ {failed,timetrap_timeout}}]),
+ FormatLastLoc = test_server_sup:format_loc(get_last_loc(Loc)),
+ ErrorReason = io_lib:format("{timetrap_timeout,~ts}", [FormatLastLoc]),
+ Comment =
+ case Comment0 of
+ "" -> "<font color=\"red\">" ++ ErrorReason ++ "</font>";
+ _ -> "<font color=\"red\">" ++ ErrorReason ++
+ xhtml("</font><br>","</font><br />") ++ to_string(Comment0)
+ end,
+ print(html,
+ "<td>" ++ St0 ++ "~.3fs" ++ St1 ++ "</td>"
+ "<td><font color=\"red\">FAILED</font></td>"
+ "<td>~ts</td></tr>\n",
+ [T/1000,Comment]),
+ FormatLoc = test_server_sup:format_loc(Loc),
+ print(minor, "=== Location: ~ts", [FormatLoc]),
+ print(minor, "=== Reason: timetrap timeout", []),
+ failed;
+
+progress(failed, CaseNum, Mod, Func, GrName, Loc, {testcase_aborted,Reason}, _T,
+ Comment0, {St0,St1}) ->
+ print(major, "=result failed: testcase_aborted, ~p", [Loc]),
+ print(1, "*** FAILED ~ts ***",
+ [get_info_str(Mod,Func, CaseNum, get(test_server_cases))]),
+ test_server_sup:framework_call(report,
+ [tc_done,{Mod,{Func,GrName},
+ {failed,testcase_aborted}}]),
+ FormatLastLoc = test_server_sup:format_loc(get_last_loc(Loc)),
+ ErrorReason = io_lib:format("{testcase_aborted,~ts}", [FormatLastLoc]),
+ Comment =
+ case Comment0 of
+ "" -> "<font color=\"red\">" ++ ErrorReason ++ "</font>";
+ _ -> "<font color=\"red\">" ++ ErrorReason ++
+ xhtml("</font><br>","</font><br />") ++ to_string(Comment0)
+ end,
+ print(html,
+ "<td>" ++ St0 ++ "died" ++ St1 ++ "</td>"
+ "<td><font color=\"red\">FAILED</font></td>"
+ "<td>~ts</td></tr>\n",
+ [Comment]),
+ FormatLoc = test_server_sup:format_loc(Loc),
+ print(minor, "=== Location: ~ts", [FormatLoc]),
+ print(minor,
+ escape_chars(io_lib:format("=== Reason: {testcase_aborted,~p}",
+ [Reason])),
+ []),
+ failed;
+
+progress(failed, CaseNum, Mod, Func, GrName, unknown, Reason, Time,
+ Comment0, {St0,St1}) ->
+ print(major, "=result failed: ~p, ~w", [Reason,unknown_location]),
+ print(1, "*** FAILED ~ts ***",
+ [get_info_str(Mod,Func, CaseNum, get(test_server_cases))]),
+ test_server_sup:framework_call(report, [tc_done,{Mod,{Func,GrName},
+ {failed,Reason}}]),
+ TimeStr = io_lib:format(if is_float(Time) -> "~.3fs";
+ true -> "~w"
+ end, [Time]),
+ ErrorReason = escape_chars(lists:flatten(io_lib:format("~p", [Reason]))),
+ ErrorReason1 = lists:flatten([string:strip(S,left) ||
+ S <- string:tokens(ErrorReason,[$\n])]),
+ ErrorReason2 =
+ if length(ErrorReason1) > 63 ->
+ string:substr(ErrorReason1, 1, 60) ++ "...";
+ true ->
+ ErrorReason1
+ end,
+ Comment =
+ case Comment0 of
+ "" -> "<font color=\"red\">" ++ ErrorReason2 ++ "</font>";
+ _ -> "<font color=\"red\">" ++ ErrorReason2 ++
+ xhtml("</font><br>","</font><br />") ++
+ to_string(Comment0)
+ end,
+ print(html,
+ "<td>" ++ St0 ++ "~ts" ++ St1 ++ "</td>"
+ "<td><font color=\"red\">FAILED</font></td>"
+ "<td>~ts</td></tr>\n",
+ [TimeStr,Comment]),
+ print(minor, "=== Location: ~w", [unknown]),
+ {FStr,FormattedReason} = format_exception(Reason),
+ print(minor,
+ escape_chars(io_lib:format("=== Reason: " ++ FStr, [FormattedReason])),
+ []),
+ failed;
+
+progress(failed, CaseNum, Mod, Func, GrName, Loc, Reason, Time,
+ Comment0, {St0,St1}) ->
+ {LocMaj,LocMin} = if Func == error_in_suite ->
+ case get_fw_mod(undefined) of
+ Mod -> {unknown_location,unknown};
+ _ -> {Loc,Loc}
+ end;
+ true -> {Loc,Loc}
+ end,
+ print(major, "=result failed: ~p, ~p", [Reason,LocMaj]),
+ print(1, "*** FAILED ~ts ***",
+ [get_info_str(Mod,Func, CaseNum, get(test_server_cases))]),
+ test_server_sup:framework_call(report, [tc_done,{Mod,{Func,GrName},
+ {failed,Reason}}]),
+ TimeStr = io_lib:format(if is_float(Time) -> "~.3fs";
+ true -> "~w"
+ end, [Time]),
+ Comment =
+ case Comment0 of
+ "" -> "";
+ _ -> xhtml("<br>","<br />") ++ to_string(Comment0)
+ end,
+ FormatLastLoc = test_server_sup:format_loc(get_last_loc(LocMaj)),
+ print(html,
+ "<td>" ++ St0 ++ "~ts" ++ St1 ++ "</td>"
+ "<td><font color=\"red\">FAILED</font></td>"
+ "<td><font color=\"red\">~ts</font>~ts</td></tr>\n",
+ [TimeStr,FormatLastLoc,Comment]),
+ FormatLoc = test_server_sup:format_loc(LocMin),
+ print(minor, "=== Location: ~ts", [FormatLoc]),
+ {FStr,FormattedReason} = format_exception(Reason),
+ print(minor, "=== Reason: " ++
+ escape_chars(io_lib:format(FStr, [FormattedReason])), []),
+ failed;
+
+progress(ok, _CaseNum, Mod, Func, GrName, _Loc, RetVal, Time,
+ Comment0, {St0,St1}) ->
+ print(minor, "successfully completed test case", []),
+ test_server_sup:framework_call(report, [tc_done,{Mod,{Func,GrName},ok}]),
+ Comment =
+ case RetVal of
+ {comment,RetComment} ->
+ String = to_string(RetComment),
+ HtmlCmt = test_server_sup:framework_call(format_comment,
+ [String],
+ String),
+ print(major, "=result ok: ~ts", [String]),
+ "<td>" ++ HtmlCmt ++ "</td>";
+ _ ->
+ print(major, "=result ok", []),
+ case Comment0 of
+ "" -> "<td></td>";
+ _ -> "<td>" ++ to_string(Comment0) ++ "</td>"
+ end
+ end,
+ print(major, "=elapsed ~p", [Time]),
+ print(html,
+ "<td>" ++ St0 ++ "~.3fs" ++ St1 ++ "</td>"
+ "<td><font color=\"green\">Ok</font></td>"
+ "~ts</tr>\n",
+ [Time,Comment]),
+ print(minor,
+ escape_chars(io_lib:format("=== Returned value: ~tp", [RetVal])),
+ []),
+ ok.
+
+%%--------------------------------------------------------------------
+%% various help functions
+escape_chars(Term) when not is_list(Term), not is_binary(Term) ->
+ esc_chars_in_list(io_lib:format("~tp", [Term]));
+escape_chars(List = [Term | _]) when not is_list(Term), not is_integer(Term) ->
+ esc_chars_in_list(io_lib:format("~tp", [List]));
+escape_chars(List) ->
+ esc_chars_in_list(List).
+
+esc_chars_in_list([Bin | Io]) when is_binary(Bin) ->
+ [Bin | esc_chars_in_list(Io)];
+esc_chars_in_list([List | Io]) when is_list(List) ->
+ [esc_chars_in_list(List) | esc_chars_in_list(Io)];
+esc_chars_in_list([$< | Io]) ->
+ ["&lt;" | esc_chars_in_list(Io)];
+esc_chars_in_list([$> | Io]) ->
+ ["&gt;" | esc_chars_in_list(Io)];
+esc_chars_in_list([$& | Io]) ->
+ ["&amp;" | esc_chars_in_list(Io)];
+esc_chars_in_list([Char | Io]) when is_integer(Char) ->
+ [Char | esc_chars_in_list(Io)];
+esc_chars_in_list([]) ->
+ [];
+esc_chars_in_list(Bin) ->
+ Bin.
+
+get_fw_mod(Mod) ->
+ case get(test_server_framework) of
+ undefined ->
+ case os:getenv("TEST_SERVER_FRAMEWORK") of
+ FW when FW =:= false; FW =:= "undefined" ->
+ Mod;
+ FW ->
+ list_to_atom(FW)
+ end;
+ '$none' -> Mod;
+ FW -> FW
+ end.
+
+fw_name(?MODULE) ->
+ test_server;
+fw_name(Mod) ->
+ case get(test_server_framework_name) of
+ undefined ->
+ case get_fw_mod(undefined) of
+ undefined ->
+ Mod;
+ Mod ->
+ case os:getenv("TEST_SERVER_FRAMEWORK_NAME") of
+ FWName when FWName =:= false; FWName =:= "undefined" ->
+ Mod;
+ FWName ->
+ list_to_atom(FWName)
+ end;
+ _ ->
+ Mod
+ end;
+ '$none' ->
+ Mod;
+ FWName ->
+ case get_fw_mod(Mod) of
+ Mod -> FWName;
+ _ -> Mod
+ end
+ end.
+
+if_auto_skip(Reason={failed,{_,init_per_testcase,_}}, True, _False) ->
+ {Reason,True()};
+if_auto_skip({skip,Reason={failed,{_,init_per_testcase,_}}}, True, _False) ->
+ {Reason,True()};
+if_auto_skip({auto_skip,Reason}, True, _False) ->
+ {Reason,True()};
+if_auto_skip(Reason, _True, False) ->
+ {Reason,False()}.
+
+update_skip_counters({_T,Pat,_Opts}, {US,AS}) ->
+ {_,Result} = if_auto_skip(Pat, fun() -> {US,AS+1} end, fun() -> {US+1,AS} end),
+ Result;
+update_skip_counters(Pat, {US,AS}) ->
+ {_,Result} = if_auto_skip(Pat, fun() -> {US,AS+1} end, fun() -> {US+1,AS} end),
+ Result.
+
+get_info_str(Mod,Func, 0, _Cases) ->
+ io_lib:format("~w", [{Mod,Func}]);
+get_info_str(_Mod,_Func, CaseNum, unknown) ->
+ "test case " ++ integer_to_list(CaseNum);
+get_info_str(_Mod,_Func, CaseNum, Cases) ->
+ "test case " ++ integer_to_list(CaseNum) ++
+ " of " ++ integer_to_list(Cases).
+
+print_if_known(Known, {SK,AK}, {SU,AU}) ->
+ {S,A} = if Known == unknown -> {SU,AU};
+ true -> {SK,AK}
+ end,
+ io_lib:format(S, A).
+
+to_string(Term) when is_list(Term) ->
+ case (catch io_lib:format("~ts", [Term])) of
+ {'EXIT',_} -> lists:flatten(io_lib:format("~p", [Term]));
+ String -> lists:flatten(String)
+ end;
+to_string(Term) ->
+ lists:flatten(io_lib:format("~p", [Term])).
+
+get_last_loc(Loc) when is_tuple(Loc) ->
+ Loc;
+get_last_loc([Loc|_]) when is_tuple(Loc) ->
+ [Loc];
+get_last_loc(Loc) ->
+ Loc.
+
+reason_to_string({failed,{_,FailFunc,bad_return}}) ->
+ atom_to_list(FailFunc) ++ " bad return value";
+reason_to_string({failed,{_,FailFunc,{timetrap_timeout,_}}}) ->
+ atom_to_list(FailFunc) ++ " timed out";
+reason_to_string(FWInitFail = {failed,{_CB,init_tc,_Reason}}) ->
+ to_string(FWInitFail);
+reason_to_string({failed,{_,FailFunc,_}}) ->
+ atom_to_list(FailFunc) ++ " failed";
+reason_to_string(Other) ->
+ to_string(Other).
+
+%get_font_style(Prop) ->
+% {Col,St0,St1} = get_font_style1(Prop),
+% {{"<font color="++Col++">","</font>"},
+% {"<font color="++Col++">"++St0,St1++"</font>"}}.
+
+get_font_style(NormalCase, Mode) ->
+ Prop = if not NormalCase ->
+ default;
+ true ->
+ case check_prop(parallel, Mode) of
+ false ->
+ case check_prop(sequence, Mode) of
+ false ->
+ default;
+ _ ->
+ sequence
+ end;
+ _ ->
+ parallel
+ end
+ end,
+ {Col,St0,St1} = get_font_style1(Prop),
+ {{"<font color="++Col++">","</font>"},
+ {"<font color="++Col++">"++St0,St1++"</font>"}}.
+
+get_font_style1(parallel) ->
+ {"\"darkslategray\"","<i>","</i>"};
+get_font_style1(sequence) ->
+% {"\"darkolivegreen\"","",""};
+ {"\"saddlebrown\"","",""};
+get_font_style1(default) ->
+ {"\"black\"","",""}.
+%%get_font_style1(skipped) ->
+%% {"\"lightgray\"","",""}.
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% format_exception({Error,Stack}) -> {CtrlSeq,Term}
+%%
+%% The default behaviour is that error information gets formatted
+%% (like in the erlang shell) before printed to the minor log file.
+%% The framework application can switch this feature off by setting
+%% *its* application environment variable 'format_exception' to false.
+%% It is also possible to switch formatting off by starting the
+%% test_server node with init argument 'test_server_format_exception'
+%% set to false.
+
+format_exception(Reason={_Error,Stack}) when is_list(Stack) ->
+ case get_fw_mod(undefined) of
+ undefined ->
+ case application:get_env(test_server, format_exception) of
+ {ok,false} ->
+ {"~p",Reason};
+ _ ->
+ do_format_exception(Reason)
+ end;
+ FW ->
+ case application:get_env(FW, format_exception) of
+ {ok,false} ->
+ {"~p",Reason};
+ _ ->
+ do_format_exception(Reason)
+ end
+ end;
+format_exception(Error) ->
+ format_exception({Error,[]}).
+
+do_format_exception(Reason={Error,Stack}) ->
+ StackFun = fun(_, _, _) -> false end,
+ PF = fun(Term, I) ->
+ io_lib:format("~." ++ integer_to_list(I) ++ "p", [Term])
+ end,
+ case catch lib:format_exception(1, error, Error, Stack, StackFun, PF) of
+ {'EXIT',_} ->
+ {"~p",Reason};
+ Formatted ->
+ Formatted1 = re:replace(Formatted, "exception error: ", "", [{return,list}]),
+ {"~ts",lists:flatten(Formatted1)}
+ end.
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% run_test_case_apply(CaseNum, Mod, Func, Args, Name, RunInit,
+%% TimetrapData) ->
+%% {{Time,RetVal,Loc,Opts,Comment},DetectedFail,ProcessesBefore,ProcessesAfter} |
+%% {{died,Reason,unknown,Comment},DetectedFail,ProcessesBefore,ProcessesAfter}
+%% Name = atom()
+%% Time = float() (seconds)
+%% RetVal = term()
+%% Loc = term()
+%% Comment = string()
+%% Reason = term()
+%% DetectedFail = [{File,Line}]
+%% ProcessesBefore = ProcessesAfter = integer()
+%%
+
+run_test_case_apply(CaseNum, Mod, Func, Args, Name, RunInit,
+ TimetrapData) ->
+ test_server:run_test_case_apply({CaseNum,Mod,Func,Args,Name,RunInit,
+ TimetrapData}).
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% print(Detail, Format, Args) -> ok
+%% Detail = integer()
+%% Format = string()
+%% Args = [term()]
+%%
+%% Just like io:format, except that depending on the Detail value, the output
+%% is directed to console, major and/or minor log files.
+
+print(Detail, Format) ->
+ print(Detail, Format, []).
+
+print(Detail, Format, Args) ->
+ print(Detail, Format, Args, internal).
+
+print(Detail, ["$tc_html",Format], Args, Printer) ->
+ Msg = io_lib:format(Format, Args),
+ print_or_buffer(Detail, ["$tc_html",Msg], Printer);
+
+print(Detail, Format, Args, Printer) ->
+ Msg = io_lib:format(Format, Args),
+ print_or_buffer(Detail, Msg, Printer).
+
+print_or_buffer(Detail, Msg, Printer) ->
+ test_server_gl:print(group_leader(), Detail, Msg, Printer).
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% print_timestamp(Detail, Leader) -> ok
+%%
+%% Prints Leader followed by a time stamp (date and time). Depending on
+%% the Detail value, the output is directed to console, major and/or minor
+%% log files.
+
+print_timestamp(Detail, Leader) ->
+ print(Detail, timestamp_get(Leader), []).
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% print_who(Host, User) -> ok
+%%
+%% Logs who runs the suite.
+
+print_who(Host, User) ->
+ UserStr = case User of
+ "" -> "";
+ _ -> " by " ++ User
+ end,
+ print(html, "Run~ts on ~ts", [UserStr,Host]).
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% format(Format) -> IoLibReturn
+%% format(Detail, Format) -> IoLibReturn
+%% format(Format, Args) -> IoLibReturn
+%% format(Detail, Format, Args) -> IoLibReturn
+%%
+%% Detail = integer()
+%% Format = string()
+%% Args = [term(),...]
+%% IoLibReturn = term()
+%%
+%% Logs the Format string and Args, similar to io:format/1/2 etc. If
+%% Detail is not specified, the default detail level (which is 50) is used.
+%% Which log files the string will be logged in depends on the thresholds
+%% set with set_levels/3. Typically with default detail level, only the
+%% minor log file is used.
+
+format(Format) ->
+ format(minor, Format, []).
+
+format(major, Format) ->
+ format(major, Format, []);
+format(minor, Format) ->
+ format(minor, Format, []);
+format(Detail, Format) when is_integer(Detail) ->
+ format(Detail, Format, []);
+format(Format, Args) ->
+ format(minor, Format, Args).
+
+format(Detail, Format, Args) ->
+ Str =
+ case catch io_lib:format(Format, Args) of
+ {'EXIT',_} ->
+ io_lib:format("illegal format; ~p with args ~p.\n",
+ [Format,Args]);
+ Valid -> Valid
+ end,
+ print_or_buffer(Detail, Str, self()).
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% xhtml(BasicHtml, XHtml) -> BasicHtml | XHtml
+%%
+xhtml(HTML, XHTML) ->
+ case get(basic_html) of
+ true -> HTML;
+ _ -> XHTML
+ end.
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% odd_or_even() -> "odd" | "even"
+%%
+odd_or_even() ->
+ case get(odd_or_even) of
+ even ->
+ put(odd_or_even, odd),
+ "even";
+ _ ->
+ put(odd_or_even, even),
+ "odd"
+ end.
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% timestamp_filename_get(Leader) -> string()
+%% Leader = string()
+%%
+%% Returns a string consisting of Leader concatenated with the current
+%% date and time. The resulting string is suitable as a filename.
+timestamp_filename_get(Leader) ->
+ timestamp_get_internal(Leader,
+ "~ts~w-~2.2.0w-~2.2.0w_~2.2.0w.~2.2.0w.~2.2.0w").
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% timestamp_get(Leader) -> string()
+%% Leader = string()
+%%
+%% Returns a string consisting of Leader concatenated with the current
+%% date and time. The resulting string is suitable for display.
+timestamp_get(Leader) ->
+ timestamp_get_internal(Leader,
+ "~ts~w-~2.2.0w-~2.2.0w ~2.2.0w:~2.2.0w:~2.2.0w").
+
+timestamp_get_internal(Leader, Format) ->
+ {YY,MM,DD,H,M,S} = time_get(),
+ io_lib:format(Format, [Leader,YY,MM,DD,H,M,S]).
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% time_get() -> {YY,MM,DD,H,M,S}
+%% YY = integer()
+%% MM = integer()
+%% DD = integer()
+%% H = integer()
+%% M = integer()
+%% S = integer()
+%%
+%% Returns the current Year,Month,Day,Hours,Minutes,Seconds.
+%% The function checks that the date doesn't wrap while calling
+%% getting the time.
+time_get() ->
+ {YY,MM,DD} = date(),
+ {H,M,S} = time(),
+ case date() of
+ {YY,MM,DD} ->
+ {YY,MM,DD,H,M,S};
+ _NewDay ->
+ %% date changed between call to date() and time(), try again
+ time_get()
+ end.
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% make_config(Config) -> NewConfig
+%% Config = [{Key,Value},...]
+%% NewConfig = [{Key,Value},...]
+%%
+%% Creates a configuration list (currently returns it's input)
+
+make_config(Initial) ->
+ Initial.
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% update_config(Config, Update) -> NewConfig
+%% Config = [{Key,Value},...]
+%% Update = [{Key,Value},...] | {Key,Value}
+%% NewConfig = [{Key,Value},...]
+%%
+%% Adds or replaces the key-value pairs in config with those in update.
+%% Returns the updated list.
+
+update_config(Config, {Key,Val}) ->
+ case lists:keymember(Key, 1, Config) of
+ true ->
+ lists:keyreplace(Key, 1, Config, {Key,Val});
+ false ->
+ [{Key,Val}|Config]
+ end;
+update_config(Config, [Assoc|Assocs]) ->
+ NewConfig = update_config(Config, Assoc),
+ update_config(NewConfig, Assocs);
+update_config(Config, []) ->
+ Config.
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% collect_cases(CurMod, TopCase, SkipList) ->
+%% BasicCaseList | {error,Reason}
+%%
+%% CurMod = atom()
+%% TopCase = term()
+%% SkipList = [term(),...]
+%% BasicCaseList = [term(),...]
+%%
+%% Parses the given test goal(s) in TopCase, and transforms them to a
+%% simple list of test cases to call, when executing the test suite.
+%%
+%% CurMod is the "current" module, that is, the module the last instruction
+%% was read from. May be be set to 'none' initially.
+%%
+%% SkipList is the list of test cases to skip and requirements to deny.
+%%
+%% The BasicCaseList is built out of TopCase, which may be any of the
+%% following terms:
+%%
+%% [] Nothing is added
+%% List list() The list is decomposed, and each element is
+%% treated according to this table
+%% Case atom() CurMod:Case(suite) is called
+%% {module,Case} CurMod:Case(suite) is called
+%% {Module,Case} Module:Case(suite) is called
+%% {module,Module,Case} Module:Case(suite) is called
+%% {module,Module,Case,Args} Module:Case is called with Args as arguments
+%% {dir,Dir} All modules *_SUITE in the named directory
+%% are listed, and each Module:all(suite) is called
+%% {dir,Dir,Pattern} All modules <Pattern>_SUITE in the named dir
+%% are listed, and each Module:all(suite) is called
+%% {conf,InitMF,Cases,FinMF}
+%% {conf,Props,InitMF,Cases,FinMF}
+%% InitMF is placed in the BasicCaseList, then
+%% Cases is treated according to this table, then
+%% FinMF is placed in the BasicCaseList. InitMF
+%% and FinMF are configuration manipulation
+%% functions. See below.
+%% {make,InitMFA,Cases,FinMFA}
+%% InitMFA is placed in the BasicCaseList, then
+%% Cases is treated according to this table, then
+%% FinMFA is placed in the BasicCaseList. InitMFA
+%% and FinMFA are make/unmake functions. If InitMFA
+%% fails, Cases are not run.
+%%
+%% When a function is called, above, it means that the function is invoked
+%% and the return is expected to be:
+%%
+%% [] Leaf case
+%% {req,ReqList} Kept for backwards compatibility - same as []
+%% {req,ReqList,Cases} Kept for backwards compatibility -
+%% Cases parsed recursively with collect_cases/3
+%% Cases (list) Recursively parsed with collect_cases/3
+%%
+%% Leaf cases are added to the BasicCaseList as Module:Case(Config). Each
+%% case is checked against the SkipList. If present, a skip instruction
+%% is inserted instead, which only prints the case name and the reason
+%% why the case was skipped in the log files.
+%%
+%% Configuration manipulation functions are called with the current
+%% configuration list as only argument, and are expected to return a new
+%% configuration list. Such a pair of function may, for example, start a
+%% server and stop it after a serie of test cases.
+%%
+%% SkipCases is expected to be in the format:
+%%
+%% Other Recursively parsed with collect_cases/3
+%% {Mod,Comment} Skip Mod, with Comment
+%% {Mod,Funcs,Comment} Skip listed functions in Mod with Comment
+%% {Mod,Func,Comment} Skip named function in Mod with Comment
+%%
+-record(cc, {mod, % current module
+ skip}). % skip list
+
+collect_all_cases(Top, Skip) when is_list(Skip) ->
+ Result =
+ case collect_cases(Top, #cc{mod=[],skip=Skip}, []) of
+ {ok,Cases,_St} -> Cases;
+ Other -> Other
+ end,
+ Result.
+
+
+collect_cases([], St, _) -> {ok,[],St};
+collect_cases([Case|Cs0], St0, Mode) ->
+ case collect_cases(Case, St0, Mode) of
+ {ok,FlatCases1,St1} ->
+ case collect_cases(Cs0, St1, Mode) of
+ {ok,FlatCases2,St} ->
+ {ok,FlatCases1 ++ FlatCases2,St};
+ {error,_Reason} = Error -> Error
+ end;
+ {error,_Reason} = Error -> Error
+ end;
+
+
+collect_cases({module,Case}, St, Mode) when is_atom(Case), is_atom(St#cc.mod) ->
+ collect_case({St#cc.mod,Case}, St, Mode);
+collect_cases({module,Mod,Case}, St, Mode) ->
+ collect_case({Mod,Case}, St, Mode);
+collect_cases({module,Mod,Case,Args}, St, Mode) ->
+ collect_case({Mod,Case,Args}, St, Mode);
+
+collect_cases({dir,SubDir}, St, Mode) ->
+ collect_files(SubDir, "*_SUITE", St, Mode);
+collect_cases({dir,SubDir,Pattern}, St, Mode) ->
+ collect_files(SubDir, Pattern++"*", St, Mode);
+
+collect_cases({conf,InitF,CaseList,FinMF}, St, Mode) when is_atom(InitF) ->
+ collect_cases({conf,[],{St#cc.mod,InitF},CaseList,FinMF}, St, Mode);
+collect_cases({conf,InitMF,CaseList,FinF}, St, Mode) when is_atom(FinF) ->
+ collect_cases({conf,[],InitMF,CaseList,{St#cc.mod,FinF}}, St, Mode);
+collect_cases({conf,InitMF,CaseList,FinMF}, St0, Mode) ->
+ collect_cases({conf,[],InitMF,CaseList,FinMF}, St0, Mode);
+collect_cases({conf,Props,InitF,CaseList,FinMF}, St, Mode) when is_atom(InitF) ->
+ case init_props(Props) of
+ {error,_} ->
+ {ok,[],St};
+ Props1 ->
+ collect_cases({conf,Props1,{St#cc.mod,InitF},CaseList,FinMF},
+ St, Mode)
+ end;
+collect_cases({conf,Props,InitMF,CaseList,FinF}, St, Mode) when is_atom(FinF) ->
+ case init_props(Props) of
+ {error,_} ->
+ {ok,[],St};
+ Props1 ->
+ collect_cases({conf,Props1,InitMF,CaseList,{St#cc.mod,FinF}},
+ St, Mode)
+ end;
+collect_cases({conf,Props,InitMF,CaseList,FinMF} = Conf, St, Mode) ->
+ case init_props(Props) of
+ {error,_} ->
+ {ok,[],St};
+ Props1 ->
+ Ref = make_ref(),
+ Skips = St#cc.skip,
+ Props2 = [{suite,St#cc.mod} | lists:delete(suite,Props1)],
+ Mode1 = [{Ref,Props2,undefined} | Mode],
+ case in_skip_list({St#cc.mod,Conf}, Skips) of
+ {true,Comment} -> % conf init skipped
+ {ok,[{skip_case,{conf,Ref,InitMF,Comment},Mode1} |
+ [] ++ [{conf,Ref,[],FinMF}]],St};
+ {true,Name,Comment} when is_atom(Name) -> % all cases skipped
+ case collect_cases(CaseList, St, Mode1) of
+ {ok,[],_St} = Empty ->
+ Empty;
+ {ok,FlatCases,St1} ->
+ Cases2Skip = FlatCases ++ [{conf,Ref,
+ keep_name(Props1),
+ FinMF}],
+ Skipped = skip_cases_upto(Ref, Cases2Skip, Comment,
+ conf, Mode1, skip_case),
+ {ok,[{skip_case,{conf,Ref,InitMF,Comment},Mode1} |
+ Skipped],St1};
+ {error,_Reason} = Error ->
+ Error
+ end;
+ {true,ToSkip,_} when is_list(ToSkip) -> % some cases skipped
+ case collect_cases(CaseList,
+ St#cc{skip=ToSkip++Skips}, Mode1) of
+ {ok,[],_St} = Empty ->
+ Empty;
+ {ok,FlatCases,St1} ->
+ {ok,[{conf,Ref,Props1,InitMF} |
+ FlatCases ++ [{conf,Ref,
+ keep_name(Props1),
+ FinMF}]],St1#cc{skip=Skips}};
+ {error,_Reason} = Error ->
+ Error
+ end;
+ false ->
+ case collect_cases(CaseList, St, Mode1) of
+ {ok,[],_St} = Empty ->
+ Empty;
+ {ok,FlatCases,St1} ->
+ {ok,[{conf,Ref,Props1,InitMF} |
+ FlatCases ++ [{conf,Ref,
+ keep_name(Props1),
+ FinMF}]],St1};
+ {error,_Reason} = Error ->
+ Error
+ end
+ end
+ end;
+
+collect_cases({make,InitMFA,CaseList,FinMFA}, St0, Mode) ->
+ case collect_cases(CaseList, St0, Mode) of
+ {ok,[],_St} = Empty -> Empty;
+ {ok,FlatCases,St} ->
+ Ref = make_ref(),
+ {ok,[{make,Ref,InitMFA}|FlatCases ++
+ [{make,Ref,FinMFA}]],St};
+ {error,_Reason} = Error -> Error
+ end;
+
+collect_cases({Module, Cases}, St, Mode) when is_list(Cases) ->
+ case (catch collect_case(Cases, St#cc{mod=Module}, [], Mode)) of
+ Result = {ok,_,_} ->
+ Result;
+ Other ->
+ {error,Other}
+ end;
+
+collect_cases({_Mod,_Case}=Spec, St, Mode) ->
+ collect_case(Spec, St, Mode);
+
+collect_cases({_Mod,_Case,_Args}=Spec, St, Mode) ->
+ collect_case(Spec, St, Mode);
+collect_cases(Case, St, Mode) when is_atom(Case), is_atom(St#cc.mod) ->
+ collect_case({St#cc.mod,Case}, St, Mode);
+collect_cases(Other, St, _Mode) ->
+ {error,{bad_subtest_spec,St#cc.mod,Other}}.
+
+collect_case({Mod,{conf,_,_,_,_}=Conf}, St, Mode) ->
+ collect_case_invoke(Mod, Conf, [], St, Mode);
+
+collect_case(MFA, St, Mode) ->
+ case in_skip_list(MFA, St#cc.skip) of
+ {true,Comment} when Comment /= make_failed ->
+ {ok,[{skip_case,{MFA,Comment},Mode}],St};
+ _ ->
+ case MFA of
+ {Mod,Case} -> collect_case_invoke(Mod, Case, MFA, St, Mode);
+ {_Mod,_Case,_Args} -> {ok,[MFA],St}
+ end
+ end.
+
+collect_case([], St, Acc, _Mode) ->
+ {ok, Acc, St};
+
+collect_case([Case | Cases], St, Acc, Mode) ->
+ {ok, FlatCases, NewSt} = collect_case({St#cc.mod, Case}, St, Mode),
+ collect_case(Cases, NewSt, Acc ++ FlatCases, Mode).
+
+collect_case_invoke(Mod, Case, MFA, St, Mode) ->
+ case get_fw_mod(undefined) of
+ undefined ->
+ case catch apply(Mod, Case, [suite]) of
+ {'EXIT',_} ->
+ {ok,[MFA],St};
+ Suite ->
+ collect_subcases(Mod, Case, MFA, St, Suite, Mode)
+ end;
+ _ ->
+ Suite = test_server_sup:framework_call(get_suite,
+ [Mod,Case],
+ []),
+ collect_subcases(Mod, Case, MFA, St, Suite, Mode)
+ end.
+
+collect_subcases(Mod, Case, MFA, St, Suite, Mode) ->
+ case Suite of
+ [] when Case == all -> {ok,[],St};
+ [] when element(1, Case) == conf -> {ok,[],St};
+ [] -> {ok,[MFA],St};
+%%%! --- START Kept for backwards compatibility ---
+%%%! Requirements are not used
+ {req,ReqList} ->
+ collect_case_deny(Mod, Case, MFA, ReqList, [], St, Mode);
+ {req,ReqList,SubCases} ->
+ collect_case_deny(Mod, Case, MFA, ReqList, SubCases, St, Mode);
+%%%! --- END Kept for backwards compatibility ---
+ {Skip,Reason} when Skip==skip; Skip==skipped ->
+ {ok,[{skip_case,{MFA,Reason},Mode}],St};
+ {error,Reason} ->
+ throw(Reason);
+ SubCases ->
+ collect_case_subcases(Mod, Case, SubCases, St, Mode)
+ end.
+
+collect_case_subcases(Mod, Case, SubCases, St0, Mode) ->
+ OldMod = St0#cc.mod,
+ case collect_cases(SubCases, St0#cc{mod=Mod}, Mode) of
+ {ok,FlatCases,St} ->
+ {ok,FlatCases,St#cc{mod=OldMod}};
+ {error,Reason} ->
+ {error,{{Mod,Case},Reason}}
+ end.
+
+collect_files(Dir, Pattern, St, Mode) ->
+ {ok,Cwd} = file:get_cwd(),
+ Dir1 = filename:join(Cwd, Dir),
+ Wc = filename:join([Dir1,Pattern++"{.erl,"++code:objfile_extension()++"}"]),
+ case catch filelib:wildcard(Wc) of
+ {'EXIT', Reason} ->
+ io:format("Could not collect files: ~p~n", [Reason]),
+ {error,{collect_fail,Dir,Pattern}};
+ Files ->
+ %% convert to module names and remove duplicates
+ Mods = lists:foldl(fun(File, Acc) ->
+ Mod = fullname_to_mod(File),
+ case lists:member(Mod, Acc) of
+ true -> Acc;
+ false -> [Mod | Acc]
+ end
+ end, [], Files),
+ Tests = [{Mod,all} || Mod <- lists:sort(Mods)],
+ collect_cases(Tests, St, Mode)
+ end.
+
+fullname_to_mod(Path) when is_list(Path) ->
+ %% If this is called with a binary, then we are probably in +fnu
+ %% mode and have found a beam file with name encoded as latin1. We
+ %% will let this crash since it can not work to load such a module
+ %% anyway. It should be removed or renamed!
+ list_to_atom(filename:rootname(filename:basename(Path))).
+
+collect_case_deny(Mod, Case, MFA, ReqList, SubCases, St, Mode) ->
+ case {check_deny(ReqList, St#cc.skip),SubCases} of
+ {{denied,Comment},_SubCases} ->
+ {ok,[{skip_case,{MFA,Comment},Mode}],St};
+ {granted,[]} ->
+ {ok,[MFA],St};
+ {granted,SubCases} ->
+ collect_case_subcases(Mod, Case, SubCases, St, Mode)
+ end.
+
+check_deny([Req|Reqs], DenyList) ->
+ case check_deny_req(Req, DenyList) of
+ {denied,_Comment}=Denied -> Denied;
+ granted -> check_deny(Reqs, DenyList)
+ end;
+check_deny([], _DenyList) -> granted;
+check_deny(Req, DenyList) -> check_deny([Req], DenyList).
+
+check_deny_req({Req,Val}, DenyList) ->
+ %%io:format("ValCheck ~p=~p in ~p\n", [Req,Val,DenyList]),
+ case lists:keysearch(Req, 1, DenyList) of
+ {value,{_Req,DenyVal}} when Val >= DenyVal ->
+ {denied,io_lib:format("Requirement ~p=~p", [Req,Val])};
+ _ ->
+ check_deny_req(Req, DenyList)
+ end;
+check_deny_req(Req, DenyList) ->
+ case lists:member(Req, DenyList) of
+ true -> {denied,io_lib:format("Requirement ~p", [Req])};
+ false -> granted
+ end.
+
+in_skip_list({Mod,{conf,Props,InitMF,_CaseList,_FinMF}}, SkipList) ->
+ case in_skip_list(InitMF, SkipList) of
+ {true,_} = Yes ->
+ Yes;
+ _ ->
+ case proplists:get_value(name, Props) of
+ undefined ->
+ false;
+ Name ->
+ ToSkip =
+ lists:flatmap(
+ fun({M,{conf,SProps,_,SCaseList,_},Cmt}) when
+ M == Mod ->
+ case proplists:get_value(name, SProps) of
+ all ->
+ [{M,all,Cmt}];
+ Name ->
+ case SCaseList of
+ all ->
+ [{M,all,Cmt}];
+ _ ->
+ [{M,F,Cmt} || F <- SCaseList]
+ end;
+ _ ->
+ []
+ end;
+ (_) ->
+ []
+ end, SkipList),
+ case ToSkip of
+ [] ->
+ false;
+ _ ->
+ case lists:keysearch(all, 2, ToSkip) of
+ {value,{_,_,Cmt}} -> {true,Name,Cmt};
+ _ -> {true,ToSkip,""}
+ end
+ end
+ end
+ end;
+
+in_skip_list({Mod,Func,_Args}, SkipList) ->
+ in_skip_list({Mod,Func}, SkipList);
+in_skip_list({Mod,Func}, [{Mod,Funcs,Comment}|SkipList]) when is_list(Funcs) ->
+ case lists:member(Func, Funcs) of
+ true ->
+ {true,Comment};
+ _ ->
+ in_skip_list({Mod,Func}, SkipList)
+ end;
+in_skip_list({Mod,Func}, [{Mod,Func,Comment}|_SkipList]) ->
+ {true,Comment};
+in_skip_list({Mod,_Func}, [{Mod,Comment}|_SkipList]) ->
+ {true,Comment};
+in_skip_list({Mod,Func}, [_|SkipList]) ->
+ in_skip_list({Mod,Func}, SkipList);
+in_skip_list(_, []) ->
+ false.
+
+%% remove unnecessary properties
+init_props(Props) ->
+ case get_repeat(Props) of
+ Repeat = {_RepType,N} when N < 2 ->
+ if N == 0 ->
+ {error,{invalid_property,Repeat}};
+ true ->
+ lists:delete(Repeat, Props)
+ end;
+ _ ->
+ Props
+ end.
+
+keep_name(Props) ->
+ lists:filter(fun({name,_}) -> true;
+ ({suite,_}) -> true;
+ (_) -> false end, Props).
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% Node handling functions %%
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% get_target_info() -> #target_info
+%%
+%% Returns a record containing system information for target
+
+get_target_info() ->
+ controller_call(get_target_info).
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% start_node(SlaveName, Type, Options) ->
+%% {ok, Slave} | {error, Reason}
+%%
+%% Called by test_server. See test_server:start_node/3 for details
+
+start_node(Name, Type, Options) ->
+ T = 10 * ?ACCEPT_TIMEOUT * test_server:timetrap_scale_factor(),
+ format(minor, "Attempt to start ~w node ~p with options ~p",
+ [Type, Name, Options]),
+ case controller_call({start_node,Name,Type,Options}, T) of
+ {{ok,Nodename}, Host, Cmd, Info, Warning} ->
+ format(minor,
+ "Successfully started node ~w on ~tp with command: ~ts",
+ [Nodename, Host, Cmd]),
+ format(major, "=node_start ~w", [Nodename]),
+ case Info of
+ [] -> ok;
+ _ -> format(minor, Info)
+ end,
+ case Warning of
+ [] -> ok;
+ _ ->
+ format(1, Warning),
+ format(minor, Warning)
+ end,
+ {ok, Nodename};
+ {fail,{Ret, Host, Cmd}} ->
+ format(minor,
+ "Failed to start node ~tp on ~tp with command: ~ts~n"
+ "Reason: ~p",
+ [Name, Host, Cmd, Ret]),
+ {fail,Ret};
+ {Ret, undefined, undefined} ->
+ format(minor, "Failed to start node ~tp: ~p", [Name,Ret]),
+ Ret;
+ {Ret, Host, Cmd} ->
+ format(minor,
+ "Failed to start node ~tp on ~tp with command: ~ts~n"
+ "Reason: ~p",
+ [Name, Host, Cmd, Ret]),
+ Ret
+ end.
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% wait_for_node(Node) -> ok | {error,timeout}
+%%
+%% Wait for a slave/peer node which has been started with
+%% the option {wait,false}. This function returns when
+%% when the new node has contacted test_server_ctrl again
+
+wait_for_node(Slave) ->
+ T = 10000 * test_server:timetrap_scale_factor(),
+ case catch controller_call({wait_for_node,Slave},T) of
+ {'EXIT',{timeout,_}} -> {error,timeout};
+ ok -> ok
+ end.
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% is_release_available(Release) -> true | false
+%% Release -> string()
+%%
+%% Test if a release (such as "r10b") is available to be
+%% started using start_node/3.
+
+is_release_available(Release) ->
+ controller_call({is_release_available,Release}).
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% stop_node(Name) -> ok | {error,Reason}
+%%
+%% Clean up - test_server will stop this node
+
+stop_node(Slave) ->
+ controller_call({stop_node,Slave}).
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% DEBUGGER INTERFACE %%
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+i() ->
+ hformat("Pid", "Initial Call", "Current Function", "Reducts", "Msgs"),
+ Line=lists:duplicate(27, "-"),
+ hformat(Line, Line, Line, Line, Line),
+ display_info(processes(), 0, 0).
+
+p(A,B,C) ->
+ pinfo(ts_pid(A,B,C)).
+p(X) when is_atom(X) ->
+ pinfo(whereis(X));
+p({A,B,C}) ->
+ pinfo(ts_pid(A,B,C));
+p(X) ->
+ pinfo(X).
+
+t() ->
+ t(wall_clock).
+t(X) ->
+ element(1, statistics(X)).
+
+pi(Item,X) ->
+ lists:keysearch(Item,1,p(X)).
+pi(Item,A,B,C) ->
+ lists:keysearch(Item,1,p(A,B,C)).
+
+%% c:pid/3
+ts_pid(X,Y,Z) when is_integer(X), is_integer(Y), is_integer(Z) ->
+ list_to_pid("<" ++ integer_to_list(X) ++ "." ++
+ integer_to_list(Y) ++ "." ++
+ integer_to_list(Z) ++ ">").
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% display_info(Pids, Reductions, Messages) -> void
+%% Pids = [pid(),...]
+%% Reductions = integer()
+%% Messaged = integer()
+%%
+%% Displays info, similar to c:i() about the processes in the list Pids.
+%% Also counts the total number of reductions and msgs for the listed
+%% processes, if called with Reductions = Messages = 0.
+
+display_info([Pid|T], R, M) ->
+ case pinfo(Pid) of
+ undefined ->
+ display_info(T, R, M);
+ Info ->
+ Call = fetch(initial_call, Info),
+ Curr = case fetch(current_function, Info) of
+ {Mod,F,Args} when is_list(Args) ->
+ {Mod,F,length(Args)};
+ Other ->
+ Other
+ end,
+ Reds = fetch(reductions, Info),
+ LM = length(fetch(messages, Info)),
+ pformat(io_lib:format("~w", [Pid]),
+ io_lib:format("~w", [Call]),
+ io_lib:format("~w", [Curr]), Reds, LM),
+ display_info(T, R+Reds, M + LM)
+ end;
+display_info([], R, M) ->
+ Line=lists:duplicate(27, "-"),
+ hformat(Line, Line, Line, Line, Line),
+ pformat("Total", "", "", R, M).
+
+hformat(A1, A2, A3, A4, A5) ->
+ io:format("~-10s ~-27s ~-27s ~8s ~4s~n", [A1,A2,A3,A4,A5]).
+
+pformat(A1, A2, A3, A4, A5) ->
+ io:format("~-10s ~-27s ~-27s ~8w ~4w~n", [A1,A2,A3,A4,A5]).
+
+fetch(Key, Info) ->
+ case lists:keysearch(Key, 1, Info) of
+ {value, {_, Val}} ->
+ Val;
+ _ ->
+ 0
+ end.
+
+pinfo(P) ->
+ Node = node(),
+ case node(P) of
+ Node ->
+ process_info(P);
+ _ ->
+ rpc:call(node(P),erlang,process_info,[P])
+ end.
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% Support functions for COVER %%
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%%
+%% A module is included in the cover analysis if
+%% - it belongs to the tested application and is not listed in the
+%% {exclude,List} part of the App.cover file
+%% - it does not belong to the application, but is listed in the
+%% {include,List} part of the App.cover file
+%% - it does not belong to the application, but is listed in the
+%% {cross,[{Tag,List}]} part of the App.cover file
+%%
+%% The modules listed in the 'cross' part of the cover file are
+%% modules that are heavily used by other tests than the one where
+%% they are explicitly tested. They should then be listed as 'cross'
+%% in the cover file for the test where they are used but do not
+%% belong.
+%%
+%% After all tests are completed, the these modules can be analysed
+%% with coverage data from all tests where they are compiled - see
+%% cross_cover_analyse/2. The result is stored in a file called
+%% cross_cover.html in the run.<timestamp> directory of the
+%% test the modules belong to.
+%%
+%% Example:
+%% If the module m1 belongs to system s1 but is heavily used also in
+%% the tests for another system s2, then the cover files for the two
+%% systems could be like this:
+%%
+%% s1.cover:
+%% {include,[m1]}.
+%%
+%% s2.cover:
+%% {include,[....]}. % modules belonging to system s2
+%% {cross,[{s1,[m1]}]}.
+%%
+%% When the tests for both s1 and s2 are completed, run
+%% cross_cover_analyse(Level,[{s1,S1LogDir},{s2,S2LogDir}]), and
+%% the accumulated cover data for m1 will be written to
+%% S1LogDir/[run.<timestamp>/]cross_cover.html
+%%
+%% S1LogDir and S2LogDir are either the run.<timestamp> directories
+%% for the two tests, or the parent directory of these, in which case
+%% the latest run.<timestamp> directory will be chosen.
+%%
+%% Note that the m1 module will also be presented in the normal
+%% coverage log for s1 (due to the include statement in s1.cover), but
+%% that only includes the coverage achieved by the s1 test itself.
+%%
+%% The Tag in the 'cross' statement in the cover file has no other
+%% purpose than mapping the list of modules ([m1] in the example
+%% above) to the correct log directory where it should be included in
+%% the cross_cover.html file (S1LogDir in the example above).
+%% I.e. the value of the Tag has no meaning, it could be foo as well
+%% as s1 above, as long as the same Tag is used in the cover file and
+%% in the call to cross_cover_analyse/2.
+
+
+%% Cover compilation
+%% The compilation is executed on the target node
+start_cover(#cover{}=CoverInfo) ->
+ cover_compile(CoverInfo);
+start_cover({log,CoverLogDir}=CoverInfo) ->
+ %% Cover is controlled by the framework - here's the log
+ put(test_server_cover_log_dir,CoverLogDir),
+ {ok,CoverInfo}.
+
+cover_compile(CoverInfo) ->
+ test_server:cover_compile(CoverInfo).
+
+%% Read the coverfile for an application and return a list of modules
+%% that are members of the application but shall not be compiled
+%% (Exclude), and a list of modules that are not members of the
+%% application but shall be compiled (Include).
+read_cover_file(none) ->
+ {[],[],[]};
+read_cover_file(CoverFile) ->
+ case file:consult(CoverFile) of
+ {ok,List} ->
+ case check_cover_file(List, [], [], []) of
+ {ok,Exclude,Include,Cross} -> {Exclude,Include,Cross};
+ error ->
+ io:fwrite("Faulty format of CoverFile ~p\n", [CoverFile]),
+ {[],[],[]}
+ end;
+ {error,Reason} ->
+ io:fwrite("Can't read CoverFile ~ts\nReason: ~p\n",
+ [CoverFile,Reason]),
+ {[],[],[]}
+ end.
+
+check_cover_file([{exclude,all}|Rest], _, Include, Cross) ->
+ check_cover_file(Rest, all, Include, Cross);
+check_cover_file([{exclude,Exclude}|Rest], _, Include, Cross) ->
+ case lists:all(fun(M) -> is_atom(M) end, Exclude) of
+ true ->
+ check_cover_file(Rest, Exclude, Include, Cross);
+ false ->
+ error
+ end;
+check_cover_file([{include,Include}|Rest], Exclude, _, Cross) ->
+ case lists:all(fun(M) -> is_atom(M) end, Include) of
+ true ->
+ check_cover_file(Rest, Exclude, Include, Cross);
+ false ->
+ error
+ end;
+check_cover_file([{cross,Cross}|Rest], Exclude, Include, _) ->
+ case check_cross(Cross) of
+ true ->
+ check_cover_file(Rest, Exclude, Include, Cross);
+ false ->
+ error
+ end;
+check_cover_file([], Exclude, Include, Cross) ->
+ {ok,Exclude,Include,Cross}.
+
+check_cross([{Tag,Modules}|Rest]) ->
+ case lists:all(fun(M) -> is_atom(M) end, [Tag|Modules]) of
+ true ->
+ check_cross(Rest);
+ false ->
+ false
+ end;
+check_cross([]) ->
+ true.
+
+
+%% Cover analysis, per application
+%% This analysis is executed on the target node once the test is
+%% completed for an application. This is not the same as the cross
+%% cover analysis, which can be executed on any node after the tests
+%% are finshed.
+%%
+%% This per application analysis writes the file cover.html in the
+%% application's run.<timestamp> directory.
+stop_cover(#cover{}=CoverInfo, TestDir) ->
+ cover_analyse(CoverInfo, TestDir);
+stop_cover(_CoverInfo, _TestDir) ->
+ %% Cover is probably controlled by the framework
+ ok.
+
+make_relative(AbsDir, VsDir) ->
+ DirTokens = filename:split(AbsDir),
+ VsTokens = filename:split(VsDir),
+ filename:join(make_relative1(DirTokens, VsTokens)).
+
+make_relative1([T | DirTs], [T | VsTs]) ->
+ make_relative1(DirTs, VsTs);
+make_relative1(Last = [_File], []) ->
+ Last;
+make_relative1(Last = [_File], VsTs) ->
+ Ups = ["../" || _ <- VsTs],
+ Ups ++ Last;
+make_relative1(DirTs, []) ->
+ DirTs;
+make_relative1(DirTs, VsTs) ->
+ Ups = ["../" || _ <- VsTs],
+ Ups ++ DirTs.
+
+
+cover_analyse(CoverInfo, TestDir) ->
+ write_default_cross_coverlog(TestDir),
+
+ {ok,CoverLog} = open_html_file(filename:join(TestDir, ?coverlog_name)),
+ write_coverlog_header(CoverLog),
+ #cover{app=App,
+ file=CoverFile,
+ excl=Excluded,
+ cross=Cross} = CoverInfo,
+ io:fwrite(CoverLog, "<h1>Coverage for application '~w'</h1>\n", [App]),
+ io:fwrite(CoverLog,
+ "<p><a href=\"~ts\">Coverdata collected over all tests</a></p>",
+ [?cross_coverlog_name]),
+
+ io:fwrite(CoverLog, "<p>CoverFile: <code>~tp</code>\n", [CoverFile]),
+ write_cross_cover_info(TestDir,Cross),
+
+ case length(cover:imported_modules()) of
+ Imps when Imps > 0 ->
+ io:fwrite(CoverLog,
+ "<p>Analysis includes data from ~w imported module(s).\n",
+ [Imps]);
+ _ ->
+ ok
+ end,
+
+ io:fwrite(CoverLog, "<p>Excluded module(s): <code>~tp</code>\n", [Excluded]),
+
+ Coverage = test_server:cover_analyse(TestDir, CoverInfo),
+ write_binary_file(filename:join(TestDir,?raw_coverlog_name),
+ term_to_binary(Coverage)),
+
+ case lists:filter(fun({_M,{_,_,_}}) -> false;
+ (_) -> true
+ end, Coverage) of
+ [] ->
+ ok;
+ Bad ->
+ io:fwrite(CoverLog, "<p>Analysis failed for ~w module(s): "
+ "<code>~w</code>\n",
+ [length(Bad),[BadM || {BadM,{_,_Why}} <- Bad]])
+ end,
+
+ TotPercent = write_cover_result_table(CoverLog, Coverage),
+ write_binary_file(filename:join(TestDir, ?cover_total),
+ term_to_binary(TotPercent)).
+
+%% Cover analysis - accumulated over multiple tests
+%% This can be executed on any node after all tests are finished.
+%% Analyse = overview | details
+%% TagDirs = [{Tag,Dir}]
+%% Tag = atom(), identifier
+%% Dir = string(), the log directory for Tag, it can be a
+%% run.<timestamp> directory or the parent directory of
+%% such (in which case the latest run.<timestamp> directory
+%% is used)
+cross_cover_analyse(Analyse, TagDirs0) ->
+ TagDirs = get_latest_run_dirs(TagDirs0),
+ TagMods = get_all_cross_info(TagDirs,[]),
+ TagDirMods = add_cross_modules(TagMods,TagDirs),
+ CoverdataFiles = get_coverdata_files(TagDirMods),
+ lists:foreach(fun(CDF) -> cover:import(CDF) end, CoverdataFiles),
+ io:fwrite("Cover analysing...\n", []),
+ DetailsFun =
+ case Analyse of
+ details ->
+ fun(Dir,M) ->
+ OutFile = filename:join(Dir,
+ atom_to_list(M) ++
+ ".CROSS_COVER.html"),
+ case cover:analyse_to_file(M, OutFile, [html]) of
+ {ok,_} ->
+ {file,OutFile};
+ Error ->
+ Error
+ end
+ end;
+ _ ->
+ fun(_,_) -> undefined end
+ end,
+ Coverage = analyse_tests(TagDirMods, DetailsFun, []),
+ cover:stop(),
+ write_cross_cover_logs(Coverage,TagDirMods).
+
+write_cross_cover_info(_Dir,[]) ->
+ ok;
+write_cross_cover_info(Dir,Cross) ->
+ write_binary_file(filename:join(Dir,?cross_cover_info),
+ term_to_binary(Cross)).
+
+%% For each test from which there are cross cover analysed
+%% modules, write a cross cover log (cross_cover.html).
+write_cross_cover_logs([{Tag,Coverage}|T],TagDirMods) ->
+ case lists:keyfind(Tag,1,TagDirMods) of
+ {_,Dir,Mods} when Mods=/=[] ->
+ write_binary_file(filename:join(Dir,?raw_cross_coverlog_name),
+ term_to_binary(Coverage)),
+ CoverLogName = filename:join(Dir,?cross_coverlog_name),
+ {ok,CoverLog} = open_html_file(CoverLogName),
+ write_coverlog_header(CoverLog),
+ io:fwrite(CoverLog,
+ "<h1>Coverage results for \'~w\' from all tests</h1>\n",
+ [Tag]),
+ write_cover_result_table(CoverLog, Coverage),
+ io:fwrite("Written file ~tp\n", [CoverLogName]);
+ _ ->
+ ok
+ end,
+ write_cross_cover_logs(T,TagDirMods);
+write_cross_cover_logs([],_) ->
+ io:fwrite("done\n", []).
+
+%% Get the latest run.<timestamp> directories
+get_latest_run_dirs([{Tag,Dir}|Rest]) ->
+ [{Tag,get_latest_run_dir(Dir)} | get_latest_run_dirs(Rest)];
+get_latest_run_dirs([]) ->
+ [].
+
+get_latest_run_dir(Dir) ->
+ case filelib:wildcard(filename:join(Dir,"run.[1-2]*")) of
+ [] ->
+ Dir;
+ [H|T] ->
+ get_latest_dir(T,H)
+ end.
+
+get_latest_dir([H|T],Latest) when H>Latest ->
+ get_latest_dir(T,H);
+get_latest_dir([_|T],Latest) ->
+ get_latest_dir(T,Latest);
+get_latest_dir([],Latest) ->
+ Latest.
+
+get_all_cross_info([{_Tag,Dir}|Rest],Acc) ->
+ case file:read_file(filename:join(Dir,?cross_cover_info)) of
+ {ok,Bin} ->
+ TagMods = binary_to_term(Bin),
+ get_all_cross_info(Rest,TagMods++Acc);
+ _ ->
+ get_all_cross_info(Rest,Acc)
+ end;
+get_all_cross_info([],Acc) ->
+ Acc.
+
+%% Associate the cross cover modules with their log directories
+add_cross_modules(TagMods,TagDirs)->
+ do_add_cross_modules(TagMods,[{Tag,Dir,[]} || {Tag,Dir} <- TagDirs]).
+do_add_cross_modules([{Tag,Mods1}|TagMods],TagDirMods)->
+ NewTagDirMods =
+ case lists:keytake(Tag,1,TagDirMods) of
+ {value,{Tag,Dir,Mods},Rest} ->
+ [{Tag,Dir,lists:umerge(lists:sort(Mods1),Mods)}|Rest];
+ false ->
+ TagDirMods
+ end,
+ do_add_cross_modules(TagMods,NewTagDirMods);
+do_add_cross_modules([],TagDirMods) ->
+ %% Just to get the modules in the same order as in the normal cover log
+ [{Tag,Dir,lists:reverse(Mods)} || {Tag,Dir,Mods} <- TagDirMods].
+
+%% Find all exported coverdata files.
+get_coverdata_files(TagDirMods) ->
+ lists:flatmap(
+ fun({_,LatestDir,_}) ->
+ filelib:wildcard(filename:join(LatestDir,"all.coverdata"))
+ end,
+ TagDirMods).
+
+
+%% For each test, analyse all modules
+%% Used for cross cover analysis.
+analyse_tests([{Tag,LastTest,Modules}|T], DetailsFun, Acc) ->
+ Cov = analyse_modules(LastTest, Modules, DetailsFun, []),
+ analyse_tests(T, DetailsFun, [{Tag,Cov}|Acc]);
+analyse_tests([], _DetailsFun, Acc) ->
+ Acc.
+
+%% Analyse each module
+%% Used for cross cover analysis.
+analyse_modules(Dir, [M|Modules], DetailsFun, Acc) ->
+ {ok,{M,{Cov,NotCov}}} = cover:analyse(M, module),
+ Acc1 = [{M,{Cov,NotCov,DetailsFun(Dir,M)}}|Acc],
+ analyse_modules(Dir, Modules, DetailsFun, Acc1);
+analyse_modules(_Dir, [], _DetailsFun, Acc) ->
+ Acc.
+
+
+%% Support functions for writing the cover logs (both cross and normal)
+write_coverlog_header(CoverLog) ->
+ case catch io:put_chars(CoverLog,html_header("Coverage results")) of
+ {'EXIT',Reason} ->
+ io:format("\n\nERROR: Could not write normal heading in coverlog.\n"
+ "CoverLog: ~w\n"
+ "Reason: ~p\n",
+ [CoverLog,Reason]),
+ io:format(CoverLog,"<html><body>\n", []);
+ _ ->
+ ok
+ end.
+
+
+format_analyse(M,Cov,NotCov,undefined) ->
+ io_lib:fwrite("<tr><td>~w</td>"
+ "<td align=right>~w %</td>"
+ "<td align=right>~w</td>"
+ "<td align=right>~w</td></tr>\n",
+ [M,pc(Cov,NotCov),Cov,NotCov]);
+format_analyse(M,Cov,NotCov,{file,File}) ->
+ io_lib:fwrite("<tr><td><a href=\"~ts\">~w</a></td>"
+ "<td align=right>~w %</td>"
+ "<td align=right>~w</td>"
+ "<td align=right>~w</td></tr>\n",
+ [uri_encode(filename:basename(File)),
+ M,pc(Cov,NotCov),Cov,NotCov]);
+format_analyse(M,Cov,NotCov,{lines,Lines}) ->
+ CoverOutName = atom_to_list(M)++".COVER.html",
+ {ok,CoverOut} = open_html_file(CoverOutName),
+ write_not_covered(CoverOut,M,Lines),
+ ok = file:close(CoverOut),
+ io_lib:fwrite("<tr><td><a href=\"~ts\">~w</a></td>"
+ "<td align=right>~w %</td>"
+ "<td align=right>~w</td>"
+ "<td align=right>~w</td></tr>\n",
+ [uri_encode(CoverOutName),M,pc(Cov,NotCov),Cov,NotCov]);
+format_analyse(M,Cov,NotCov,{error,_}) ->
+ io_lib:fwrite("<tr><td>~w</td>"
+ "<td align=right>~w %</td>"
+ "<td align=right>~w</td>"
+ "<td align=right>~w</td></tr>\n",
+ [M,pc(Cov,NotCov),Cov,NotCov]).
+
+
+pc(0,0) ->
+ 0;
+pc(Cov,NotCov) ->
+ round(Cov/(Cov+NotCov)*100).
+
+
+write_not_covered(CoverOut,M,Lines) ->
+ io:put_chars(CoverOut,html_header("Coverage results for "++atom_to_list(M))),
+ io:fwrite(CoverOut,
+ "The following lines in module ~w are not covered:\n"
+ "<table border=3 cellpadding=5>\n"
+ "<th>Line Number</th>\n",
+ [M]),
+ lists:foreach(fun({{_M,Line},{0,1}}) ->
+ io:fwrite(CoverOut,"<tr><td>~w</td></tr>\n", [Line]);
+ (_) ->
+ ok
+ end,
+ Lines),
+ io:put_chars(CoverOut,"</table>\n</body>\n</html>\n").
+
+
+write_default_coverlog(TestDir) ->
+ {ok,CoverLog} = open_html_file(filename:join(TestDir,?coverlog_name)),
+ write_coverlog_header(CoverLog),
+ io:put_chars(CoverLog,"Cover tool is not used\n</body></html>\n"),
+ ok = file:close(CoverLog).
+
+write_default_cross_coverlog(TestDir) ->
+ {ok,CrossCoverLog} =
+ open_html_file(filename:join(TestDir,?cross_coverlog_name)),
+ write_coverlog_header(CrossCoverLog),
+ io:put_chars(CrossCoverLog,
+ ["No cross cover modules exist for this application,",
+ xhtml("<br>","<br />"),
+ "or cross cover analysis is not completed.\n"
+ "</body></html>\n"]),
+ ok = file:close(CrossCoverLog).
+
+write_cover_result_table(CoverLog,Coverage) ->
+ io:fwrite(CoverLog,
+ "<p><table border=3 cellpadding=5>\n"
+ "<tr><th>Module</th><th>Covered (%)</th><th>Covered (Lines)</th>"
+ "<th>Not covered (Lines)</th>\n",
+ []),
+ {TotCov,TotNotCov} =
+ lists:foldl(fun({M,{Cov,NotCov,Details}},{AccCov,AccNotCov}) ->
+ Str = format_analyse(M,Cov,NotCov,Details),
+ io:fwrite(CoverLog,"~ts", [Str]),
+ {AccCov+Cov,AccNotCov+NotCov};
+ ({_M,{error,_Reason}},{AccCov,AccNotCov}) ->
+ {AccCov,AccNotCov}
+ end,
+ {0,0},
+ Coverage),
+ TotPercent = pc(TotCov,TotNotCov),
+ io:fwrite(CoverLog,
+ "<tr><th align=left>Total</th><th align=right>~w %</th>"
+ "<th align=right>~w</th><th align=right>~w</th></tr>\n"
+ "</table>\n"
+ "</body>\n"
+ "</html>\n",
+ [TotPercent,TotCov,TotNotCov]),
+ ok = file:close(CoverLog),
+ TotPercent.
+
+
+%%%-----------------------------------------------------------------
+%%% Support functions for writing files
+
+%% HTML files are always written with utf8 encoding
+html_header(Title) ->
+ ["<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 3.2 Final//EN\">\n"
+ "<!-- autogenerated by '", atom_to_list(?MODULE), "'. -->\n"
+ "<html>\n"
+ "<head>\n"
+ "<title>", Title, "</title>\n"
+ "<meta http-equiv=\"cache-control\" content=\"no-cache\"></meta>\n"
+ "<meta http-equiv=\"content-type\" content=\"text/html; "
+ "charset=utf-8\"></meta>\n"
+ "</head>\n"
+ "<body bgcolor=\"white\" text=\"black\" "
+ "link=\"blue\" vlink=\"purple\" alink=\"red\">\n"].
+
+open_html_file(File) ->
+ open_utf8_file(File).
+
+open_html_file(File,Opts) ->
+ open_utf8_file(File,Opts).
+
+write_html_file(File,Content) ->
+ write_file(File,Content,utf8).
+
+%% The 'major' log file, which is a pure text file is also written
+%% with utf8 encoding
+open_utf8_file(File) ->
+ case file:open(File,AllOpts=[write,{encoding,utf8}]) of
+ {error,Reason} -> {error,{Reason,{File,AllOpts}}};
+ Result -> Result
+ end.
+
+open_utf8_file(File,Opts) ->
+ case file:open(File,AllOpts=[{encoding,utf8}|Opts]) of
+ {error,Reason} -> {error,{Reason,{File,AllOpts}}};
+ Result -> Result
+ end.
+
+%% Write a file with specified encoding
+write_file(File,Content,latin1) ->
+ file:write_file(File,Content);
+write_file(File,Content,utf8) ->
+ write_binary_file(File,unicode:characters_to_binary(Content)).
+
+%% Write a file with only binary data
+write_binary_file(File,Content) ->
+ file:write_file(File,Content).
+
+%% Encoding of hyperlinks in HTML files
+uri_encode(File) ->
+ Encoding = file:native_name_encoding(),
+ uri_encode(File,Encoding).
+
+uri_encode(File,Encoding) ->
+ Components = filename:split(File),
+ filename:join([uri_encode_comp(C,Encoding) || C <- Components]).
+
+%% Encode the reference to a "filename of the given encoding" so it
+%% can be inserted in a utf8 encoded HTML file.
+%% This does almost the same as http_uri:encode/1, except
+%% 1. it does not convert @, : and / (in order to preserve nodename and c:/)
+%% 2. if the file name is in latin1, it also encodes all
+%% characters >127 - i.e. latin1 but not ASCII.
+uri_encode_comp([Char|Chars],Encoding) ->
+ Reserved = sets:is_element(Char, reserved()),
+ case (Char>127 andalso Encoding==latin1) orelse Reserved of
+ true ->
+ [ $% | http_util:integer_to_hexlist(Char)] ++
+ uri_encode_comp(Chars,Encoding);
+ false ->
+ [Char | uri_encode_comp(Chars,Encoding)]
+ end;
+uri_encode_comp([],_) ->
+ [].
+
+%% Copied from http_uri.erl, but slightly modified
+%% (not converting @, : and /)
+reserved() ->
+ sets:from_list([$;, $&, $=, $+, $,, $?,
+ $#, $[, $], $<, $>, $\", ${, $}, $|,
+ $\\, $', $^, $%, $ ]).
+
+encoding(File) ->
+ case epp:read_encoding(File) of
+ none ->
+ epp:default_encoding();
+ E ->
+ E
+ end.
diff --git a/lib/common_test/src/test_server_gl.erl b/lib/common_test/src/test_server_gl.erl
new file mode 100644
index 0000000000..233e59172b
--- /dev/null
+++ b/lib/common_test/src/test_server_gl.erl
@@ -0,0 +1,350 @@
+%%
+%% %CopyrightBegin%
+%%
+%% Copyright Ericsson AB 2012-2015. All Rights Reserved.
+%%
+%% Licensed under the Apache License, Version 2.0 (the "License");
+%% you may not use this file except in compliance with the License.
+%% You may obtain a copy of the License at
+%%
+%% http://www.apache.org/licenses/LICENSE-2.0
+%%
+%% Unless required by applicable law or agreed to in writing, software
+%% distributed under the License is distributed on an "AS IS" BASIS,
+%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+%% See the License for the specific language governing permissions and
+%% limitations under the License.
+%%
+%% %CopyrightEnd%
+%%
+%% This module implements group leader processes for test cases.
+%% Each group leader process handles output to the minor log file for
+%% a test case, and calls test_server_io to handle output to the common
+%% log files. The group leader processes are created and destroyed
+%% through the test_server_io module/process.
+
+-module(test_server_gl).
+-export([start_link/0,stop/1,set_minor_fd/3,unset_minor_fd/1,
+ get_tc_supervisor/1,print/4,set_props/2]).
+
+-export([init/1,handle_call/3,handle_cast/2,handle_info/2,terminate/2]).
+
+-record(st, {tc_supervisor :: 'none'|pid(), %Test case supervisor
+ tc :: mfa() | 'undefined', %Current test case MFA
+ minor :: 'none'|pid(), %Minor fd
+ minor_monitor, %Monitor ref for minor fd
+ capture :: 'none'|pid(), %Capture output
+ reject_io :: boolean(), %Reject I/O requests...
+ permit_io, %... and exceptions
+ auto_nl=true :: boolean(), %Automatically add NL
+ levels, %{Stdout,Major,Minor}
+ escape_chars=true %Switch escaping HTML on/off
+ }).
+
+%% start_link()
+%% Start a new group leader process. Only to be called by
+%% the test_server_io process.
+
+start_link() ->
+ case gen_server:start_link(?MODULE, [], []) of
+ {ok,Pid} ->
+ {ok,Pid};
+ Other ->
+ Other
+ end.
+
+
+%% stop(Pid)
+%% Stop a group leader process. Only to be called by
+%% the test_server_io process.
+
+stop(GL) ->
+ gen_server:cast(GL, stop).
+
+
+%% set_minor_fd(GL, Fd, MFA)
+%% GL = Pid for the group leader process
+%% Fd = file descriptor for the minor log file
+%% MFA = {M,F,A} for the test case owning the minor log file
+%%
+%% Register the file descriptor for the minor log file. Subsequent
+%% IO directed to the minor log file will be written to this file.
+%% Also register the currently executing process at the testcase
+%% supervisor corresponding to this group leader process.
+
+set_minor_fd(GL, Fd, MFA) ->
+ req(GL, {set_minor_fd,Fd,MFA,self()}).
+
+
+%% unset_minor_fd(GL, Fd, MFA)
+%% GL = Pid for the group leader process
+%%
+%% Unregister the file descriptor for minor log file (typically
+%% because the test case has ended the minor log file is about
+%% to be closed). Subsequent IO (for example, by a process spawned
+%% by the testcase process) will go to the unexpected_io log file.
+
+unset_minor_fd(GL) ->
+ req(GL, unset_minor_fd).
+
+
+%% get_tc_supervisor(GL)
+%% GL = Pid for the group leader process
+%%
+%% Return the Pid for the process that supervises the test case
+%% that has this group leader.
+
+get_tc_supervisor(GL) ->
+ req(GL, get_tc_supervisor).
+
+
+%% print(GL, Detail, Format, Args) -> ok
+%% GL = Pid for the group leader process
+%% Detail = integer() | minor | major | html | stdout
+%% Msg = iodata()
+%% Printer = internal | pid()
+%%
+%% Print a message to one of the log files. If Detail is an integer,
+%% it will be compared to the levels (set by set_props/2) to
+%% determine which log file(s) that are to receive the output. If
+%% Detail is an atom, the value of the atom will directly determine
+%% which log file to use. IO to the minor log file will be handled
+%% directly by this group leader process (printing to the file set by
+%% set_minor_fd/3), and all other IO will be handled by calling
+%% test_server_io:print/3.
+
+print(GL, Detail, Msg, Printer) ->
+ req(GL, {print,Detail,Msg,Printer}).
+
+
+%% set_props(GL, [PropertyTuple])
+%% GL = Pid for the group leader process
+%% PropertyTuple = {levels,{Show,Major,Minor}} |
+%% {auto_nl,boolean()} |
+%% {reject_io_reqs,boolean()}
+%%
+%% Set properties for this group leader process.
+
+set_props(GL, PropList) ->
+ req(GL, {set_props,PropList}).
+
+%%% Internal functions.
+
+init([]) ->
+ {ok,#st{tc_supervisor=none,
+ minor=none,
+ minor_monitor=none,
+ capture=none,
+ reject_io=false,
+ permit_io=gb_sets:empty(),
+ auto_nl=true,
+ levels={1,19,10},
+ escape_chars=true
+ }}.
+
+req(GL, Req) ->
+ gen_server:call(GL, Req, infinity).
+
+handle_call(get_tc_supervisor, _From, #st{tc_supervisor=Pid}=St) ->
+ {reply,Pid,St};
+handle_call({set_minor_fd,Fd,MFA,Supervisor}, _From, St) ->
+ Ref = erlang:monitor(process, Fd),
+ {reply,ok,St#st{tc=MFA,minor=Fd,minor_monitor=Ref,
+ tc_supervisor=Supervisor}};
+handle_call(unset_minor_fd, _From, St) ->
+ {reply,ok,St#st{minor=none,tc_supervisor=none}};
+handle_call({set_props,PropList}, _From, St) ->
+ {reply,ok,do_set_props(PropList, St)};
+handle_call({print,Detail,Msg,Printer}, {From,_}, St) ->
+ output(Detail, Msg, Printer, From, St),
+ {reply,ok,St}.
+
+handle_cast(stop, St) ->
+ {stop,normal,St}.
+
+handle_info({'DOWN',Ref,process,_,Reason}=D, #st{minor_monitor=Ref}=St) ->
+ case Reason of
+ normal -> ok;
+ _ ->
+ Data = io_lib:format("=== WARNING === TC: ~w\n"
+ "Got down from minor Fd ~w: ~w\n\n",
+ [St#st.tc,St#st.minor,D]),
+ test_server_io:print_unexpected(Data)
+ end,
+ {noreply,St#st{minor=none,minor_monitor=none}};
+handle_info({permit_io,Pid}, #st{permit_io=P}=St) ->
+ {noreply,St#st{permit_io=gb_sets:add(Pid, P)}};
+handle_info({capture,Cap0}, St) ->
+ Cap = case Cap0 of
+ false -> none;
+ Pid when is_pid(Cap0) -> Pid
+ end,
+ {noreply,St#st{capture=Cap}};
+handle_info({io_request,From,ReplyAs,Req}=IoReq, St) ->
+ try io_req(Req, From, St) of
+ passthrough ->
+ group_leader() ! IoReq;
+ {EscapeHtml,Data} ->
+ case is_io_permitted(From, St) of
+ false ->
+ ok;
+ true ->
+ case St of
+ #st{capture=none} ->
+ ok;
+ #st{capture=CapturePid} ->
+ CapturePid ! {captured,Data}
+ end,
+ case EscapeHtml andalso St#st.escape_chars of
+ true ->
+ output(minor, test_server_ctrl:escape_chars(Data),
+ From, From, St);
+ false ->
+ output(minor, Data, From, From, St)
+ end
+ end,
+ From ! {io_reply,ReplyAs,ok}
+ catch
+ _:_ ->
+ From ! {io_reply,ReplyAs,{error,arguments}}
+ end,
+ {noreply,St};
+handle_info({structured_io,ClientPid,{Detail,Str}}, St) ->
+ output(Detail, Str, ClientPid, ClientPid, St),
+ {noreply,St};
+handle_info({printout,Detail,["$tc_html",Format],Args}, St) ->
+ Str = io_lib:format(Format, Args),
+ output(Detail, ["$tc_html",Str], internal, none, St),
+ {noreply,St};
+handle_info({printout,Detail,Fun}, St) when is_function(Fun)->
+ output(Detail, Fun, internal, none, St),
+ {noreply,St};
+handle_info({printout,Detail,Format,Args}, St) ->
+ Str = io_lib:format(Format, Args),
+ if not St#st.escape_chars ->
+ output(Detail, ["$tc_html",Str], internal, none, St);
+ true ->
+ output(Detail, Str, internal, none, St)
+ end,
+ {noreply,St};
+handle_info(Msg, #st{tc_supervisor=Pid}=St) when is_pid(Pid) ->
+ %% The process overseeing the testcase process also used to be
+ %% the group leader; thus, it is widely expected that it can be
+ %% reached by sending a message to the group leader. Therefore
+ %% we'll need to forward any non-recognized messaged to the test
+ %% case supervisor.
+ Pid ! Msg,
+ {noreply,St};
+handle_info(_Msg, #st{}=St) ->
+ %% There is no known supervisor process. Ignore this message.
+ {noreply,St}.
+
+terminate(_, _) ->
+ ok.
+
+do_set_props([{levels,Levels}|Ps], St) ->
+ do_set_props(Ps, St#st{levels=Levels});
+do_set_props([{auto_nl,AutoNL}|Ps], St) ->
+ do_set_props(Ps, St#st{auto_nl=AutoNL});
+do_set_props([{reject_io_reqs,Bool}|Ps], St) ->
+ do_set_props(Ps, St#st{reject_io=Bool});
+do_set_props([], St) -> St.
+
+io_req({put_chars,Enc,Str}, _, _) when Enc =:= latin1; Enc =:= unicode ->
+ case Str of
+ ["$tc_html",Str0] ->
+ {false,unicode:characters_to_list(Str0, Enc)};
+ _ ->
+ {true,unicode:characters_to_list(Str, Enc)}
+ end;
+io_req({put_chars,Encoding,Mod,Func,[Format,Args]}, _, _) ->
+ case Format of
+ ["$tc_html",Format0] ->
+ Str = Mod:Func(Format0, Args),
+ {false,unicode:characters_to_list(Str, Encoding)};
+ _ ->
+ Str = Mod:Func(Format, Args),
+ {true,unicode:characters_to_list(Str, Encoding)}
+ end;
+io_req(_, _, _) -> passthrough.
+
+output(Level, StrOrFun, Sender, From, St) when is_integer(Level) ->
+ case selected_by_level(Level, stdout, St) of
+ true when hd(StrOrFun) == "$tc_html" ->
+ output(stdout, tl(StrOrFun), Sender, From, St);
+ true when is_function(StrOrFun) ->
+ output(stdout, StrOrFun(stdout), Sender, From, St);
+ true ->
+ output(stdout, StrOrFun, Sender, From, St);
+ false ->
+ ok
+ end,
+ case selected_by_level(Level, major, St) of
+ true when hd(StrOrFun) == "$tc_html" ->
+ output(major, tl(StrOrFun), Sender, From, St);
+ true when is_function(StrOrFun) ->
+ output(major, StrOrFun(major), Sender, From, St);
+ true ->
+ output(major, StrOrFun, Sender, From, St);
+ false ->
+ ok
+ end,
+ case selected_by_level(Level, minor, St) of
+ true when hd(StrOrFun) == "$tc_html" ->
+ output(minor, tl(StrOrFun), Sender, From, St);
+ true when is_function(StrOrFun) ->
+ output(minor, StrOrFun(minor), Sender, From, St);
+ true ->
+ output(minor, test_server_ctrl:escape_chars(StrOrFun),
+ Sender, From, St);
+ false ->
+ ok
+ end;
+output(stdout, Str, _Sender, From, St) ->
+ output_to_file(stdout, Str, From, St);
+output(html, Str, _Sender, From, St) ->
+ output_to_file(html, Str, From, St);
+output(Level, Str, Sender, From, St) when is_atom(Level) ->
+ output_to_file(Level, dress_output(Str, Sender, St), From, St).
+
+output_to_file(minor, Data0, From, #st{tc={M,F,A},minor=none}) ->
+ Data = [io_lib:format("=== ~w:~w/~w\n", [M,F,A]),Data0],
+ test_server_io:print(From, unexpected_io, Data),
+ ok;
+output_to_file(minor, Data, From, #st{tc=TC,minor=Fd}) ->
+ try
+ io:put_chars(Fd, Data)
+ catch
+ Type:Reason ->
+ Data1 =
+ [io_lib:format("=== ERROR === TC: ~w\n"
+ "Failed to write to minor Fd: ~w\n"
+ "Type: ~w\n"
+ "Reason: ~w\n",
+ [TC,Fd,Type,Reason]),
+ Data,"\n"],
+ test_server_io:print(From, unexpected_io, Data1)
+ end;
+output_to_file(Detail, Data, From, _) ->
+ test_server_io:print(From, Detail, Data).
+
+is_io_permitted(From, #st{reject_io=true,permit_io=P}) ->
+ gb_sets:is_member(From, P);
+is_io_permitted(_, #st{reject_io=false}) -> true.
+
+selected_by_level(Level, stdout, #st{levels={Stdout,_,_}}) ->
+ Level =< Stdout;
+selected_by_level(Level, major, #st{levels={_,Major,_}}) ->
+ Level =< Major;
+selected_by_level(Level, minor, #st{levels={_,_,Minor}}) ->
+ Level >= Minor.
+
+dress_output([$=|_]=Str, internal, _) ->
+ [Str,$\n];
+dress_output(Str, internal, _) ->
+ ["=== ",Str,$\n];
+dress_output(Str, _, #st{auto_nl=AutoNL}) ->
+ case AutoNL of
+ true -> [Str,$\n];
+ false -> Str
+ end.
diff --git a/lib/common_test/src/test_server_internal.hrl b/lib/common_test/src/test_server_internal.hrl
new file mode 100644
index 0000000000..1ec2d83417
--- /dev/null
+++ b/lib/common_test/src/test_server_internal.hrl
@@ -0,0 +1,60 @@
+%%
+%% %CopyrightBegin%
+%%
+%% Copyright Ericsson AB 2002-2013. All Rights Reserved.
+%%
+%% Licensed under the Apache License, Version 2.0 (the "License");
+%% you may not use this file except in compliance with the License.
+%% You may obtain a copy of the License at
+%%
+%% http://www.apache.org/licenses/LICENSE-2.0
+%%
+%% Unless required by applicable law or agreed to in writing, software
+%% distributed under the License is distributed on an "AS IS" BASIS,
+%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+%% See the License for the specific language governing permissions and
+%% limitations under the License.
+%%
+%% %CopyrightEnd%
+%%
+
+-define(priv_dir,"log_private").
+-define(MAIN_PORT,3289).
+-define(ACCEPT_TIMEOUT,20000).
+
+%% Target information generated by test_server:init_target_info/0
+%% Once initiated, this information will never change!!
+-record(target_info, {os_family, % atom(); win32 | unix
+ os_type, % result of os:type()
+ host, % string(); the name of the target machine
+ version, % string()
+ system_version, % string()
+ root_dir, % string()
+ emulator, % string()
+ otp_release, % string()
+ username, % string()
+ cookie, % string(); Cookie for target node
+ naming, % string(); "-name" | "-sname"
+ master}). % string(); Was used for OSE's master
+ % node for main target and slave nodes.
+ % For other platforms the target node
+ % itself is master for slave nodes
+
+%% Temporary information generated by test_server_ctrl:read_parameters/X
+%% This information is used when starting the main target, and for
+%% initiating the #target_info record.
+-record(par, {type,
+ target,
+ naming,
+ master,
+ cookie}).
+
+
+-record(cover, {app, % application; Name | none
+ file, % cover spec file
+ incl, % explicitly include modules
+ excl, % explicitly exclude modules
+ level, % analyse level; details | overview
+ mods, % actually cover compiled modules
+ stop=true, % stop cover after analyse; boolean()
+ cross}).% cross cover analyse info
diff --git a/lib/common_test/src/test_server_io.erl b/lib/common_test/src/test_server_io.erl
new file mode 100644
index 0000000000..0d881d0ada
--- /dev/null
+++ b/lib/common_test/src/test_server_io.erl
@@ -0,0 +1,452 @@
+%%
+%% %CopyrightBegin%
+%%
+%% Copyright Ericsson AB 2012-2013. All Rights Reserved.
+%%
+%% Licensed under the Apache License, Version 2.0 (the "License");
+%% you may not use this file except in compliance with the License.
+%% You may obtain a copy of the License at
+%%
+%% http://www.apache.org/licenses/LICENSE-2.0
+%%
+%% Unless required by applicable law or agreed to in writing, software
+%% distributed under the License is distributed on an "AS IS" BASIS,
+%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+%% See the License for the specific language governing permissions and
+%% limitations under the License.
+%%
+%% %CopyrightEnd%
+%%
+%% This module implements a process with the registered name 'test_server_io',
+%% which has two main responsibilities:
+%%
+%% * Manage group leader processes (see the test_server_gl module)
+%% for test cases. A group_leader process is obtained by calling
+%% get_gl/1. Group leader processes will be kept alive as along as
+%% the 'test_server_io' process is alive.
+%%
+%% * Handle output to the common log files (stdout, major, html,
+%% unexpected_io).
+%%
+
+-module(test_server_io).
+-export([start_link/0,stop/1,get_gl/1,set_fd/2,
+ start_transaction/0,end_transaction/0,
+ print_buffered/1,print/3,print_unexpected/1,
+ set_footer/1,set_job_name/1,set_gl_props/1,
+ reset_state/0,finish/0]).
+
+-export([init/1,handle_call/3,handle_info/2,terminate/2]).
+
+-record(st, {fds, % Singleton fds (gb_tree)
+ tags=[], % Known tag types
+ shared_gl :: pid(), % Shared group leader
+ gls, % Group leaders (gb_set)
+ io_buffering=false, % I/O buffering
+ buffered, % Buffered I/O requests
+ html_footer, % HTML footer
+ job_name, % Name of current job.
+ gl_props, % Properties for GL
+ phase, % Indicates current mode
+ offline_buffer, % Buffer I/O during startup
+ stopping, % Reply to when process stopped
+ pending_ops % Perform when process idle
+ }).
+
+start_link() ->
+ case whereis(?MODULE) of
+ undefined ->
+ case gen_server:start_link({local,?MODULE}, ?MODULE, [], []) of
+ {ok,Pid} ->
+ {ok,Pid};
+ Other ->
+ Other
+ end;
+ Pid ->
+ %% already running, reset the state
+ reset_state(),
+ {ok,Pid}
+ end.
+
+stop(FilesToClose) ->
+ OldGL = group_leader(),
+ group_leader(self(), self()),
+ req({stop,FilesToClose}),
+ group_leader(OldGL, self()),
+ ok.
+
+finish() ->
+ req(finish).
+
+%% get_gl(Shared) -> Pid
+%% Shared = boolean()
+%% Pid = pid()
+%%
+%% Return a group leader (a process using the test_server_gl module).
+%% If Shared is true, the shared group leader is returned (suitable for
+%% running sequential test cases), otherwise a new group leader process
+%% is spawned. Group leader processes will live until the
+%% 'test_server_io' process is stopped.
+
+get_gl(Shared) when is_boolean(Shared) ->
+ req({get_gl,Shared}).
+
+%% set_fd(Tag, Fd) -> ok.
+%% Tag = major | html | unexpected_io
+%% Fd = a file descriptor (as returned by file:open/2)
+%%
+%% Associate a file descriptor with the given Tag. This
+%% Tag can later be used in when calling to print/3.
+
+set_fd(Tag, Fd) ->
+ req({set_fd,Tag,Fd}).
+
+%% start_transaction()
+%%
+%% Subsequent calls to print/3 from the process executing start_transaction/0
+%% will cause the messages to be buffered instead of printed directly.
+
+start_transaction() ->
+ req({start_transaction,self()}).
+
+%% end_transaction()
+%%
+%% End the transaction started by start_transaction/0. Subsequent calls to
+%% print/3 will cause the message to be printed directly.
+
+end_transaction() ->
+ req({end_transaction,self()}).
+
+%% print(From, Tag, Msg)
+%% From = pid()
+%% Tag = stdout, or any tag that has been registered using set_fd/2
+%% Msg = string or iolist
+%%
+%% Either print Msg to the file identified by Tag, or buffer the message
+%% start_transaction/0 has been called from the process From.
+%%
+%% NOTE: The tags have various special meanings. For example, 'html'
+%% is assumed to be a HTML file.
+
+print(From, Tag, Msg) ->
+ req({print,From,Tag,Msg}).
+
+%% print_buffered(Pid)
+%% Pid = pid()
+%%
+%% Print all messages buffered in the *first* transaction buffered for Pid.
+%% (If start_transaction/0 and end_transaction/0 has been called N times,
+%% print_buffered/1 must be called N times to print all transactions.)
+
+print_buffered(Pid) ->
+ req({print_buffered,Pid}).
+
+%% print_unexpected(Msg)
+%% Msg = string or iolist
+%%
+%% Print the given string in the unexpected_io log.
+
+print_unexpected(Msg) ->
+ print(xxxFrom,unexpected_io,Msg).
+
+%% set_footer(IoData)
+%%
+%% Set a footer for the file associated with the 'html' tag.
+%% It will be used by print/3 to print a footer for the HTML file.
+
+set_footer(Footer) ->
+ req({set_footer,Footer}).
+
+%% set_job_name(Name)
+%%
+%% Set a name for the currently running job. The name will be used
+%% when printing to 'stdout'.
+%%
+
+set_job_name(Name) ->
+ req({set_job_name,Name}).
+
+%% set_gl_props(PropList)
+%%
+%% Set properties for group leader processes. When a group_leader process
+%% is created, test_server_gl:set_props(PropList) will be called.
+
+set_gl_props(PropList) ->
+ req({set_gl_props,PropList}).
+
+%% reset_state
+%%
+%% Reset the initial state
+reset_state() ->
+ req(reset_state).
+
+%%% Internal functions.
+
+init([]) ->
+ process_flag(trap_exit, true),
+ Empty = gb_trees:empty(),
+ {ok,Shared} = test_server_gl:start_link(),
+ {ok,#st{fds=Empty,shared_gl=Shared,gls=gb_sets:empty(),
+ io_buffering=gb_sets:empty(),
+ buffered=Empty,
+ html_footer="</body>\n</html>\n",
+ job_name="<name not set>",
+ gl_props=[],
+ phase=starting,
+ offline_buffer=[],
+ pending_ops=[]}}.
+
+req(Req) ->
+ gen_server:call(?MODULE, Req, infinity).
+
+handle_call({get_gl,false}, _From, #st{gls=Gls,gl_props=Props}=St) ->
+ {ok,Pid} = test_server_gl:start_link(),
+ test_server_gl:set_props(Pid, Props),
+ {reply,Pid,St#st{gls=gb_sets:insert(Pid, Gls)}};
+handle_call({get_gl,true}, _From, #st{shared_gl=Shared}=St) ->
+ {reply,Shared,St};
+handle_call({set_fd,Tag,Fd}, _From, #st{fds=Fds0,tags=Tags0,
+ offline_buffer=OfflineBuff}=St) ->
+ Fds = gb_trees:enter(Tag, Fd, Fds0),
+ St1 = St#st{fds=Fds,tags=[Tag|lists:delete(Tag, Tags0)]},
+ OfflineBuff1 =
+ if OfflineBuff == [] ->
+ [];
+ true ->
+ %% Fd ready, print anything buffered for associated Tag
+ lists:filtermap(fun({T,From,Str}) when T == Tag ->
+ output(From, Tag, Str, St1),
+ false;
+ (_) ->
+ true
+ end, lists:reverse(OfflineBuff))
+ end,
+ {reply,ok,St1#st{phase=started,
+ offline_buffer=lists:reverse(OfflineBuff1)}};
+handle_call({start_transaction,Pid}, _From, #st{io_buffering=Buffer0,
+ buffered=Buf0}=St) ->
+ Buf = case gb_trees:is_defined(Pid, Buf0) of
+ false -> gb_trees:insert(Pid, queue:new(), Buf0);
+ true -> Buf0
+ end,
+ Buffer = gb_sets:add(Pid, Buffer0),
+ {reply,ok,St#st{io_buffering=Buffer,buffered=Buf}};
+handle_call({print,From,Tag,Str}, _From, St0) ->
+ St = output(From, Tag, Str, St0),
+ {reply,ok,St};
+handle_call({end_transaction,Pid}, _From, #st{io_buffering=Buffer0,
+ buffered=Buffered0}=St0) ->
+ Q0 = gb_trees:get(Pid, Buffered0),
+ Q = queue:in(eot, Q0),
+ Buffered = gb_trees:update(Pid, Q, Buffered0),
+ Buffer = gb_sets:delete_any(Pid, Buffer0),
+ St = St0#st{io_buffering=Buffer,buffered=Buffered},
+ {reply,ok,St};
+handle_call({print_buffered,Pid}, _From, #st{buffered=Buffered0}=St0) ->
+ Q0 = gb_trees:get(Pid, Buffered0),
+ Q = do_print_buffered(Q0, St0),
+ Buffered = gb_trees:update(Pid, Q, Buffered0),
+ St = St0#st{buffered=Buffered},
+ {reply,ok,St};
+handle_call({set_footer,Footer}, _From, St) ->
+ {reply,ok,St#st{html_footer=Footer}};
+handle_call({set_job_name,Name}, _From, St) ->
+ {reply,ok,St#st{job_name=Name}};
+handle_call({set_gl_props,Props}, _From, #st{shared_gl=Shared}=St) ->
+ test_server_gl:set_props(Shared, Props),
+ {reply,ok,St#st{gl_props=Props}};
+handle_call(reset_state, From, #st{phase=stopping,pending_ops=Ops}=St) ->
+ %% can't reset during stopping phase, save op for later
+ Op = fun(NewSt) ->
+ {_,Result,NewSt1} = handle_call(reset_state, From, NewSt),
+ {Result,NewSt1}
+ end,
+ {noreply,St#st{pending_ops=[{From,Op}|Ops]}};
+handle_call(reset_state, _From, #st{fds=Fds,tags=Tags,gls=Gls,
+ offline_buffer=OfflineBuff}) ->
+ %% close open log files
+ lists:foreach(fun(Tag) ->
+ case gb_trees:lookup(Tag, Fds) of
+ none ->
+ ok;
+ {value,Fd} ->
+ file:close(Fd)
+ end
+ end, Tags),
+ GlList = gb_sets:to_list(Gls),
+ [test_server_gl:stop(GL) || GL <- GlList],
+ timer:sleep(100),
+ case lists:filter(fun(GlPid) -> is_process_alive(GlPid) end, GlList) of
+ [] ->
+ ok;
+ _ ->
+ timer:sleep(2000),
+ [exit(GL, kill) || GL <- GlList]
+ end,
+ Empty = gb_trees:empty(),
+ {ok,Shared} = test_server_gl:start_link(),
+ {reply,ok,#st{fds=Empty,shared_gl=Shared,gls=gb_sets:empty(),
+ io_buffering=gb_sets:empty(),
+ buffered=Empty,
+ html_footer="</body>\n</html>\n",
+ job_name="<name not set>",
+ gl_props=[],
+ phase=starting,
+ offline_buffer=OfflineBuff,
+ pending_ops=[]}};
+handle_call({stop,FdTags}, From, #st{fds=Fds0,tags=Tags0,
+ shared_gl=SGL,gls=Gls0}=St0) ->
+ St = St0#st{gls=gb_sets:insert(SGL, Gls0),phase=stopping,stopping=From},
+ gc(St),
+ %% close open log files
+ {Fds1,Tags1} = lists:foldl(fun(Tag, {Fds,Tags}) ->
+ case gb_trees:lookup(Tag, Fds) of
+ none ->
+ {Fds,Tags};
+ {value,Fd} ->
+ file:close(Fd),
+ {gb_trees:delete(Tag, Fds),
+ lists:delete(Tag, Tags)}
+ end
+ end, {Fds0,Tags0}, FdTags),
+ %% Give the users of the surviving group leaders some
+ %% time to finish.
+ erlang:send_after(1000, self(), stop_group_leaders),
+ {noreply,St#st{fds=Fds1,tags=Tags1}};
+handle_call(finish, From, St) ->
+ gen_server:reply(From, ok),
+ {stop,normal,St}.
+
+handle_info({'EXIT',Pid,normal}, #st{gls=Gls0,stopping=From}=St) ->
+ Gls = gb_sets:delete_any(Pid, Gls0),
+ case gb_sets:is_empty(Gls) andalso stopping =/= undefined of
+ true ->
+ %% No more group leaders left.
+ gen_server:reply(From, ok),
+ {noreply,St#st{gls=Gls,phase=stopping,stopping=undefined}};
+ false ->
+ %% Wait for more group leaders to finish.
+ {noreply,St#st{gls=Gls,phase=stopping}}
+ end;
+handle_info({'EXIT',_Pid,Reason}, _St) ->
+ exit(Reason);
+handle_info(stop_group_leaders, #st{gls=Gls}=St) ->
+ %% Stop the remaining group leaders.
+ GlPids = gb_sets:to_list(Gls),
+ [test_server_gl:stop(GL) || GL <- GlPids],
+ timer:sleep(100),
+ Wait =
+ case lists:filter(fun(GlPid) -> is_process_alive(GlPid) end, GlPids) of
+ [] -> 0;
+ _ -> 2000
+ end,
+ erlang:send_after(Wait, self(), kill_group_leaders),
+ {noreply,St};
+handle_info(kill_group_leaders, #st{gls=Gls,stopping=From,
+ pending_ops=Ops}=St) ->
+ [exit(GL, kill) || GL <- gb_sets:to_list(Gls)],
+ if From /= undefined ->
+ gen_server:reply(From, ok);
+ true -> % reply has been sent already
+ ok
+ end,
+ %% we're idle, check if any ops are pending
+ St1 = lists:foldr(fun({ReplyTo,Op},NewSt) ->
+ {Result,NewSt1} = Op(NewSt),
+ gen_server:reply(ReplyTo, Result),
+ NewSt1
+ end, St#st{phase=idle,pending_ops=[]}, Ops),
+ {noreply,St1};
+handle_info(Other, St) ->
+ io:format("Ignoring: ~p\n", [Other]),
+ {noreply,St}.
+
+terminate(_, _) ->
+ ok.
+
+output(From, Tag, Str, #st{io_buffering=Buffered,buffered=Buf0,
+ phase=Phase,offline_buffer=OfflineBuff}=St) ->
+ case gb_sets:is_member(From, Buffered) of
+ false ->
+ case do_output(Tag, Str, Phase, St) of
+ buffer when length(OfflineBuff)>500 ->
+ %% something's wrong, clear buffer
+ St#st{offline_buffer=[]};
+ buffer ->
+ St#st{offline_buffer=[{Tag,From,Str}|OfflineBuff]};
+ _ ->
+ St
+ end;
+ true ->
+ Q0 = gb_trees:get(From, Buf0),
+ Q = queue:in({Tag,Str}, Q0),
+ Buf = gb_trees:update(From, Q, Buf0),
+ St#st{buffered=Buf}
+ end.
+
+do_output(stdout, Str, _, #st{job_name=undefined}) ->
+ io:put_chars(Str);
+do_output(stdout, Str0, _, #st{job_name=Name}) ->
+ Str = io_lib:format("Testing ~ts: ~ts\n", [Name,Str0]),
+ io:put_chars(Str);
+do_output(Tag, Str, Phase, #st{fds=Fds}=St) ->
+ case gb_trees:lookup(Tag, Fds) of
+ none when Phase /= started ->
+ buffer;
+ none ->
+ S = io_lib:format("\n*** ERROR: ~w, line ~w: No known '~p' log file\n",
+ [?MODULE,?LINE,Tag]),
+ do_output(stdout, [S,Str], Phase, St);
+ {value,Fd} ->
+ try
+ io:put_chars(Fd, Str),
+ case Tag of
+ html -> finalise_table(Fd, St);
+ _ -> ok
+ end
+ catch _:Error ->
+ S = io_lib:format("\n*** ERROR: ~w, line ~w: Error writing to "
+ "log file '~p': ~p\n",
+ [?MODULE,?LINE,Tag,Error]),
+ do_output(stdout, [S,Str], Phase, St)
+ end
+ end.
+
+finalise_table(Fd, #st{html_footer=Footer}) ->
+ case file:position(Fd, {cur,0}) of
+ {ok,Pos} ->
+ %% We are writing to a seekable file. Finalise so
+ %% we get complete valid (and viewable) HTML code.
+ %% Then rewind to overwrite the finalising code.
+ io:put_chars(Fd, ["\n</table>\n",Footer]),
+ file:position(Fd, Pos);
+ {error,epipe} ->
+ %% The file is not seekable. We cannot erase what
+ %% we've already written --- so the reader will
+ %% have to wait until we're done.
+ ok
+ end.
+
+do_print_buffered(Q0, St) ->
+ Item = queue:get(Q0),
+ Q = queue:drop(Q0),
+ case Item of
+ eot ->
+ Q;
+ {Tag,Str} ->
+ do_output(Tag, Str, undefined, St),
+ do_print_buffered(Q, St)
+ end.
+
+gc(#st{gls=Gls0}) ->
+ InUse0 = [begin
+ case process_info(P, group_leader) of
+ {group_leader,GL} -> GL;
+ undefined -> undefined
+ end
+ end || P <- processes()],
+ InUse = ordsets:from_list(InUse0),
+ Gls = gb_sets:to_list(Gls0),
+ NotUsed = ordsets:subtract(Gls, InUse),
+ [test_server_gl:stop(Pid) || Pid <- NotUsed],
+ ok.
diff --git a/lib/common_test/src/test_server_node.erl b/lib/common_test/src/test_server_node.erl
new file mode 100644
index 0000000000..c64399e485
--- /dev/null
+++ b/lib/common_test/src/test_server_node.erl
@@ -0,0 +1,766 @@
+%%
+%% %CopyrightBegin%
+%%
+%% Copyright Ericsson AB 2002-2016. All Rights Reserved.
+%%
+%% Licensed under the Apache License, Version 2.0 (the "License");
+%% you may not use this file except in compliance with the License.
+%% You may obtain a copy of the License at
+%%
+%% http://www.apache.org/licenses/LICENSE-2.0
+%%
+%% Unless required by applicable law or agreed to in writing, software
+%% distributed under the License is distributed on an "AS IS" BASIS,
+%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+%% See the License for the specific language governing permissions and
+%% limitations under the License.
+%%
+%% %CopyrightEnd%
+%%
+-module(test_server_node).
+-compile(r12).
+
+%%%
+%%% The same compiled code for this module must be possible to load
+%%% in R12B and later.
+%%%
+
+%% Test Controller interface
+-export([is_release_available/1]).
+-export([start_tracer_node/2,trace_nodes/2,stop_tracer_node/1]).
+-export([start_node/5, stop_node/1]).
+-export([kill_nodes/0, nodedown/1]).
+%% Internal export
+-export([node_started/1,trc/1,handle_debug/4]).
+
+-include("test_server_internal.hrl").
+-record(slave_info, {name,socket,client}).
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%%% %%%
+%%% All code in this module executes on the test_server_ctrl process %%%
+%%% except for node_started/1 and trc/1 which execute on a new node. %%%
+%%% %%%
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+is_release_available(Rel) when is_atom(Rel) ->
+ is_release_available(atom_to_list(Rel));
+is_release_available(Rel) ->
+ case os:type() of
+ {unix,_} ->
+ Erl = find_release(Rel),
+ case Erl of
+ none -> false;
+ _ -> filelib:is_regular(Erl)
+ end;
+ _ ->
+ false
+ end.
+
+nodedown(Sock) ->
+ Match = #slave_info{name='$1',socket=Sock,client='$2',_='_'},
+ case ets:match(slave_tab,Match) of
+ [[Node,_Client]] -> % Slave node died
+ gen_tcp:close(Sock),
+ ets:delete(slave_tab,Node),
+ slave_died;
+ [] ->
+ ok
+ end.
+
+
+
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%%% Start trace node
+%%%
+start_tracer_node(TraceFile,TI) ->
+ Match = #slave_info{name='$1',_='_'},
+ SlaveNodes = lists:map(fun([N]) -> [" ",N] end,
+ ets:match(slave_tab,Match)),
+ TargetNode = node(),
+ Cookie = TI#target_info.cookie,
+ {ok,LSock} = gen_tcp:listen(0,[binary,{reuseaddr,true},{packet,2}]),
+ {ok,TracePort} = inet:port(LSock),
+ Prog = quote_progname(pick_erl_program(default)),
+ Cmd = lists:concat([Prog, " -sname tracer -hidden -setcookie ", Cookie,
+ " -s ", ?MODULE, " trc ", TraceFile, " ",
+ TracePort, " ", TI#target_info.os_family]),
+ spawn(fun() -> print_data(open_port({spawn,Cmd},[stream])) end),
+%! open_port({spawn,Cmd},[stream]),
+ case gen_tcp:accept(LSock,?ACCEPT_TIMEOUT) of
+ {ok,Sock} ->
+ gen_tcp:close(LSock),
+ receive
+ {tcp,Sock,Result} when is_binary(Result) ->
+ case unpack(Result) of
+ error ->
+ gen_tcp:close(Sock),
+ {error,timeout};
+ {ok,started} ->
+ trace_nodes(Sock,[TargetNode | SlaveNodes]),
+ {ok,Sock};
+ {ok,Error} -> Error
+ end;
+ {tcp_closed,Sock} ->
+ gen_tcp:close(Sock),
+ {error,could_not_start_tracernode}
+ after ?ACCEPT_TIMEOUT ->
+ gen_tcp:close(Sock),
+ {error,timeout}
+ end;
+ Error ->
+ gen_tcp:close(LSock),
+ {error,{could_not_start_tracernode,Error}}
+ end.
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%%% Start a tracer on each of these nodes and set flags and patterns
+%%%
+trace_nodes(Sock,Nodes) ->
+ Bin = term_to_binary({add_nodes,Nodes}),
+ ok = gen_tcp:send(Sock, tag_trace_message(Bin)),
+ receive_ack(Sock).
+
+
+receive_ack(Sock) ->
+ receive
+ {tcp,Sock,Bin} when is_binary(Bin) ->
+ case unpack(Bin) of
+ error -> receive_ack(Sock);
+ {ok,_} -> ok
+ end;
+ _ ->
+ receive_ack(Sock)
+ end.
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%%% Stop trace node
+%%%
+stop_tracer_node(Sock) ->
+ Bin = term_to_binary(id(stop)),
+ ok = gen_tcp:send(Sock, tag_trace_message(Bin)),
+ receive {tcp_closed,Sock} -> gen_tcp:close(Sock) end,
+ ok.
+
+
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% trc([TraceFile,Nodes]) -> ok
+%%
+%% Start tracing on the given nodes
+%%
+%% This function executes on the new node
+%%
+trc([TraceFile, PortAtom, Type]) ->
+ {Result,Patterns} =
+ case file:consult(TraceFile) of
+ {ok,TI} ->
+ Pat = parse_trace_info(lists:flatten(TI)),
+ {started,Pat};
+ Error ->
+ {Error,[]}
+ end,
+ Port = list_to_integer(atom_to_list(PortAtom)),
+ case catch gen_tcp:connect("localhost", Port, [binary,
+ {reuseaddr,true},
+ {packet,2}]) of
+ {ok,Sock} ->
+ BinResult = term_to_binary(Result),
+ ok = gen_tcp:send(Sock,tag_trace_message(BinResult)),
+ trc_loop(Sock,Patterns,Type);
+ _else ->
+ ok
+ end,
+ erlang:halt().
+trc_loop(Sock,Patterns,Type) ->
+ receive
+ {tcp,Sock,Bin} ->
+ case unpack(Bin) of
+ error ->
+ ttb:stop(),
+ gen_tcp:close(Sock);
+ {ok,{add_nodes,Nodes}} ->
+ add_nodes(Nodes,Patterns,Type),
+ Bin = term_to_binary(id(ok)),
+ ok = gen_tcp:send(Sock, tag_trace_message(Bin)),
+ trc_loop(Sock,Patterns,Type);
+ {ok,stop} ->
+ ttb:stop(),
+ gen_tcp:close(Sock)
+ end;
+ {tcp_closed,Sock} ->
+ ttb:stop(),
+ gen_tcp:close(Sock)
+ end.
+add_nodes(Nodes,Patterns,_Type) ->
+ ttb:tracer(Nodes,[{file,{local, test_server}},
+ {handler, {{?MODULE,handle_debug},initial}}]),
+ ttb:p(all,[call,timestamp]),
+ lists:foreach(fun({TP,M,F,A,Pat}) -> ttb:TP(M,F,A,Pat);
+ ({CTP,M,F,A}) -> ttb:CTP(M,F,A)
+ end,
+ Patterns).
+
+parse_trace_info([{TP,M,Pat}|Pats]) when TP=:=tp; TP=:=tpl ->
+ [{TP,M,'_','_',Pat}|parse_trace_info(Pats)];
+parse_trace_info([{TP,M,F,Pat}|Pats]) when TP=:=tp; TP=:=tpl ->
+ [{TP,M,F,'_',Pat}|parse_trace_info(Pats)];
+parse_trace_info([{TP,M,F,A,Pat}|Pats]) when TP=:=tp; TP=:=tpl ->
+ [{TP,M,F,A,Pat}|parse_trace_info(Pats)];
+parse_trace_info([CTP|Pats]) when CTP=:=ctp; CTP=:=ctpl; CTP=:=ctpg ->
+ [{CTP,'_','_','_'}|parse_trace_info(Pats)];
+parse_trace_info([{CTP,M}|Pats]) when CTP=:=ctp; CTP=:=ctpl; CTP=:=ctpg ->
+ [{CTP,M,'_','_'}|parse_trace_info(Pats)];
+parse_trace_info([{CTP,M,F}|Pats]) when CTP=:=ctp; CTP=:=ctpl; CTP=:=ctpg ->
+ [{CTP,M,F,'_'}|parse_trace_info(Pats)];
+parse_trace_info([{CTP,M,F,A}|Pats]) when CTP=:=ctp; CTP=:=ctpl; CTP=:=ctpg ->
+ [{CTP,M,F,A}|parse_trace_info(Pats)];
+parse_trace_info([]) ->
+ [];
+parse_trace_info([_other|Pats]) -> % ignore
+ parse_trace_info(Pats).
+
+handle_debug(Out,Trace,TI,initial) ->
+ handle_debug(Out,Trace,TI,0);
+handle_debug(_Out,end_of_trace,_TI,N) ->
+ N;
+handle_debug(Out,Trace,_TI,N) ->
+ print_trc(Out,Trace,N),
+ N+1.
+
+print_trc(Out,{trace_ts,P,call,{M,F,A},C,Ts},N) ->
+ io:format(Out,
+ "~w: ~s~n"
+ "Process : ~w~n"
+ "Call : ~w:~w/~w~n"
+ "Arguments : ~p~n"
+ "Caller : ~w~n~n",
+ [N,ts(Ts),P,M,F,length(A),A,C]);
+print_trc(Out,{trace_ts,P,call,{M,F,A},Ts},N) ->
+ io:format(Out,
+ "~w: ~s~n"
+ "Process : ~w~n"
+ "Call : ~w:~w/~w~n"
+ "Arguments : ~p~n~n",
+ [N,ts(Ts),P,M,F,length(A),A]);
+print_trc(Out,{trace_ts,P,return_from,{M,F,A},R,Ts},N) ->
+ io:format(Out,
+ "~w: ~s~n"
+ "Process : ~w~n"
+ "Return from : ~w:~w/~w~n"
+ "Return value : ~p~n~n",
+ [N,ts(Ts),P,M,F,A,R]);
+print_trc(Out,{drop,X},N) ->
+ io:format(Out,
+ "~w: Tracer dropped ~w messages - too busy~n~n",
+ [N,X]);
+print_trc(Out,Trace,N) ->
+ Ts = element(size(Trace),Trace),
+ io:format(Out,
+ "~w: ~s~n"
+ "Trace : ~p~n~n",
+ [N,ts(Ts),Trace]).
+ts({_, _, Micro} = Now) ->
+ {{Y,M,D},{H,Min,S}} = calendar:now_to_local_time(Now),
+ io_lib:format("~4.4.0w-~2.2.0w-~2.2.0w ~2.2.0w:~2.2.0w:~2.2.0w,~6.6.0w",
+ [Y,M,D,H,Min,S,Micro]).
+
+
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%%% Start slave/peer nodes (initiated by test_server:start_node/5)
+%%%
+start_node(SlaveName, slave, Options, From, TI) when is_list(SlaveName) ->
+ start_node_slave(list_to_atom(SlaveName), Options, From, TI);
+start_node(SlaveName, slave, Options, From, TI) ->
+ start_node_slave(SlaveName, Options, From, TI);
+start_node(SlaveName, peer, Options, From, TI) when is_atom(SlaveName) ->
+ start_node_peer(atom_to_list(SlaveName), Options, From, TI);
+start_node(SlaveName, peer, Options, From, TI) ->
+ start_node_peer(SlaveName, Options, From, TI);
+start_node(_SlaveName, _Type, _Options, _From, _TI) ->
+ not_implemented_yet.
+
+%%
+%% Peer nodes are always started on the same host as test_server_ctrl
+%%
+%% (Socket communication is used since in early days the test target
+%% and the test server controller node could be on different hosts and
+%% the target could not know the controller node via erlang
+%% distribution)
+%%
+start_node_peer(SlaveName, OptList, From, TI) ->
+ SuppliedArgs = start_node_get_option_value(args, OptList, []),
+ Cleanup = start_node_get_option_value(cleanup, OptList, true),
+ HostStr = test_server_sup:hoststr(),
+ {ok,LSock} = gen_tcp:listen(0,[binary,
+ {reuseaddr,true},
+ {packet,2}]),
+ {ok,WaitPort} = inet:port(LSock),
+ NodeStarted = lists:concat([" -s ", ?MODULE, " node_started ",
+ HostStr, " ", WaitPort]),
+
+ % Support for erl_crash_dump files..
+ CrashDir = test_server_sup:crash_dump_dir(),
+ CrashFile = filename:join([CrashDir,
+ "erl_crash_dump."++cast_to_list(SlaveName)]),
+ CrashArgs = lists:concat([" -env ERL_CRASH_DUMP \"",CrashFile,"\" "]),
+ FailOnError = start_node_get_option_value(fail_on_error, OptList, true),
+ Prog0 = start_node_get_option_value(erl, OptList, default),
+ Prog = quote_progname(pick_erl_program(Prog0)),
+ Args =
+ case string:str(SuppliedArgs,"-setcookie") of
+ 0 -> "-setcookie " ++ TI#target_info.cookie ++ " " ++ SuppliedArgs;
+ _ -> SuppliedArgs
+ end,
+ Cmd = lists:concat([Prog,
+ " -detached ",
+ TI#target_info.naming, " ", SlaveName,
+ NodeStarted,
+ CrashArgs,
+ " ", Args]),
+ Opts = case start_node_get_option_value(env, OptList, []) of
+ [] -> [];
+ Env -> [{env, Env}]
+ end,
+ %% peer is always started on localhost
+ %%
+ %% Bad environment can cause open port to fail. If this happens,
+ %% we ignore it and let the testcase handle the situation...
+ catch open_port({spawn, Cmd}, [stream|Opts]),
+
+ Tmo = 60000 * test_server:timetrap_scale_factor(),
+
+ case start_node_get_option_value(wait, OptList, true) of
+ true ->
+ Ret = wait_for_node_started(LSock,Tmo,undefined,Cleanup,TI,self()),
+ case {Ret,FailOnError} of
+ {{{ok, Node}, Warning},_} ->
+ gen_server:reply(From,{{ok,Node},HostStr,Cmd,[],Warning});
+ {_,false} ->
+ gen_server:reply(From,{Ret, HostStr, Cmd});
+ {_,true} ->
+ gen_server:reply(From,{fail,{Ret, HostStr, Cmd}})
+ end;
+ false ->
+ Nodename = list_to_atom(SlaveName ++ "@" ++ HostStr),
+ I = "=== Not waiting for node",
+ gen_server:reply(From,{{ok, Nodename}, HostStr, Cmd, I, []}),
+ Self = self(),
+ spawn_link(wait_for_node_started_fun(LSock,Tmo,Cleanup,TI,Self)),
+ ok
+ end.
+
+-spec wait_for_node_started_fun(_, _, _, _, _) -> fun(() -> no_return()).
+wait_for_node_started_fun(LSock, Tmo, Cleanup, TI, Self) ->
+ fun() ->
+ wait_for_node_started(LSock,Tmo,undefined,
+ Cleanup,TI,Self),
+ receive after infinity -> ok end
+ end.
+
+%%
+%% Slave nodes are started on a remote host if
+%% - the option remote is given when calling test_server:start_node/3
+%%
+start_node_slave(SlaveName, OptList, From, _TI) ->
+ SuppliedArgs = start_node_get_option_value(args, OptList, []),
+ Cleanup = start_node_get_option_value(cleanup, OptList, true),
+
+ CrashDir = test_server_sup:crash_dump_dir(),
+ CrashFile = filename:join([CrashDir,
+ "erl_crash_dump."++cast_to_list(SlaveName)]),
+ CrashArgs = lists:concat([" -env ERL_CRASH_DUMP \"",CrashFile,"\" "]),
+ Args = lists:concat([" ", SuppliedArgs, CrashArgs]),
+
+ Prog0 = start_node_get_option_value(erl, OptList, default),
+ Prog = pick_erl_program(Prog0),
+ Ret =
+ case start_which_node(OptList) of
+ {error,Reason} -> {{error,Reason},undefined,undefined};
+ Host0 -> do_start_node_slave(Host0,SlaveName,Args,Prog,Cleanup)
+ end,
+ gen_server:reply(From,Ret).
+
+
+do_start_node_slave(Host0, SlaveName, Args, Prog, Cleanup) ->
+ Host =
+ case Host0 of
+ local -> test_server_sup:hoststr();
+ _ -> cast_to_list(Host0)
+ end,
+ Cmd = Prog ++ " " ++ Args,
+ case slave:start(Host, SlaveName, Args, no_link, Prog) of
+ {ok,Nodename} ->
+ case Cleanup of
+ true -> ets:insert(slave_tab,#slave_info{name=Nodename});
+ false -> ok
+ end,
+ {{ok,Nodename}, Host, Cmd, [], []};
+ Ret ->
+ {Ret, Host, Cmd}
+ end.
+
+
+wait_for_node_started(LSock,Timeout,Client,Cleanup,TI,CtrlPid) ->
+ case gen_tcp:accept(LSock,Timeout) of
+ {ok,Sock} ->
+ gen_tcp:close(LSock),
+ receive
+ {tcp,Sock,Started0} when is_binary(Started0) ->
+ case unpack(Started0) of
+ error ->
+ gen_tcp:close(Sock),
+ {error, connection_closed};
+ {ok,Started} ->
+ Version = TI#target_info.otp_release,
+ VsnStr = TI#target_info.system_version,
+ {ok,Nodename, W} =
+ handle_start_node_return(Version,
+ VsnStr,
+ Started),
+ case Cleanup of
+ true ->
+ ets:insert(slave_tab,#slave_info{name=Nodename,
+ socket=Sock,
+ client=Client});
+ false -> ok
+ end,
+ gen_tcp:controlling_process(Sock,CtrlPid),
+ test_server_ctrl:node_started(Nodename),
+ {{ok,Nodename},W}
+ end;
+ {tcp_closed,Sock} ->
+ gen_tcp:close(Sock),
+ {error, connection_closed}
+ after Timeout ->
+ gen_tcp:close(Sock),
+ {error, timeout}
+ end;
+ {error,Reason} ->
+ gen_tcp:close(LSock),
+ {error, {no_connection,Reason}}
+ end.
+
+
+
+handle_start_node_return(Version,VsnStr,{started, Node, Version, VsnStr}) ->
+ {ok, Node, []};
+handle_start_node_return(Version,VsnStr,{started, Node, OVersion, OVsnStr}) ->
+ Str = io_lib:format("WARNING: Started node "
+ "reports different system "
+ "version than current node! "
+ "Current node version: ~p, ~p "
+ "Started node version: ~p, ~p",
+ [Version, VsnStr,
+ OVersion, OVsnStr]),
+ Str1 = lists:flatten(Str),
+ {ok, Node, Str1}.
+
+
+%%
+%% This function executes on the new node
+%%
+node_started([Host,PortAtom]) ->
+ %% Must spawn a new process because the boot process should not
+ %% hang forever!!
+ spawn(node_started_fun(Host,PortAtom)).
+
+-spec node_started_fun(_, _) -> fun(() -> no_return()).
+node_started_fun(Host,PortAtom) ->
+ fun() -> node_started(Host,PortAtom) end.
+
+%% This process hangs forever, just waiting for the socket to be
+%% closed and terminating the node
+node_started(Host,PortAtom) ->
+ {_, Version} = init:script_id(),
+ VsnStr = erlang:system_info(system_version),
+ Port = list_to_integer(atom_to_list(PortAtom)),
+ case catch gen_tcp:connect(Host,Port, [binary,
+ {reuseaddr,true},
+ {packet,2}]) of
+
+ {ok,Sock} ->
+ Started = term_to_binary({started, node(), Version, VsnStr}),
+ ok = gen_tcp:send(Sock, tag_trace_message(Started)),
+ receive _Anyting ->
+ gen_tcp:close(Sock),
+ erlang:halt()
+ end;
+ _else ->
+ erlang:halt()
+ end.
+
+
+-compile({inline, [tag_trace_message/1]}).
+-dialyzer({no_improper_lists, tag_trace_message/1}).
+tag_trace_message(M) ->
+ [1|M].
+
+% start_which_node(Optlist) -> hostname
+start_which_node(Optlist) ->
+ case start_node_get_option_value(remote, Optlist) of
+ undefined ->
+ local;
+ true ->
+ case find_remote_host() of
+ {error, Other} ->
+ {error, Other};
+ RHost ->
+ RHost
+ end
+ end.
+
+find_remote_host() ->
+ HostList=test_server_ctrl:get_hosts(),
+ case lists:delete(test_server_sup:hoststr(), HostList) of
+ [] ->
+ {error, no_remote_hosts};
+ [RHost|_Rest] ->
+ RHost
+ end.
+
+start_node_get_option_value(Key, List) ->
+ start_node_get_option_value(Key, List, undefined).
+
+start_node_get_option_value(Key, List, Default) ->
+ case lists:keysearch(Key, 1, List) of
+ {value, {Key, Value}} ->
+ Value;
+ false ->
+ Default
+ end.
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% stop_node(Name) -> ok | {error,Reason}
+%%
+%% Clean up - test_server will stop this node
+stop_node(Name) ->
+ case ets:lookup(slave_tab,Name) of
+ [#slave_info{}] ->
+ ets:delete(slave_tab,Name),
+ ok;
+ [] ->
+ {error, not_a_slavenode}
+ end.
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% kill_nodes() -> ok
+%%
+%% Brutally kill all slavenodes that were not stopped by test_server
+kill_nodes() ->
+ case ets:match_object(slave_tab,'_') of
+ [] -> [];
+ List ->
+ lists:map(fun(SI) -> kill_node(SI) end, List)
+ end.
+
+kill_node(SI) ->
+ Name = SI#slave_info.name,
+ ets:delete(slave_tab,Name),
+ case SI#slave_info.socket of
+ undefined ->
+ catch rpc:call(Name,erlang,halt,[]);
+ Sock ->
+ gen_tcp:close(Sock)
+ end,
+ Name.
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%%% cast_to_list(X) -> string()
+%%% X = list() | atom() | void()
+%%% Returns a string representation of whatever was input
+
+cast_to_list(X) when is_list(X) -> X;
+cast_to_list(X) when is_atom(X) -> atom_to_list(X);
+cast_to_list(X) -> lists:flatten(io_lib:format("~w", [X])).
+
+
+%%% L contains elements of the forms
+%%% {prog, String}
+%%% {release, Rel} where Rel = String | latest | previous
+%%% this
+%%%
+pick_erl_program(default) ->
+ cast_to_list(lib:progname());
+pick_erl_program(L) ->
+ P = random_element(L),
+ case P of
+ {prog, S} ->
+ S;
+ {release, S} ->
+ find_release(S);
+ this ->
+ cast_to_list(lib:progname())
+ end.
+
+%% This is an attempt to distinguish between spaces in the program
+%% path and spaces that separate arguments. The program is quoted to
+%% allow spaces in the path.
+%%
+%% Arguments could exist either if the executable is excplicitly given
+%% ({prog,String}) or if the -program switch to beam is used and
+%% includes arguments (typically done by cerl in OTP test environment
+%% in order to ensure that slave/peer nodes are started with the same
+%% emulator and flags as the test node. The return from lib:progname()
+%% could then typically be '/<full_path_to>/cerl -gcov').
+quote_progname(Progname) ->
+ do_quote_progname(string:tokens(Progname," ")).
+
+do_quote_progname([Prog]) ->
+ "\""++Prog++"\"";
+do_quote_progname([Prog,Arg|Args]) ->
+ case os:find_executable(Prog) of
+ false ->
+ do_quote_progname([Prog++" "++Arg | Args]);
+ _ ->
+ %% this one has an executable - we assume the rest are arguments
+ "\""++Prog++"\""++
+ lists:flatten(lists:map(fun(X) -> [" ",X] end, [Arg|Args]))
+ end.
+
+random_element(L) ->
+ lists:nth(rand:uniform(length(L)), L).
+
+find_release(latest) ->
+ "/usr/local/otp/releases/latest/bin/erl";
+find_release(previous) ->
+ "kaka";
+find_release(Rel) ->
+ find_release(os:type(), Rel).
+
+find_release({unix,sunos}, Rel) ->
+ case os:cmd("uname -p") of
+ "sparc" ++ _ ->
+ "/usr/local/otp/releases/otp_beam_solaris8_" ++ Rel ++ "/bin/erl";
+ _ ->
+ none
+ end;
+find_release({unix,linux}, Rel) ->
+ Candidates = find_rel_linux(Rel),
+ case lists:dropwhile(fun(N) ->
+ not filelib:is_regular(N)
+ end, Candidates) of
+ [] -> none;
+ [Erl|_] -> Erl
+ end;
+find_release(_, _) -> none.
+
+find_rel_linux(Rel) ->
+ case suse_release() of
+ none -> [];
+ SuseRel -> find_rel_suse(Rel, SuseRel)
+ end.
+
+find_rel_suse(Rel, SuseRel) ->
+ Root = "/usr/local/otp/releases/sles",
+ case SuseRel of
+ "11" ->
+ %% Try both SuSE 11, SuSE 10 and SuSe 9 in that order.
+ find_rel_suse_1(Rel, Root++"11") ++
+ find_rel_suse_1(Rel, Root++"10") ++
+ find_rel_suse_1(Rel, Root++"9");
+ "10" ->
+ %% Try both SuSE 10 and SuSe 9 in that order.
+ find_rel_suse_1(Rel, Root++"10") ++
+ find_rel_suse_1(Rel, Root++"9");
+ "9" ->
+ find_rel_suse_1(Rel, Root++"9");
+ _ ->
+ []
+ end.
+
+find_rel_suse_1(Rel, RootWc) ->
+ case erlang:system_info(wordsize) of
+ 4 ->
+ find_rel_suse_2(Rel, RootWc++"_32");
+ 8 ->
+ find_rel_suse_2(Rel, RootWc++"_64") ++
+ find_rel_suse_2(Rel, RootWc++"_32")
+ end.
+
+find_rel_suse_2(Rel, RootWc) ->
+ RelDir = filename:dirname(RootWc),
+ Pat = filename:basename(RootWc ++ "_" ++ Rel) ++ ".*",
+ case file:list_dir(RelDir) of
+ {ok,Dirs} ->
+ case lists:filter(fun(Dir) ->
+ case re:run(Dir, Pat) of
+ nomatch -> false;
+ _ -> true
+ end
+ end, Dirs) of
+ [] ->
+ [];
+ [R|_] ->
+ [filename:join([RelDir,R,"bin","erl"])]
+ end;
+ _ ->
+ []
+ end.
+
+%% suse_release() -> VersionString | none.
+%% Return the major SuSE version number for this platform or
+%% 'none' if this is not a SuSE platform.
+suse_release() ->
+ case file:open("/etc/SuSE-release", [read]) of
+ {ok,Fd} ->
+ try
+ suse_release(Fd)
+ after
+ file:close(Fd)
+ end;
+ {error,_} -> none
+ end.
+
+suse_release(Fd) ->
+ case io:get_line(Fd, '') of
+ eof -> none;
+ Line when is_list(Line) ->
+ case re:run(Line, "^VERSION\\s*=\\s*(\\d+)\s*",
+ [{capture,all_but_first,list}]) of
+ nomatch ->
+ suse_release(Fd);
+ {match,[Version]} ->
+ Version
+ end
+ end.
+
+unpack(Bin) ->
+ {One,Term} = split_binary(Bin, 1),
+ case binary_to_list(One) of
+ [1] ->
+ case catch {ok,binary_to_term(Term)} of
+ {'EXIT',_} -> error;
+ {ok,_}=Res -> Res
+ end;
+ _ -> error
+ end.
+
+id(I) -> I.
+
+print_data(Port) ->
+ receive
+ {Port, {data, Bytes}} ->
+ io:put_chars(Bytes),
+ print_data(Port);
+ {Port, eof} ->
+ Port ! {self(), close},
+ receive
+ {Port, closed} ->
+ true
+ end,
+ receive
+ {'EXIT', Port, _} ->
+ ok
+ after 1 -> % force context switch
+ ok
+ end
+ end.
diff --git a/lib/common_test/src/test_server_sup.erl b/lib/common_test/src/test_server_sup.erl
new file mode 100644
index 0000000000..c4530ba62f
--- /dev/null
+++ b/lib/common_test/src/test_server_sup.erl
@@ -0,0 +1,943 @@
+%%
+%% %CopyrightBegin%
+%%
+%% Copyright Ericsson AB 1998-2014. All Rights Reserved.
+%%
+%% Licensed under the Apache License, Version 2.0 (the "License");
+%% you may not use this file except in compliance with the License.
+%% You may obtain a copy of the License at
+%%
+%% http://www.apache.org/licenses/LICENSE-2.0
+%%
+%% Unless required by applicable law or agreed to in writing, software
+%% distributed under the License is distributed on an "AS IS" BASIS,
+%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+%% See the License for the specific language governing permissions and
+%% limitations under the License.
+%%
+%% %CopyrightEnd%
+%%
+
+%%%-------------------------------------------------------------------
+%%% Purpose: Test server support functions.
+%%%-------------------------------------------------------------------
+-module(test_server_sup).
+-export([timetrap/2, timetrap/3, timetrap/4,
+ timetrap_cancel/1, capture_get/1, messages_get/1,
+ timecall/3, call_crash/5, app_test/2, check_new_crash_dumps/0,
+ cleanup_crash_dumps/0, crash_dump_dir/0, tar_crash_dumps/0,
+ get_username/0, get_os_family/0,
+ hostatom/0, hostatom/1, hoststr/0, hoststr/1,
+ framework_call/2,framework_call/3,framework_call/4,
+ format_loc/1,
+ util_start/0, util_stop/0, unique_name/0,
+ call_trace/1,
+ appup_test/1]).
+-include("test_server_internal.hrl").
+-define(crash_dump_tar,"crash_dumps.tar.gz").
+-define(src_listing_ext, ".src.html").
+-record(util_state, {starter, latest_name}).
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% timetrap(Timeout,Scale,Pid) -> Handle
+%% Handle = term()
+%%
+%% Creates a time trap, that will kill the given process if the
+%% trap is not cancelled with timetrap_cancel/1, within Timeout
+%% milliseconds.
+%% Scale says if the time should be scaled up to compensate for
+%% delays during the test (e.g. if cover is running).
+
+timetrap(Timeout0, Pid) ->
+ timetrap(Timeout0, Timeout0, true, Pid).
+
+timetrap(Timeout0, Scale, Pid) ->
+ timetrap(Timeout0, Timeout0, Scale, Pid).
+
+timetrap(Timeout0, ReportTVal, Scale, Pid) ->
+ process_flag(priority, max),
+ Timeout = if not Scale -> Timeout0;
+ true -> test_server:timetrap_scale_factor() * Timeout0
+ end,
+ TruncTO = trunc(Timeout),
+ receive
+ after TruncTO ->
+ kill_the_process(Pid, Timeout0, TruncTO, ReportTVal)
+ end.
+
+kill_the_process(Pid, Timeout0, TruncTO, ReportTVal) ->
+ case is_process_alive(Pid) of
+ true ->
+ TimeToReport = if Timeout0 == ReportTVal -> TruncTO;
+ true -> ReportTVal end,
+ MFLs = test_server:get_loc(Pid),
+ Mon = erlang:monitor(process, Pid),
+ Trap = {timetrap_timeout,TimeToReport,MFLs},
+ exit(Pid, Trap),
+ receive
+ {'DOWN', Mon, process, Pid, _} ->
+ ok
+ after 10000 ->
+ %% Pid is probably trapping exits, hit it harder...
+ catch error_logger:warning_msg(
+ "Testcase process ~w not "
+ "responding to timetrap "
+ "timeout:~n"
+ " ~p.~n"
+ "Killing testcase...~n",
+ [Pid, Trap]),
+ exit(Pid, kill)
+ end;
+ false ->
+ ok
+ end.
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% timetrap_cancel(Handle) -> ok
+%% Handle = term()
+%%
+%% Cancels a time trap.
+timetrap_cancel(Handle) ->
+ unlink(Handle),
+ MonRef = erlang:monitor(process, Handle),
+ exit(Handle, kill),
+ receive {'DOWN',MonRef,_,_,_} -> ok
+ after
+ 2000 ->
+ erlang:demonitor(MonRef, [flush]),
+ ok
+ end.
+
+capture_get(Msgs) ->
+ receive
+ {captured,Msg} ->
+ capture_get([Msg|Msgs])
+ after 0 ->
+ lists:reverse(Msgs)
+ end.
+
+messages_get(Msgs) ->
+ receive
+ Msg ->
+ messages_get([Msg|Msgs])
+ after 0 ->
+ lists:reverse(Msgs)
+ end.
+
+timecall(M, F, A) ->
+ {Elapsed, Val} = timer:tc(M, F, A),
+ {Elapsed / 1000000, Val}.
+
+
+call_crash(Time,Crash,M,F,A) ->
+ OldTrapExit = process_flag(trap_exit,true),
+ Pid = spawn_link(M,F,A),
+ Answer =
+ receive
+ {'EXIT',Crash} ->
+ ok;
+ {'EXIT',Pid,Crash} ->
+ ok;
+ {'EXIT',_Reason} when Crash==any ->
+ ok;
+ {'EXIT',Pid,_Reason} when Crash==any ->
+ ok;
+ {'EXIT',Reason} ->
+ test_server:format(12, "Wrong crash reason. Wanted ~p, got ~p.",
+ [Crash, Reason]),
+ exit({wrong_crash_reason,Reason});
+ {'EXIT',Pid,Reason} ->
+ test_server:format(12, "Wrong crash reason. Wanted ~p, got ~p.",
+ [Crash, Reason]),
+ exit({wrong_crash_reason,Reason});
+ {'EXIT',OtherPid,Reason} when OldTrapExit == false ->
+ exit({'EXIT',OtherPid,Reason})
+ after do_trunc(Time) ->
+ exit(call_crash_timeout)
+ end,
+ process_flag(trap_exit,OldTrapExit),
+ Answer.
+
+do_trunc(infinity) -> infinity;
+do_trunc(T) -> trunc(T).
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% app_test/2
+%%
+%% Checks one applications .app file for obvious errors.
+%% Checks..
+%% * .. required fields
+%% * .. that all modules specified actually exists
+%% * .. that all requires applications exists
+%% * .. that no module included in the application has export_all
+%% * .. that all modules in the ebin/ dir is included
+%% (This only produce a warning, as all modules does not
+%% have to be included (If the `pedantic' option isn't used))
+app_test(Application, Mode) ->
+ case is_app(Application) of
+ {ok, AppFile} ->
+ do_app_tests(AppFile, Application, Mode);
+ Error ->
+ test_server:fail(Error)
+ end.
+
+is_app(Application) ->
+ case file:consult(filename:join([code:lib_dir(Application),"ebin",
+ atom_to_list(Application)++".app"])) of
+ {ok, [{application, Application, AppFile}] } ->
+ {ok, AppFile};
+ _ ->
+ test_server:format(minor,
+ "Application (.app) file not found, "
+ "or it has very bad syntax.~n"),
+ {error, not_an_application}
+ end.
+
+
+do_app_tests(AppFile, AppName, Mode) ->
+ DictList=
+ [
+ {missing_fields, []},
+ {missing_mods, []},
+ {superfluous_mods_in_ebin, []},
+ {export_all_mods, []},
+ {missing_apps, []}
+ ],
+ fill_dictionary(DictList),
+
+ %% An appfile must (?) have some fields..
+ check_fields([description, modules, registered, applications], AppFile),
+
+ %% Check for missing and extra modules.
+ {value, {modules, Mods}}=lists:keysearch(modules, 1, AppFile),
+ EBinList=lists:sort(get_ebin_modnames(AppName)),
+ {Missing, Extra} = common(lists:sort(Mods), EBinList),
+ put(superfluous_mods_in_ebin, Extra),
+ put(missing_mods, Missing),
+
+ %% Check that no modules in the application has export_all.
+ app_check_export_all(Mods),
+
+ %% Check that all specified applications exists.
+ {value, {applications, Apps}}=
+ lists:keysearch(applications, 1, AppFile),
+ check_apps(Apps),
+
+ A=check_dict(missing_fields, "Inconsistent app file, "
+ "missing fields"),
+ B=check_dict(missing_mods, "Inconsistent app file, "
+ "missing modules"),
+ C=check_dict_tolerant(superfluous_mods_in_ebin, "Inconsistent app file, "
+ "Modules not included in app file.", Mode),
+ D=check_dict(export_all_mods, "Inconsistent app file, "
+ "Modules have `export_all'."),
+ E=check_dict(missing_apps, "Inconsistent app file, "
+ "missing applications."),
+
+ erase_dictionary(DictList),
+ case A+B+C+D+E of
+ 5 ->
+ ok;
+ _ ->
+ test_server:fail()
+ end.
+
+app_check_export_all([]) ->
+ ok;
+app_check_export_all([Mod|Mods]) ->
+ case catch apply(Mod, module_info, [compile]) of
+ {'EXIT', {undef,_}} ->
+ app_check_export_all(Mods);
+ COpts ->
+ case lists:keysearch(options, 1, COpts) of
+ false ->
+ app_check_export_all(Mods);
+ {value, {options, List}} ->
+ case lists:member(export_all, List) of
+ true ->
+ put(export_all_mods, [Mod|get(export_all_mods)]),
+ app_check_export_all(Mods);
+ false ->
+ app_check_export_all(Mods)
+ end
+ end
+ end.
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% appup_test/1
+%%
+%% Checks one applications .appup file for obvious errors.
+%% Checks..
+%% * .. syntax
+%% * .. that version in app file matches appup file version
+%% * .. validity of appup instructions
+%%
+%% For library application this function checks that the proper
+%% 'restart_application' upgrade and downgrade clauses exist.
+appup_test(Application) ->
+ case is_app(Application) of
+ {ok, AppFile} ->
+ case is_appup(Application, proplists:get_value(vsn, AppFile)) of
+ {ok, Up, Down} ->
+ StartMod = proplists:get_value(mod, AppFile),
+ Modules = proplists:get_value(modules, AppFile),
+ do_appup_tests(StartMod, Application, Up, Down, Modules);
+ Error ->
+ test_server:fail(Error)
+ end;
+ Error ->
+ test_server:fail(Error)
+ end.
+
+is_appup(Application, Version) ->
+ AppupFile = atom_to_list(Application) ++ ".appup",
+ AppupPath = filename:join([code:lib_dir(Application), "ebin", AppupFile]),
+ case file:consult(AppupPath) of
+ {ok, [{Version, Up, Down}]} when is_list(Up), is_list(Down) ->
+ {ok, Up, Down};
+ _ ->
+ test_server:format(
+ minor,
+ "Application upgrade (.appup) file not found, "
+ "or it has very bad syntax.~n"),
+ {error, appup_not_readable}
+ end.
+
+do_appup_tests(undefined, Application, Up, Down, _Modules) ->
+ %% library application
+ case Up of
+ [{<<".*">>, [{restart_application, Application}]}] ->
+ case Down of
+ [{<<".*">>, [{restart_application, Application}]}] ->
+ ok;
+ _ ->
+ test_server:format(
+ minor,
+ "Library application needs restart_application "
+ "downgrade instruction.~n"),
+ {error, library_downgrade_instruction_malformed}
+ end;
+ _ ->
+ test_server:format(
+ minor,
+ "Library application needs restart_application "
+ "upgrade instruction.~n"),
+ {error, library_upgrade_instruction_malformed}
+ end;
+do_appup_tests(_, _Application, Up, Down, Modules) ->
+ %% normal application
+ case check_appup_clauses_plausible(Up, up, Modules) of
+ ok ->
+ case check_appup_clauses_plausible(Down, down, Modules) of
+ ok ->
+ test_server:format(minor, "OK~n");
+ Error ->
+ test_server:format(minor, "ERROR ~p~n", [Error]),
+ test_server:fail(Error)
+ end;
+ Error ->
+ test_server:format(minor, "ERROR ~p~n", [Error]),
+ test_server:fail(Error)
+ end.
+
+check_appup_clauses_plausible([], _Direction, _Modules) ->
+ ok;
+check_appup_clauses_plausible([{Re, Instrs} | Rest], Direction, Modules)
+ when is_binary(Re) ->
+ case re:compile(Re) of
+ {ok, _} ->
+ case check_appup_instructions(Instrs, Direction, Modules) of
+ ok ->
+ check_appup_clauses_plausible(Rest, Direction, Modules);
+ Error ->
+ Error
+ end;
+ {error, Error} ->
+ {error, {version_regex_malformed, Re, Error}}
+ end;
+check_appup_clauses_plausible([{V, Instrs} | Rest], Direction, Modules)
+ when is_list(V) ->
+ case check_appup_instructions(Instrs, Direction, Modules) of
+ ok ->
+ check_appup_clauses_plausible(Rest, Direction, Modules);
+ Error ->
+ Error
+ end;
+check_appup_clauses_plausible(Clause, _Direction, _Modules) ->
+ {error, {clause_malformed, Clause}}.
+
+check_appup_instructions(Instrs, Direction, Modules) ->
+ case check_instructions(Direction, Instrs, Instrs, [], [], Modules) of
+ {_Good, []} ->
+ ok;
+ {_, Bad} ->
+ {error, {bad_instructions, Bad}}
+ end.
+
+check_instructions(_, [], _, Good, Bad, _) ->
+ {lists:reverse(Good), lists:reverse(Bad)};
+check_instructions(UpDown, [Instr | Rest], All, Good, Bad, Modules) ->
+ case catch check_instruction(UpDown, Instr, All, Modules) of
+ ok ->
+ check_instructions(UpDown, Rest, All, [Instr | Good], Bad, Modules);
+ {error, Reason} ->
+ NewBad = [{Instr, Reason} | Bad],
+ check_instructions(UpDown, Rest, All, Good, NewBad, Modules)
+ end.
+
+check_instruction(up, {add_module, Module}, _, Modules) ->
+ %% A new module is added
+ check_module(Module, Modules);
+check_instruction(down, {add_module, Module}, _, Modules) ->
+ %% An old module is re-added
+ case (catch check_module(Module, Modules)) of
+ {error, {unknown_module, Module, Modules}} -> ok;
+ ok -> throw({error, {existing_readded_module, Module}})
+ end;
+check_instruction(_, {load_module, Module}, _, Modules) ->
+ check_module(Module, Modules);
+check_instruction(_, {load_module, Module, DepMods}, _, Modules) ->
+ check_module(Module, Modules),
+ check_depend(DepMods);
+check_instruction(_, {load_module, Module, Pre, Post, DepMods}, _, Modules) ->
+ check_module(Module, Modules),
+ check_depend(DepMods),
+ check_purge(Pre),
+ check_purge(Post);
+check_instruction(up, {delete_module, Module}, _, Modules) ->
+ case (catch check_module(Module, Modules)) of
+ {error, {unknown_module, Module, Modules}} ->
+ ok;
+ ok ->
+ throw({error,{existing_module_deleted, Module}})
+ end;
+check_instruction(down, {delete_module, Module}, _, Modules) ->
+ check_module(Module, Modules);
+check_instruction(_, {update, Module}, _, Modules) ->
+ check_module(Module, Modules);
+check_instruction(_, {update, Module, supervisor}, _, Modules) ->
+ check_module(Module, Modules);
+check_instruction(_, {update, Module, DepMods}, _, Modules)
+ when is_list(DepMods) ->
+ check_module(Module, Modules);
+check_instruction(_, {update, Module, Change}, _, Modules) ->
+ check_module(Module, Modules),
+ check_change(Change);
+check_instruction(_, {update, Module, Change, DepMods}, _, Modules) ->
+ check_module(Module, Modules),
+ check_change(Change),
+ check_depend(DepMods);
+check_instruction(_, {update, Module, Change, Pre, Post, DepMods}, _, Modules) ->
+ check_module(Module, Modules),
+ check_change(Change),
+ check_purge(Pre),
+ check_purge(Post),
+ check_depend(DepMods);
+check_instruction(_,
+ {update, Module, Timeout, Change, Pre, Post, DepMods},
+ _,
+ Modules) ->
+ check_module(Module, Modules),
+ check_timeout(Timeout),
+ check_change(Change),
+ check_purge(Pre),
+ check_purge(Post),
+ check_depend(DepMods);
+check_instruction(_,
+ {update, Module, ModType, Timeout, Change, Pre, Post, DepMods},
+ _,
+ Modules) ->
+ check_module(Module, Modules),
+ check_mod_type(ModType),
+ check_timeout(Timeout),
+ check_change(Change),
+ check_purge(Pre),
+ check_purge(Post),
+ check_depend(DepMods);
+check_instruction(_, {restart_application, Application}, _, _) ->
+ check_application(Application);
+check_instruction(_, {remove_application, Application}, _, _) ->
+ check_application(Application);
+check_instruction(_, {add_application, Application}, _, _) ->
+ check_application(Application);
+check_instruction(_, {add_application, Application, Type}, _, _) ->
+ check_application(Application),
+ check_restart_type(Type);
+check_instruction(_, Instr, _, _) ->
+ throw({error, {low_level_or_invalid_instruction, Instr}}).
+
+check_module(Module, Modules) ->
+ case {is_atom(Module), lists:member(Module, Modules)} of
+ {true, true} -> ok;
+ {true, false} -> throw({error, {unknown_module, Module}});
+ {false, _} -> throw({error, {bad_module, Module}})
+ end.
+
+check_application(App) ->
+ case is_atom(App) of
+ true -> ok;
+ false -> throw({error, {bad_application, App}})
+ end.
+
+check_depend(Dep) when is_list(Dep) -> ok;
+check_depend(Dep) -> throw({error, {bad_depend, Dep}}).
+
+check_restart_type(permanent) -> ok;
+check_restart_type(transient) -> ok;
+check_restart_type(temporary) -> ok;
+check_restart_type(load) -> ok;
+check_restart_type(none) -> ok;
+check_restart_type(Type) -> throw({error, {bad_restart_type, Type}}).
+
+check_timeout(T) when is_integer(T), T > 0 -> ok;
+check_timeout(default) -> ok;
+check_timeout(infinity) -> ok;
+check_timeout(T) -> throw({error, {bad_timeout, T}}).
+
+check_mod_type(static) -> ok;
+check_mod_type(dynamic) -> ok;
+check_mod_type(Type) -> throw({error, {bad_mod_type, Type}}).
+
+check_purge(soft_purge) -> ok;
+check_purge(brutal_purge) -> ok;
+check_purge(Purge) -> throw({error, {bad_purge, Purge}}).
+
+check_change(soft) -> ok;
+check_change({advanced, _}) -> ok;
+check_change(Change) -> throw({error, {bad_change, Change}}).
+
+%% Given two sorted lists, L1 and L2, returns {NotInL2, NotInL1},
+%% NotInL2 is the elements of L1 which don't occurr in L2,
+%% NotInL1 is the elements of L2 which don't ocurr in L1.
+
+common(L1, L2) ->
+ common(L1, L2, [], []).
+
+common([X|Rest1], [X|Rest2], A1, A2) ->
+ common(Rest1, Rest2, A1, A2);
+common([X|Rest1], [Y|Rest2], A1, A2) when X < Y ->
+ common(Rest1, [Y|Rest2], [X|A1], A2);
+common([X|Rest1], [Y|Rest2], A1, A2) ->
+ common([X|Rest1], Rest2, A1, [Y|A2]);
+common([], L, A1, A2) ->
+ {A1, L++A2};
+common(L, [], A1, A2) ->
+ {L++A1, A2}.
+
+check_apps([]) ->
+ ok;
+check_apps([App|Apps]) ->
+ case is_app(App) of
+ {ok, _AppFile} ->
+ ok;
+ {error, _} ->
+ put(missing_apps, [App|get(missing_apps)])
+ end,
+ check_apps(Apps).
+
+check_fields([], _AppFile) ->
+ ok;
+check_fields([L|Ls], AppFile) ->
+ check_field(L, AppFile),
+ check_fields(Ls, AppFile).
+
+check_field(FieldName, AppFile) ->
+ case lists:keymember(FieldName, 1, AppFile) of
+ true ->
+ ok;
+ false ->
+ put(missing_fields, [FieldName|get(missing_fields)]),
+ ok
+ end.
+
+check_dict(Dict, Reason) ->
+ case get(Dict) of
+ [] ->
+ 1; % All ok.
+ List ->
+ io:format("** ~ts (~ts) ->~n~p~n",[Reason, Dict, List]),
+ 0
+ end.
+
+check_dict_tolerant(Dict, Reason, Mode) ->
+ case get(Dict) of
+ [] ->
+ 1; % All ok.
+ List ->
+ io:format("** ~ts (~ts) ->~n~p~n",[Reason, Dict, List]),
+ case Mode of
+ pedantic ->
+ 0;
+ _ ->
+ 1
+ end
+ end.
+
+get_ebin_modnames(AppName) ->
+ Wc=filename:join([code:lib_dir(AppName),"ebin",
+ "*"++code:objfile_extension()]),
+ TheFun=fun(X, Acc) ->
+ [list_to_atom(filename:rootname(
+ filename:basename(X)))|Acc] end,
+ _Files=lists:foldl(TheFun, [], filelib:wildcard(Wc)).
+
+%%
+%% This function removes any erl_crash_dump* files found in the
+%% test server directory. Done only once when the test server
+%% is started.
+%%
+cleanup_crash_dumps() ->
+ Dir = crash_dump_dir(),
+ Dumps = filelib:wildcard(filename:join(Dir, "erl_crash_dump*")),
+ delete_files(Dumps).
+
+crash_dump_dir() ->
+ %% If no framework is known, then we use current working directory
+ %% - in most cases that will be the same as the default log
+ %% directory.
+ {ok,Dir} = test_server_sup:framework_call(get_log_dir,[],file:get_cwd()),
+ Dir.
+
+tar_crash_dumps() ->
+ Dir = crash_dump_dir(),
+ case filelib:wildcard(filename:join(Dir, "erl_crash_dump*")) of
+ [] -> {error,no_crash_dumps};
+ Dumps ->
+ TarFileName = filename:join(Dir,?crash_dump_tar),
+ {ok,Tar} = erl_tar:open(TarFileName,[write,compressed]),
+ lists:foreach(
+ fun(File) ->
+ ok = erl_tar:add(Tar,File,filename:basename(File),[])
+ end,
+ Dumps),
+ ok = erl_tar:close(Tar),
+ delete_files(Dumps),
+ {ok,TarFileName}
+ end.
+
+
+check_new_crash_dumps() ->
+ Dir = crash_dump_dir(),
+ Dumps = filelib:wildcard(filename:join(Dir, "erl_crash_dump*")),
+ case length(Dumps) of
+ 0 ->
+ ok;
+ Num ->
+ test_server_ctrl:format(minor,
+ "Found ~w crash dumps:~n", [Num]),
+ append_files_to_logfile(Dumps),
+ delete_files(Dumps)
+ end.
+
+append_files_to_logfile([]) -> ok;
+append_files_to_logfile([File|Files]) ->
+ NodeName=from($., File),
+ test_server_ctrl:format(minor, "Crash dump from node ~tp:~n",[NodeName]),
+ Fd=get(test_server_minor_fd),
+ case file:read_file(File) of
+ {ok, Bin} ->
+ case file:write(Fd, Bin) of
+ ok ->
+ ok;
+ {error,Error} ->
+ %% Write failed. The following io:format/3 will probably also
+ %% fail, but in that case it will throw an exception so that
+ %% we will be aware of the problem.
+ io:format(Fd, "Unable to write the crash dump "
+ "to this file: ~p~n", [file:format_error(Error)])
+ end;
+ _Error ->
+ io:format(Fd, "Failed to read: ~ts\n", [File])
+ end,
+ append_files_to_logfile(Files).
+
+delete_files([]) -> ok;
+delete_files([File|Files]) ->
+ io:format("Deleting file: ~ts~n", [File]),
+ case file:delete(File) of
+ {error, _} ->
+ case file:rename(File, File++".old") of
+ {error, Error} ->
+ io:format("Could neither delete nor rename file "
+ "~ts: ~ts.~n", [File, Error]);
+ _ ->
+ ok
+ end;
+ _ ->
+ ok
+ end,
+ delete_files(Files).
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% erase_dictionary(Vars) -> ok
+%% Vars = [atom(),...]
+%%
+%% Takes a list of dictionary keys, KeyVals, erases
+%% each key and returns ok.
+erase_dictionary([{Var, _Val}|Vars]) ->
+ erase(Var),
+ erase_dictionary(Vars);
+erase_dictionary([]) ->
+ ok.
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% fill_dictionary(KeyVals) -> void()
+%% KeyVals = [{atom(),term()},...]
+%%
+%% Takes each Key-Value pair, and inserts it in the process dictionary.
+fill_dictionary([{Var,Val}|Vars]) ->
+ put(Var,Val),
+ fill_dictionary(Vars);
+fill_dictionary([]) ->
+ [].
+
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% get_username() -> UserName
+%%
+%% Returns the current user
+get_username() ->
+ getenv_any(["USER","USERNAME"]).
+
+getenv_any([Key|Rest]) ->
+ case catch os:getenv(Key) of
+ String when is_list(String) -> String;
+ false -> getenv_any(Rest)
+ end;
+getenv_any([]) -> "".
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% get_os_family() -> OsFamily
+%%
+%% Returns the OS family
+get_os_family() ->
+ {OsFamily,_OsName} = os:type(),
+ OsFamily.
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% hostatom()/hostatom(Node) -> Host; atom()
+%% hoststr() | hoststr(Node) -> Host; string()
+%%
+%% Returns the OS family
+hostatom() ->
+ hostatom(node()).
+hostatom(Node) ->
+ list_to_atom(hoststr(Node)).
+hoststr() ->
+ hoststr(node()).
+hoststr(Node) when is_atom(Node) ->
+ hoststr(atom_to_list(Node));
+hoststr(Node) when is_list(Node) ->
+ from($@, Node).
+
+from(H, [H | T]) -> T;
+from(H, [_ | T]) -> from(H, T);
+from(_H, []) -> [].
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% framework_call(Callback,Func,Args,DefaultReturn) -> Return | DefaultReturn
+%%
+%% Calls the given Func in Callback
+framework_call(Func,Args) ->
+ framework_call(Func,Args,ok).
+framework_call(Func,Args,DefaultReturn) ->
+ CB = os:getenv("TEST_SERVER_FRAMEWORK"),
+ framework_call(CB,Func,Args,DefaultReturn).
+framework_call(FW,_Func,_Args,DefaultReturn)
+ when FW =:= false; FW =:= "undefined" ->
+ DefaultReturn;
+framework_call(Callback,Func,Args,DefaultReturn) ->
+ Mod = list_to_atom(Callback),
+ case code:is_loaded(Mod) of
+ false -> code:load_file(Mod);
+ _ -> ok
+ end,
+ case erlang:function_exported(Mod,Func,length(Args)) of
+ true ->
+ EH = fun(Reason) -> exit({fw_error,{Mod,Func,Reason}}) end,
+ SetTcState = case Func of
+ end_tc -> true;
+ init_tc -> true;
+ _ -> false
+ end,
+ case SetTcState of
+ true ->
+ test_server:set_tc_state({framework,Mod,Func});
+ false ->
+ ok
+ end,
+ try apply(Mod,Func,Args) of
+ Result ->
+ Result
+ catch
+ exit:Why ->
+ EH(Why);
+ error:Why ->
+ EH({Why,erlang:get_stacktrace()});
+ throw:Why ->
+ EH(Why)
+ end;
+ false ->
+ DefaultReturn
+ end.
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% format_loc(Loc) -> string()
+%%
+%% Formats the printout of the line of code read from
+%% process dictionary (test_server_loc). Adds link to
+%% correct line in source code.
+format_loc([{Mod,Func,Line}]) ->
+ [format_loc1({Mod,Func,Line})];
+format_loc([{Mod,Func,Line}|Rest]) ->
+ ["[",format_loc1({Mod,Func,Line}),",\n"|format_loc1(Rest)];
+format_loc([{Mod,LineOrFunc}]) ->
+ format_loc({Mod,LineOrFunc});
+format_loc({Mod,Func}) when is_atom(Func) ->
+ io_lib:format("{~w,~w}",[Mod,Func]);
+format_loc(Loc) ->
+ io_lib:format("~p",[Loc]).
+
+format_loc1([{Mod,Func,Line}]) ->
+ [" ",format_loc1({Mod,Func,Line}),"]"];
+format_loc1([{Mod,Func,Line}|Rest]) ->
+ [" ",format_loc1({Mod,Func,Line}),",\n"|format_loc1(Rest)];
+format_loc1({Mod,Func,Line}) ->
+ ModStr = atom_to_list(Mod),
+ case {lists:member(no_src, get(test_server_logopts)),
+ lists:reverse(ModStr)} of
+ {false,[$E,$T,$I,$U,$S,$_|_]} ->
+ Link = if is_integer(Line) ->
+ integer_to_list(Line);
+ Line == last_expr ->
+ list_to_atom(atom_to_list(Func)++"-last_expr");
+ is_atom(Line) ->
+ atom_to_list(Line);
+ true ->
+ Line
+ end,
+ io_lib:format("{~w,~w,<a href=\"~ts~ts#~s\">~w</a>}",
+ [Mod,Func,
+ test_server_ctrl:uri_encode(downcase(ModStr)),
+ ?src_listing_ext,Link,Line]);
+ _ ->
+ io_lib:format("{~w,~w,~w}",[Mod,Func,Line])
+ end.
+
+downcase(S) -> downcase(S, []).
+downcase([Uc|Rest], Result) when $A =< Uc, Uc =< $Z ->
+ downcase(Rest, [Uc-$A+$a|Result]);
+downcase([C|Rest], Result) ->
+ downcase(Rest, [C|Result]);
+downcase([], Result) ->
+ lists:reverse(Result).
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% util_start() -> ok
+%%
+%% Start local utility process
+util_start() ->
+ Starter = self(),
+ case whereis(?MODULE) of
+ undefined ->
+ spawn_link(fun() ->
+ register(?MODULE, self()),
+ util_loop(#util_state{starter=Starter})
+ end);
+ _Pid ->
+ ok
+ end.
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% util_stop() -> ok
+%%
+%% Stop local utility process
+util_stop() ->
+ try (?MODULE ! {self(),stop}) of
+ _ ->
+ receive {?MODULE,stopped} -> ok
+ after 5000 -> exit(whereis(?MODULE), kill)
+ end
+ catch
+ _:_ ->
+ ok
+ end.
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% unique_name() -> string()
+%%
+unique_name() ->
+ ?MODULE ! {self(),unique_name},
+ receive {?MODULE,Name} -> Name
+ after 5000 -> exit({?MODULE,no_util_process})
+ end.
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% util_loop(State) -> ok
+%%
+util_loop(State) ->
+ receive
+ {From,unique_name} ->
+ Nr = erlang:unique_integer([positive]),
+ Name = integer_to_list(Nr),
+ if Name == State#util_state.latest_name ->
+ timer:sleep(1),
+ self() ! {From,unique_name},
+ util_loop(State);
+ true ->
+ From ! {?MODULE,Name},
+ util_loop(State#util_state{latest_name = Name})
+ end;
+ {From,stop} ->
+ catch unlink(State#util_state.starter),
+ From ! {?MODULE,stopped},
+ ok
+ end.
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% call_trace(TraceSpecFile) -> ok
+%%
+%% Read terms on format {m,Mod} | {f,Mod,Func}
+%% from TraceSpecFile and enable call trace for
+%% specified functions.
+call_trace(TraceSpec) ->
+ case catch try_call_trace(TraceSpec) of
+ {'EXIT',Reason} ->
+ erlang:display(Reason),
+ exit(Reason);
+ Ok ->
+ Ok
+ end.
+
+try_call_trace(TraceSpec) ->
+ case file:consult(TraceSpec) of
+ {ok,Terms} ->
+ dbg:tracer(),
+ %% dbg:p(self(), [p, m, sos, call]),
+ dbg:p(self(), [sos, call]),
+ lists:foreach(fun({m,M}) ->
+ case dbg:tpl(M,[{'_',[],[{return_trace}]}]) of
+ {error,What} -> exit({error,{tracing_failed,What}});
+ _ -> ok
+ end;
+ ({f,M,F}) ->
+ case dbg:tpl(M,F,[{'_',[],[{return_trace}]}]) of
+ {error,What} -> exit({error,{tracing_failed,What}});
+ _ -> ok
+ end;
+ (Huh) ->
+ exit({error,{unrecognized_trace_term,Huh}})
+ end, Terms),
+ ok;
+ {_,Error} ->
+ exit({error,{tracing_failed,TraceSpec,Error}})
+ end.
+
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-08 02:37:54 +0000