aboutsummaryrefslogtreecommitdiffstats
path: root/lib/test_server/src/test_server.erl
diff options
context:
space:
mode:
Diffstat (limited to 'lib/test_server/src/test_server.erl')
-rw-r--r--lib/test_server/src/test_server.erl2655
1 files changed, 0 insertions, 2655 deletions
diff --git a/lib/test_server/src/test_server.erl b/lib/test_server/src/test_server.erl
deleted file mode 100644
index da6bf491ac..0000000000
--- a/lib/test_server/src/test_server.erl
+++ /dev/null
@@ -1,2655 +0,0 @@
-%%
-%% %CopyrightBegin%
-%%
-%% Copyright Ericsson AB 1996-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%
--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(),
- TestServerDir = filename:absname(filename:dirname(code:which(?MODULE))),
- #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(),
- test_server_dir=TestServerDir,
- 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(
- fun() ->
- run_test_case_eval(Mod, Func, Args, Name, Ref,
- RunInit, TimetrapData,
- LogOpts, TCCallback)
- end),
- 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,Conf,TVal)
- end.
-
-do_call_end_conf(Starter,Mod,Func,Data,Conf,TVal) ->
- EndConfProc =
- fun() ->
- process_flag(trap_exit,true), % to catch timetraps
- Supervisor = self(),
- EndConfApply =
- fun() ->
- timetrap(TVal),
- try apply(Mod,end_per_testcase,[Func,Conf]) of
- _ -> ok
- catch
- _:Why ->
- timer:sleep(1),
- group_leader() ! {printout,12,
- "WARNING! "
- "~w:end_per_testcase(~w, ~p)"
- " crashed!\n\tReason: ~p\n",
- [Mod,Func,Conf,Why]}
- end,
- Supervisor ! {self(),end_conf}
- end,
- Pid = spawn_link(EndConfApply),
- receive
- {Pid,end_conf} ->
- Starter ! {self(),{call_end_conf,Data,ok}};
- {'EXIT',Pid,Reason} ->
- group_leader() ! {printout,12,
- "WARNING! ~w:end_per_testcase(~w, ~p)"
- " failed!\n\tReason: ~p\n",
- [Mod,Func,Conf,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).
-
-spawn_fw_call(Mod,{init_per_testcase,Func},CurrConf,Pid,
- {timetrap_timeout,TVal}=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 do_end_tc_call(Mod,Func, {Pid,Skip,[CurrConf]}, Why) of
- _ -> ok
- catch
- _:FwEndTCErr ->
- exit({fw_notify_done,end_tc,FwEndTCErr})
- end,
- %% finished, report back
- SendTo ! {self(),fw_notify_done,
- {TVal/1000,Skip,Loc,[],undefined}}
- end,
- spawn_link(FwCall);
-
-spawn_fw_call(Mod,{end_per_testcase,Func},EndConf,Pid,
- {timetrap_timeout,TVal}=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,
- group_leader() ! {printout,12,
- "WARNING! ~w:end_per_testcase(~w, ~p)"
- " failed!\n\tReason: timetrap timeout"
- " after ~w ms!\n", [Mod,Func,EndConf,TVal]},
- FailLoc = proplists:get_value(tc_fail_loc, EndConf),
- try do_end_tc_call(Mod,Func,
- {Pid,Report,[EndConf]}, Why) of
- _ -> ok
- catch
- _:FwEndTCErr ->
- exit({fw_notify_done,end_tc,FwEndTCErr})
- end,
- Warn = "<font color=\"red\">"
- "WARNING: end_per_testcase timed out!</font>",
- %% finished, report back (if end_per_testcase fails, a warning
- %% should be printed as part of the comment)
- SendTo ! {self(),fw_notify_done,
- {TVal/1000,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 = case Func of
- {_InitOrEndPerTC,F} -> F;
- F -> F
- 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,Func1,
- {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().
-
-%% 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),
-
- FWInitResult = test_server_sup:framework_call(init_tc,[Mod,Func,Args0],
- {ok,Args0}),
- set_tc_state(running),
- {{Time,Value},Loc,Opts} =
- case FWInitResult of
- {ok,Args} ->
- run_test_case_eval1(Mod, Func, Args, Name, RunInit, TCCallback);
- Error = {error,_Reason} ->
- NewResult = do_end_tc_call(Mod,Func, {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,Func, {{error,Reason},[Conf]},
- {fail,Reason}),
- {{0,NewResult},Where,[]};
- Skip = {SkipType,_Reason} when SkipType == skip;
- SkipType == skipped ->
- NewResult = do_end_tc_call(Mod,Func,
- {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,Func, {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,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,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,Func,
- {{error,Reason},[EndConf]},
- FailTC),
- {{0,NewRes},[{Mod,Func}],[]};
- {ok,NewConf} ->
- %% call user callback function if defined
- NewConf1 =
- user_callback(TCCallback, Mod, Func, init, NewConf),
- %% save current state in controller loop
- set_tc_state(tc, NewConf1),
- %% execute the test case
- {{T,Return},Loc} = {ts_tc(Mod,Func,[NewConf1]), get_loc()},
- {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),
- %% update current state in controller loop
- {FWReturn1,TSReturn1,EndConf2} =
- case end_per_testcase(Mod, Func, EndConf1) of
- SaveCfg1={save_config,_} ->
- {FWReturn,TSReturn,
- [SaveCfg1|lists:keydelete(save_config,1,
- EndConf1)]};
- {fail,ReasonToFail} ->
- %% user has failed the testcase
- fw_error_notify(Mod, Func, EndConf1,
- ReasonToFail),
- {{error,ReasonToFail},
- {failed,ReasonToFail},
- EndConf1};
- {failed,{_,end_per_testcase,_}} = Failure when
- FWReturn == ok ->
- %% unexpected termination in end_per_testcase
- %% report this as the result to the framework
- {Failure,TSReturn,EndConf1};
- _ ->
- %% test case result should be reported to
- %% framework no matter the status of
- %% end_per_testcase
- {FWReturn,TSReturn,EndConf1}
- end,
- %% clear current state in controller loop
- case do_end_tc_call(Mod,Func,
- {FWReturn1,[EndConf2]}, TSReturn1) of
- {failed,Reason} = NewReturn ->
- fw_error_notify(Mod,Func,EndConf2, 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_end_tc_call(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: ~p\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(),
- FormattedLoc = test_server_sup:format_loc(Line),
- group_leader() ! {printout,12,
- "ERROR! init_per_testcase thrown!\n"
- "\tLocation: ~ts\n\tReason: ~p\n",
- [FormattedLoc, Other]},
- {skip,{failed,{Mod,init_per_testcase,Other}}};
- _:Reason0 ->
- Stk = erlang:get_stacktrace(),
- Reason = {Reason0,Stk},
- set_loc(Stk),
- Line = get_loc(),
- FormattedLoc = test_server_sup:format_loc(Line),
- group_leader() ! {printout,12,
- "ERROR! init_per_testcase crashed!\n"
- "\tLocation: ~ts\n\tReason: ~p\n",
- [FormattedLoc,Reason]},
- {skip,{failed,{Mod,init_per_testcase,Reason}}}
- end.
-
-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])),
- group_leader() ! {printout,12,
- "WARNING: ~w thrown!\n"
- "Reason: ~p\n"
- "Line: ~ts\n",
- [EndFunc, Other,
- test_server_sup:format_loc(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])),
- group_leader() ! {printout,12,
- "WARNING: ~w crashed!\n"
- "Reason: ~p\n"
- "Line: ~ts\n",
- [EndFunc, Reason,
- test_server_sup:format_loc(get_loc())]},
- {failed,{Mod,end_per_testcase,Why}}
- end.
-
-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,
- fun () ->
- start_job_proxy(),
- receive
- Ref ->
- Master ! {Ref, Fun()}
- end,
- receive after infinity -> infinity end
- end),
- 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.
-
-%% 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.