diff options
Diffstat (limited to 'lib/test_server/src/test_server.erl')
| -rw-r--r-- | lib/test_server/src/test_server.erl | 2203 |
1 files changed, 2203 insertions, 0 deletions
diff --git a/lib/test_server/src/test_server.erl b/lib/test_server/src/test_server.erl new file mode 100644 index 0000000000..99e24205ae --- /dev/null +++ b/lib/test_server/src/test_server.erl @@ -0,0 +1,2203 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1996-2009. All Rights Reserved. +%% +%% The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved online at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% %CopyrightEnd% +%% +-module(test_server). + +-define(DEFAULT_TIMETRAP_SECS, 60). + +%%% START %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +-export([start/1,start/2]). + +%%% 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]). + +%%% 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([hours/1,minutes/1,seconds/1,sleep/1,timecall/3]). +-export([timetrap_scale_factor/0,timetrap/1,timetrap_cancel/1]). +-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]). +-export([is_native/1]). +-export([comment/1]). +-export([os_type/0]). +-export([run_on_shielded_node/2]). +-export([is_cover/0,is_debug/0,is_commercial/0]). + +-export([break/1,continue/0]). + +%%% DEBUGGER INTERFACE %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +-export([purify_new_leaks/0, purify_format/2, purify_new_fds_inuse/0, + purify_is_running/0]). + +%%% PRIVATE EXPORTED %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +-export([]). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +-record(state,{controller,jobs=[]}). + +-include("test_server_internal.hrl"). +-include_lib("kernel/include/file.hrl"). + +-define(pl2a(M), test_server_sup:package_atom(M)). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% **** START *** CODE FOR REMOTE TARGET ONLY *** +%% +%% test_server +%% This process is started only if the test is to be run on a remote target +%% The process is then started on target +%% A socket connection is established with the test_server_ctrl process +%% on host, and information about target is sent to host. +start([ControllerHost]) when is_atom(ControllerHost) -> + start(atom_to_list(ControllerHost)); +start(ControllerHost) when is_list(ControllerHost) -> + start(ControllerHost,?MAIN_PORT). +start(ControllerHost,ControllerPort) -> + S = self(), + Pid = spawn(fun() -> init(ControllerHost,ControllerPort,S) end), + receive {Pid,started} -> {ok,Pid}; + {Pid,Error} -> Error + end. + +init(Host,Port,Starter) -> + global:register_name(?MODULE,self()), + process_flag(trap_exit,true), + test_server_sup:cleanup_crash_dumps(), + case gen_tcp:connect(Host,Port, [binary, + {reuseaddr,true}, + {packet,2}]) of + {ok,MainSock} -> + Starter ! {self(),started}, + request(MainSock,{target_info,init_target_info()}), + loop(#state{controller={Host,MainSock}}); + Error -> + Starter ! {self(),{error, + {could_not_contact_controller,Error}}} + end. + +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())}. + + +loop(#state{controller={_,MainSock}} = State) -> + receive + {tcp, MainSock, <<1,Request/binary>>} -> + State1 = decode_main(binary_to_term(Request),State), + loop(State1); + {tcp_closed, MainSock} -> + gen_tcp:close(MainSock), + halt(); + {'EXIT',Pid,Reason} -> + case lists:keysearch(Pid,1,State#state.jobs) of + {value,{Pid,Name}} -> + case Reason of + normal -> ignore; + _other -> request(MainSock,{job_proc_killed,Name,Reason}) + end, + NewJobs = lists:keydelete(Pid,1,State#state.jobs), + loop(State#state{jobs = NewJobs}); + false -> + loop(State) + end + end. + +%% Decode request on main socket +decode_main({job,Port,Name},#state{controller={Host,_},jobs=Jobs}=State) -> + S = self(), + NewJob = spawn_link(fun() -> job(Host,Port,S) end), + receive {NewJob,started} -> State#state{jobs=[{NewJob,Name}|Jobs]}; + {NewJob,_Error} -> State + end. + +init_purify() -> + purify_new_leaks(). + + +%% Temporary job process on target +%% This process will live while all test cases in the job are executed. +%% A socket connection is established with the job process on host. +job(Host,Port,Starter) -> + process_flag(trap_exit,true), + init_purify(), + case gen_tcp:connect(Host,Port, [binary, + {reuseaddr,true}, + {packet,4}, + {active,false}]) of + {ok,JobSock} -> + Starter ! {self(),started}, + job(JobSock); + Error -> + Starter ! {self(),{error, + {could_not_contact_controller,Error}}} + end. + +job(JobSock) -> + JobDir = get_jobdir(), + ok = file:make_dir(JobDir), + ok = file:make_dir(filename:join(JobDir,?priv_dir)), + put(test_server_job_sock,JobSock), + put(test_server_job_dir,JobDir), + {ok,Cwd} = file:get_cwd(), + job_loop(JobSock), + ok = file:set_cwd(Cwd), + send_privdir(JobDir,JobSock), % also recursively removes jobdir + ok. + + +get_jobdir() -> + Now = now(), + {{Y,M,D},{H,Mi,S}} = calendar:now_to_local_time(Now), + Basename = io_lib:format("~w-~2.2.0w-~2.2.0w_~2.2.0w.~2.2.0w.~2.2.0w_~w", + [Y,M,D,H,Mi,S,element(3,Now)]), + %% if target has a file master, don't use prim_file to look up cwd + case lists:keymember(master,1,init:get_arguments()) of + true -> + {ok,Cwd} = file:get_cwd(), + Cwd ++ "/" ++ Basename; + false -> + filename:absname(Basename) + end. + +send_privdir(JobDir,JobSock) -> + LocalPrivDir = filename:join(JobDir,?priv_dir), + case file:list_dir(LocalPrivDir) of + {ok,List} when List/=[] -> + Tarfile0 = ?priv_dir ++ ".tar.gz", + Tarfile = filename:join(JobDir,Tarfile0), + {ok,Tar} = erl_tar:open(Tarfile,[write,compressed,cooked]), + ok = erl_tar:add(Tar,LocalPrivDir,?priv_dir,[]), + ok = erl_tar:close(Tar), + {ok,TarBin} = file:read_file(Tarfile), + file:delete(Tarfile), + ok = del_dir(JobDir), + request(JobSock,{{privdir,Tarfile0},TarBin}); + _ -> + ok = del_dir(JobDir), + request(JobSock,{privdir,empty_priv_dir}) + end. + +del_dir(Dir) -> + case file:read_file_info(Dir) of + {ok,#file_info{type=directory}} -> + {ok,Cont} = file:list_dir(Dir), + lists:foreach(fun(F) -> del_dir(filename:join(Dir,F)) end, Cont), + ok = file:del_dir(Dir); + {ok,#file_info{}} -> + ok = file:delete(Dir); + _r -> + %% This might be a symlink - let's try to delete it! + catch file:delete(Dir), + ok + end. + +%% +%% Receive and decode request on job socket +%% +job_loop(JobSock) -> + Request = recv(JobSock), + case decode_job(Request) of + ok -> job_loop(JobSock); + {stop,R} -> R + end. + +decode_job({{beam,Mod,Which},Beam}) -> + % FIXME, shared directory structure on host and target required, + % "Library beams" are not loaded from HOST... /Patrik + code:add_patha(filename:dirname(Which)), + % End of Patriks uglyness... + {module,Mod} = code:load_binary(Mod,Which,Beam), + ok; +decode_job({{datadir,Tarfile0},Archive}) -> + JobDir = get(test_server_job_dir), + Tarfile = filename:join(JobDir,Tarfile0), + ok = file:write_file(Tarfile,Archive), + % Cooked is temporary removed/broken + % ok = erl_tar:extract(Tarfile,[compressed,{cwd,JobDir},cooked]), + ok = erl_tar:extract(Tarfile,[compressed,{cwd,JobDir}]), + ok = file:delete(Tarfile), + ok; +decode_job({test_case,Case}) -> + Result = run_test_case_apply(Case), + JobSock = get(test_server_job_sock), + request(JobSock,{test_case_result,Result}), + case test_server_sup:tar_crash_dumps() of + {error,no_crash_dumps} -> request(JobSock,{crash_dumps,no_crash_dumps}); + {ok,TarFile} -> + {ok,TarBin} = file:read_file(TarFile), + file:delete(TarFile), + request(JobSock,{{crash_dumps,filename:basename(TarFile)},TarBin}) + end, + ok; +decode_job({sync_apply,{M,F,A}}) -> + R = apply(M,F,A), + request(get(test_server_job_sock),{sync_result,R}), + ok; +decode_job(job_done) -> + {stop,stopped}. + +%% +%% **** STOP *** CODE FOR REMOTE TARGET ONLY *** +%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% cover_compile({App,Include,Exclude,Cross}) -> +%% {ok,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. +%% +%% Cover compile the given application. Return {ok,AnalyseMods} if application +%% is found, else {error,application_not_found}. + +cover_compile({none,_Exclude,Include,Cross}) -> + CompileMods = Include++Cross, + case length(CompileMods) of + 0 -> + io:fwrite("WARNING: No modules to cover compile!\n\n",[]), + cover:start(), % start cover server anyway + {ok,[]}; + N -> + io:fwrite("Cover compiling ~w modules - " + "this may take some time... ",[N]), + do_cover_compile(CompileMods), + io:fwrite("done\n\n",[]), + {ok,Include} + end; +cover_compile({App,all,Include,Cross}) -> + CompileMods = Include++Cross, + case length(CompileMods) of + 0 -> + io:fwrite("WARNING: No modules to cover compile!\n\n",[]), + cover:start(), % start cover server anyway + {ok,[]}; + 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" + "~p\n", [App,CompileMods]), + do_cover_compile(CompileMods), + io:fwrite("done\n\n",[]), + {ok,Include} + end; +cover_compile({App,Exclude,Include,Cross}) -> + case code:lib_dir(App) of + {error,bad_name} -> + case Include++Cross 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: " + "~p\n", [App,Include]), + do_cover_compile(CompileMods), + io:fwrite("done\n\n",[]), + {ok,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 ++ Cross, + case length(CompileMods) of + 0 -> + io:fwrite("WARNING: No modules to cover compile!\n\n",[]), + cover:start(), % start cover server anyway + {ok,[]}; + 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,AnalyseMods} + end + end. + + +module_names(Beams) -> + [list_to_atom(filename:basename(filename:rootname(Beam))) || Beam <- Beams]. + + +do_cover_compile(Modules) -> + do_cover_compile1(lists:usort(Modules)). % remove duplicates + +do_cover_compile1([Dont|Rest]) when Dont=:=cover; + Dont=:=test_server; + Dont=:=test_server_ctrl -> + do_cover_compile1(Rest); +do_cover_compile1([M|Rest]) -> + case {code:is_sticky(M),code:is_loaded(M)} of + {true,_} -> + code:unstick_mod(M), + case cover:compile_beam(M) of + {ok,_} -> + ok; + Error -> + io:fwrite("\nWARNING: Could not cover compile ~w: ~p\n", + [M,Error]) + end, + code:stick_mod(M), + do_cover_compile1(Rest); + {false,false} -> + case code:load_file(M) of + {module,_} -> + do_cover_compile1([M|Rest]); + Error -> + io:fwrite("\nWARNING: Could not load ~w: ~p\n",[M,Error]), + do_cover_compile1(Rest) + end; + {false,_} -> + case cover:compile_beam(M) of + {ok,_} -> + ok; + Error -> + io:fwrite("\nWARNING: Could not cover compile ~w: ~p\n", + [M,Error]) + end, + do_cover_compile1(Rest) + end; +do_cover_compile1([]) -> + ok. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% cover_analyse(Analyse,Modules) -> [{M,{Cov,NotCov,Details}}] +%% +%% Analyse = {details,Dir} | details | {overview,void()} | overview +%% Modules = [atom()], the modules to analyse +%% +%% Cover analysis. If this is a remote target, analyse_to_file can not be used. +%% In that case the analyse level 'line' is used instead if Analyse==details. +%% +%% If this is a local target, the test directory is given +%% (Analyse=={details,Dir}) and analyse_to_file can be used directly. +%% +%% If Analyse==overview | {overview,Dir} analyse_to_file is not used, only +%% an overview containing the number of covered/not covered lines in each module. +%% +%% Also, if a Dir exists, cover data will be exported to a file called +%% all.coverdata in that directory. +cover_analyse(Analyse,Modules) -> + io:fwrite("Cover analysing...\n",[]), + DetailsFun = + case Analyse of + {details,Dir} -> + case cover:export(filename:join(Dir,"all.coverdata")) of + ok -> + fun(M) -> + OutFile = filename:join(Dir, + atom_to_list(M) ++ + ".COVER.html"), + case cover:analyse_to_file(M,OutFile,[html]) of + {ok,_} -> + {file,OutFile}; + Error -> + Error + end + end; + Error -> + fun(_) -> Error end + end; + details -> + fun(M) -> + case cover:analyse(M,line) of + {ok,Lines} -> + {lines,Lines}; + Error -> + Error + end + end; + {overview,Dir} -> + case cover:export(filename:join(Dir,"all.coverdata")) of + ok -> + fun(_) -> undefined end; + Error -> + fun(_) -> Error end + end; + overview -> + fun(_) -> undefined end + end, + R = lists:map( + fun(M) -> + case cover:analyse(M,module) of + {ok,{M,{Cov,NotCov}}} -> + {M,{Cov,NotCov,DetailsFun(M)}}; + Err -> + io:fwrite("WARNING: Analysis failed for ~w. Reason: ~p\n", + [M,Err]), + {M,Err} + end + end, Modules), + Sticky = unstick_all_sticky(node()), + cover:stop(), + stick_all_sticky(node(),Sticky), + R. + + +unstick_all_sticky(Node) -> + lists:filter( + fun(M) -> + case code:is_sticky(M) of + true -> + rpc:call(Node,code,unstick_mod,[M]), + true; + false -> + false + end + end, + 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,MultiplyTimetrap) -> +%% {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. +%% This might be io requests (which are redirected to the log files). +%% +%% 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. +%% +%% MultiplyTimetrap indicates a possible extension of all timetraps +%% Timetraps will be multiplied by this integer. If it is infinity, no +%% timetraps will be started at all. + +run_test_case_apply({CaseNum,Mod,Func,Args,Name,RunInit,MultiplyTimetrap}) -> + 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, + test_server_h:testcase({Mod,Func,1}), + ProcBef = erlang:system_info(process_count), + Result = run_test_case_apply(Mod, Func, Args, Name, RunInit, MultiplyTimetrap), + ProcAft = erlang:system_info(process_count), + purify_new_leaks(), + DetFail = get(test_server_detected_fail), + {Result,DetFail,ProcBef,ProcAft}. + +run_test_case_apply(Mod, Func, Args, Name, RunInit, MultiplyTimetrap) -> + case get(test_server_job_dir) of + undefined -> + %% i'm a local target + do_run_test_case_apply(Mod, Func, Args, Name, RunInit, MultiplyTimetrap); + JobDir -> + %% i'm a remote target + case Args of + [Config] when is_list(Config) -> + {value,{data_dir,HostDataDir}} = + lists:keysearch(data_dir, 1, Config), + DataBase = filename:basename(HostDataDir), + TargetDataDir = filename:join(JobDir, DataBase), + Config1 = lists:keyreplace(data_dir, 1, Config, + {data_dir,TargetDataDir}), + TargetPrivDir = filename:join(JobDir, ?priv_dir), + Config2 = lists:keyreplace(priv_dir, 1, Config1, + {priv_dir,TargetPrivDir}), + do_run_test_case_apply(Mod, Func, [Config2], Name, RunInit, + MultiplyTimetrap); + _other -> + do_run_test_case_apply(Mod, Func, Args, Name, RunInit, + MultiplyTimetrap) + end + end. +do_run_test_case_apply(Mod, Func, Args, Name, RunInit, MultiplyTimetrap) -> + {ok,Cwd} = file:get_cwd(), + Args2Print = case Args of + [Args1] when is_list(Args1) -> + lists:keydelete(tc_group_result, 1, Args1); + _ -> + Args + end, + print(minor, "Test case started with:\n~s:~s(~p)\n", [Mod,Func,Args2Print]), + print(minor, "Current directory is ~p\n", [Cwd]), + print_timestamp(minor,"Started at "), + TCCallback = get(test_server_testcase_callback), + Ref = make_ref(), + OldGLeader = group_leader(), + %% Set ourself to group leader for the spawned process + group_leader(self(),self()), + Pid = + spawn_link( + fun() -> + run_test_case_eval(Mod, Func, Args, Name, Ref, + RunInit, MultiplyTimetrap, + TCCallback) + end), + group_leader(OldGLeader, self()), + put(test_server_detected_fail, []), + run_test_case_msgloop(Ref, Pid, false, false, ""). + +%% 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 (livrem OCH hangslen mao :) +%% +%% 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(Ref, Pid, CaptureStdout, Terminate, Comment) -> + %% NOTE: Keep job_proxy_msgloop/0 up to date when changes + %% are made in this function! + {Timeout,ReturnValue} = + case Terminate of + {true, ReturnVal} -> + {20, ReturnVal}; + false -> + {infinity, should_never_appear} + end, + receive + {abort_current_testcase,Reason,From} -> + Line = get_loc(Pid), + Mon = erlang:monitor(process, Pid), + exit(Pid,{testcase_aborted,Reason,Line}), + erlang:yield(), + From ! {self(),abort_current_testcase,ok}, + NewComment = + receive + {'DOWN', Mon, process, Pid, _} -> + Comment + 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])]), + if length(Error1) > 63 -> + string:substr(Error1,1,60) ++ "..."; + true -> + Error1 + end + end, + run_test_case_msgloop(Ref,Pid,CaptureStdout,Terminate,NewComment); + {io_request,From,ReplyAs,{put_chars,io_lib,Func,[Format,Args]}} + when is_list(Format) -> + Msg = (catch io_lib:Func(Format,Args)), + run_test_case_msgloop_io(ReplyAs,CaptureStdout,Msg,From,Func), + run_test_case_msgloop(Ref,Pid,CaptureStdout,Terminate,Comment); + {io_request,From,ReplyAs,{put_chars,io_lib,Func,[Format,Args]}} + when is_atom(Format) -> + Msg = (catch io_lib:Func(Format,Args)), + run_test_case_msgloop_io(ReplyAs,CaptureStdout,Msg,From,Func), + run_test_case_msgloop(Ref,Pid,CaptureStdout,Terminate,Comment); + {io_request,From,ReplyAs,{put_chars,Bytes}} -> + run_test_case_msgloop_io( + ReplyAs,CaptureStdout,Bytes,From,put_chars), + run_test_case_msgloop(Ref,Pid,CaptureStdout,Terminate,Comment); + {io_request,From,ReplyAs,{put_chars,unicode,io_lib,Func,[Format,Args]}} + when is_list(Format) -> + Msg = unicode_to_latin1(catch io_lib:Func(Format,Args)), + run_test_case_msgloop_io(ReplyAs,CaptureStdout,Msg,From,Func), + run_test_case_msgloop(Ref,Pid,CaptureStdout,Terminate,Comment); + {io_request,From,ReplyAs,{put_chars,latin1,io_lib,Func,[Format,Args]}} + when is_list(Format) -> + Msg = (catch io_lib:Func(Format,Args)), + run_test_case_msgloop_io(ReplyAs,CaptureStdout,Msg,From,Func), + run_test_case_msgloop(Ref,Pid,CaptureStdout,Terminate,Comment); + {io_request,From,ReplyAs,{put_chars,unicode,io_lib,Func,[Format,Args]}} + when is_atom(Format) -> + Msg = unicode_to_latin1(catch io_lib:Func(Format,Args)), + run_test_case_msgloop_io(ReplyAs,CaptureStdout,Msg,From,Func), + run_test_case_msgloop(Ref,Pid,CaptureStdout,Terminate,Comment); + {io_request,From,ReplyAs,{put_chars,latin1,io_lib,Func,[Format,Args]}} + when is_atom(Format) -> + Msg = (catch io_lib:Func(Format,Args)), + run_test_case_msgloop_io(ReplyAs,CaptureStdout,Msg,From,Func), + run_test_case_msgloop(Ref,Pid,CaptureStdout,Terminate,Comment); + {io_request,From,ReplyAs,{put_chars,unicode,Bytes}} -> + run_test_case_msgloop_io( + ReplyAs,CaptureStdout,unicode_to_latin1(Bytes),From,put_chars), + run_test_case_msgloop(Ref,Pid,CaptureStdout,Terminate,Comment); + {io_request,From,ReplyAs,{put_chars,latin1,Bytes}} -> + run_test_case_msgloop_io( + ReplyAs,CaptureStdout,Bytes,From,put_chars), + run_test_case_msgloop(Ref,Pid,CaptureStdout,Terminate,Comment); + IoReq when element(1, IoReq) == io_request -> + %% something else, just pass it on + group_leader() ! IoReq, + run_test_case_msgloop(Ref,Pid,CaptureStdout,Terminate,Comment); + {structured_io,ClientPid,Msg} -> + output(Msg, ClientPid), + run_test_case_msgloop(Ref,Pid,CaptureStdout,Terminate,Comment); + {capture,NewCapture} -> + run_test_case_msgloop(Ref,Pid,NewCapture,Terminate,Comment); + {sync_apply,From,MFA} -> + sync_local_or_remote_apply(false,From,MFA), + run_test_case_msgloop(Ref,Pid,CaptureStdout,Terminate,Comment); + {sync_apply_proxy,Proxy,From,MFA} -> + sync_local_or_remote_apply(Proxy,From,MFA), + run_test_case_msgloop(Ref,Pid,CaptureStdout,Terminate,Comment); + {printout,Detail,Format,Args} -> + print(Detail,Format,Args), + run_test_case_msgloop(Ref,Pid,CaptureStdout,Terminate,Comment); + {comment,NewComment} -> + Terminate1 = + case Terminate of + {true,{Time,Value,Loc,Opts,_OldComment}} -> + {true,{Time,Value,mod_loc(Loc),Opts,NewComment}}; + Other -> + Other + end, + run_test_case_msgloop(Ref,Pid,CaptureStdout,Terminate1,NewComment); + {'EXIT',Pid,{Ref,Time,Value,Loc,Opts}} -> + RetVal = {Time/1000000,Value,mod_loc(Loc),Opts,Comment}, + run_test_case_msgloop(Ref,Pid,CaptureStdout,{true,RetVal},Comment); + {'EXIT',Pid,Reason} -> + case Reason of + {timetrap_timeout,TVal,Loc} -> + %% convert Loc to form that can be formatted + Loc1 = mod_loc(Loc), + {Mod,Func} = get_mf(Loc1), + %% The framework functions mustn't execute on this + %% group leader process or io will cause deadlock, + %% so we spawn a dedicated process for the operation + %% and let the group leader go back to handle io. + spawn_fw_call(Mod,Func,Pid,{timetrap_timeout,TVal}, + Loc1,self(),Comment), + run_test_case_msgloop(Ref,Pid,CaptureStdout,Terminate,Comment); + {timetrap_timeout,TVal,Loc,InitOrEnd} -> + Loc1 = mod_loc(Loc), + {Mod,_Func} = get_mf(Loc1), + spawn_fw_call(Mod,InitOrEnd,Pid,{timetrap_timeout,TVal}, + Loc1,self(),Comment), + run_test_case_msgloop(Ref,Pid,CaptureStdout,Terminate,Comment); + {testcase_aborted,Reason,Loc} -> + Loc1 = mod_loc(Loc), + {Mod,Func} = get_mf(Loc1), + spawn_fw_call(Mod,Func,Pid,{testcase_aborted,Reason}, + Loc1,self(),Comment), + run_test_case_msgloop(Ref,Pid,CaptureStdout,Terminate,Comment); + killed -> + %% result of an exit(TestCase,kill) call, which is the + %% only way to abort a testcase process that traps exits + %% (see abort_current_testcase) + spawn_fw_call(undefined,undefined,Pid,testcase_aborted_or_killed, + unknown,self(),Comment), + run_test_case_msgloop(Ref,Pid,CaptureStdout,Terminate,Comment); + _ -> + %% the testcase has terminated because of Reason (e.g. an exit + %% because a linked process failed) + spawn_fw_call(undefined,undefined,Pid,Reason, + unknown,self(),Comment), + run_test_case_msgloop(Ref,Pid,CaptureStdout,Terminate,Comment) + end; + {_FwCallPid,fw_notify_done,RetVal} -> + %% the framework has been notified, we're finished + run_test_case_msgloop(Ref,Pid,CaptureStdout,{true,RetVal},Comment); + {'EXIT',_FwCallPid,{fw_notify_done,Func,Error}} -> + %% a framework function failed + CB = os:getenv("TEST_SERVER_FRAMEWORK"), + Loc = case CB of + false -> + {test_server,Func}; + _ -> + {list_to_atom(CB),Func} + end, + RetVal = {died,{framework_error,Loc,Error},Loc,"Framework error"}, + run_test_case_msgloop(Ref,Pid,CaptureStdout,{true,RetVal},Comment); + {failed,File,Line} -> + put(test_server_detected_fail, + [{File, Line}| get(test_server_detected_fail)]), + run_test_case_msgloop(Ref,Pid,CaptureStdout,Terminate,Comment); + _Other when not is_tuple(_Other) -> + %% ignore anything not generated by test server + run_test_case_msgloop(Ref,Pid,CaptureStdout,Terminate,Comment); + _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(Ref,Pid,CaptureStdout,Terminate,Comment) + after Timeout -> + ReturnValue + end. + +run_test_case_msgloop_io(ReplyAs,CaptureStdout,Msg,From,Func) -> + case Msg of + {'EXIT',_} -> + From ! {io_reply,ReplyAs,{error,Func}}; + _ -> + From ! {io_reply,ReplyAs,ok} + end, + if CaptureStdout /= false -> + CaptureStdout ! {captured,Msg}; + true -> + ok + end, + output({minor,Msg},From). + +output(Msg,Sender) -> + local_or_remote_apply({test_server_ctrl,output,[Msg,Sender]}). + +spawn_fw_call(Mod,{init_per_testcase,Func},Pid,{timetrap_timeout,TVal}=Why, + Loc,SendTo,Comment) -> + FwCall = + fun() -> + Skip = {skip,{failed,{Mod,init_per_testcase,Why}}}, + %% if init_per_testcase fails, the test case + %% should be skipped + case catch test_server_sup:framework_call( + end_tc,[?pl2a(Mod),Func,{Pid,Skip,[[]]}]) of + {'EXIT',FwEndTCErr} -> + exit({fw_notify_done,end_tc,FwEndTCErr}); + _ -> + ok + end, + %% finished, report back + SendTo ! {self(),fw_notify_done, + {TVal/1000,Skip,Loc,[],Comment}} + end, + spawn_link(FwCall); +spawn_fw_call(Mod,{end_per_testcase,Func},Pid,{timetrap_timeout,TVal}=Why, + Loc,SendTo,_Comment) -> + FwCall = + fun() -> + Conf = [{tc_status,ok}], + %% if end_per_testcase fails, the test case should be + %% reported successful with a warning printed as comment + case catch test_server_sup:framework_call(end_tc, + [?pl2a(Mod),Func, + {Pid, + {failed,{Mod,end_per_testcase,Why}}, + [Conf]}]) of + {'EXIT',FwEndTCErr} -> + exit({fw_notify_done,end_tc,FwEndTCErr}); + _ -> + ok + end, + %% finished, report back + SendTo ! {self(),fw_notify_done, + {TVal/1000,{error,{Mod,end_per_testcase,Why}},Loc,[], + ["<font color=\"red\">" + "WARNING: end_per_testcase timed out!" + "</font>"]}} + end, + spawn_link(FwCall); +spawn_fw_call(Mod,Func,Pid,Error,Loc,SendTo,Comment) -> + FwCall = + fun() -> + case catch fw_error_notify(Mod,Func,[], + Error,Loc) of + {'EXIT',FwErrorNotifyErr} -> + exit({fw_notify_done,error_notification, + FwErrorNotifyErr}); + _ -> + ok + end, + Conf = [{tc_status,{failed,timetrap_timeout}}], + case catch test_server_sup:framework_call(end_tc, + [?pl2a(Mod),Func, + {Pid,Error,[Conf]}]) of + {'EXIT',FwEndTCErr} -> + exit({fw_notify_done,end_tc,FwEndTCErr}); + _ -> + ok + end, + %% finished, report back + SendTo ! {self(),fw_notify_done,{died,Error,Loc,Comment}} + 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, + MultiplyTimetrap, TCCallback) -> + put(test_server_multiply_timetraps,MultiplyTimetrap), + {{Time,Value},Loc,Opts} = + case test_server_sup:framework_call(init_tc,[?pl2a(Mod),Func,Args0], + {ok,Args0}) of + {ok,Args} -> + run_test_case_eval1(Mod, Func, Args, Name, RunInit, TCCallback); + Error = {error,_Reason} -> + test_server_sup:framework_call(end_tc,[?pl2a(Mod),Func,{Error,Args0}]), + {{0,{skip,{failed,Error}}},{Mod,Func},[]}; + {fail,Reason} -> + [Conf] = Args0, + Conf1 = [{tc_status,{failed,Reason}} | Conf], + fw_error_notify(Mod, Func, Conf, Reason), + test_server_sup:framework_call(end_tc,[?pl2a(Mod),Func, + {{error,Reason},[Conf1]}]), + {{0,{failed,Reason}},{Mod,Func},[]}; + Skip = {skip,_Reason} -> + test_server_sup:framework_call(end_tc,[?pl2a(Mod),Func,{Skip,Args0}]), + {{0,Skip},{Mod,Func},[]}; + {auto_skip,Reason} -> + test_server_sup:framework_call(end_tc,[?pl2a(Mod), + Func, + {{skip,Reason},Args0}]), + {{0,{skip,{fw_auto_skip,Reason}}},{Mod,Func},[]} + end, + exit({Ref,Time,Value,Loc,Opts}). + +run_test_case_eval1(Mod, Func, Args, Name, RunInit, TCCallback) -> + case RunInit of + run_init -> + put(test_server_init_or_end_conf,{init_per_testcase,Func}), + put(test_server_loc, {Mod,{init_per_testcase,Func}}), + ensure_timetrap(Args), + case init_per_testcase(Mod, Func, Args) of + Skip = {skip,Reason} -> + Line = get_loc(), + Conf = [{tc_status,{skipped,Reason}}], + test_server_sup:framework_call(end_tc,[?pl2a(Mod),Func,{Skip,[Conf]}]), + {{0,{skip,Reason}},Line,[]}; + {skip_and_save,Reason,SaveCfg} -> + Line = get_loc(), + Conf = [{tc_status,{skipped,Reason}},{save_config,SaveCfg}], + test_server_sup:framework_call(end_tc,[?pl2a(Mod),Func, + {{skip,Reason},[Conf]}]), + {{0,{skip,Reason}},Line,[]}; + {ok,NewConf} -> + put(test_server_init_or_end_conf,undefined), + %% call user callback function if defined + NewConf1 = user_callback(TCCallback, Mod, Func, init, NewConf), + put(test_server_loc, {Mod,Func}), + %% 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, mod_loc(Loc)), + {[{tc_status,{failed,TCError}}|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}; + {skip,Why} -> + {[{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), + {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 -> % unexpected termination + {Failure,TSReturn,EndConf1}; + _ -> + {FWReturn,TSReturn,EndConf1} + end, + case test_server_sup:framework_call(end_tc, [?pl2a(Mod), Func, + {FWReturn1,[EndConf2]}]) of + {fail,Reason} -> + fw_error_notify(Mod, Func, EndConf2, Reason), + {{T,{failed,Reason}},{Mod,Func},[]}; + _ -> + {{T,TSReturn1},Loc,[]} + end + end; + skip_init -> + %% call user callback function if defined + Args1 = user_callback(TCCallback, Mod, Func, init, Args), + ensure_timetrap(Args1), + %% ts_tc does a catch + put(test_server_loc, {Mod,Func}), + %% 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, Loc, Return1), + {{T,Return2},Loc,Opts} + 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 + test_server_sup:framework_call(end_tc, [?pl2a(M),F,{ok,A}]), + {Return,[]} + 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, mod_loc(Loc)), + test_server_sup:framework_call(end_tc, + [?pl2a(M),F,{{error,TCError}, + [[{tc_status,{failed,TCError}}|Args]]}]), + {Failed,SaveOpts}; +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) -> + test_server_sup:framework_call(end_tc, [?pl2a(M),F,{Final,A}]), + {Final,lists:reverse(SaveOpts)}. + +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, + %% init_per_testcase defined, returns new configuration + case erlang:function_exported(Mod,init_per_testcase,2) of + true -> + case catch my_apply(Mod, init_per_testcase, [Func|Args]) of + {'$test_server_ok',{Skip,Reason}} when Skip==skip; + Skip==skipped -> + {skip,Reason}; + {'$test_server_ok',Res={skip_and_save,_,_}} -> + Res; + {'$test_server_ok',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; + {'$test_server_ok',_Other} -> + group_leader() ! {printout,12, + "ERROR! init_per_testcase did not return " + "a Config list.\n",[]}, + {skip,{failed,{Mod,init_per_testcase,bad_return}}}; + {'EXIT',Reason} -> + Line = get_loc(), + FormattedLoc = test_server_sup:format_loc(mod_loc(Line)), + group_leader() ! {printout,12, + "ERROR! init_per_testcase crashed!\n" + "\tLocation: ~s\n\tReason: ~p\n", + [FormattedLoc,Reason]}, + {skip,{failed,{Mod,init_per_testcase,Reason}}}; + Other -> + Line = get_loc(), + FormattedLoc = test_server_sup:format_loc(mod_loc(Line)), + group_leader() ! {printout,12, + "ERROR! init_per_testcase thrown!\n" + "\tLocation: ~s\n\tReason: ~p\n", + [FormattedLoc, Other]}, + {skip,{failed,{Mod,init_per_testcase,Other}}} + end; + false -> + %% Optional init_per_testcase not defined + %% keep quiet. + [Config] = Args, + {ok, Config} + 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) -> + put(test_server_init_or_end_conf,{EndFunc,Func}), + put(test_server_loc, {Mod,{EndFunc,Func}}), + case catch my_apply(Mod, EndFunc, [Func,Conf]) of + {'$test_server_ok',SaveCfg={save_config,_}} -> + SaveCfg; + {'$test_server_ok',{fail,_}=Fail} -> + Fail; + {'$test_server_ok',_} -> + ok; + {'EXIT',Reason} = Why -> + comment(io_lib:format("<font color=\"red\">" + "WARNING: ~w crashed!" + "</font>\n",[EndFunc])), + group_leader() ! {printout,12, + "WARNING: ~w crashed!\n" + "Reason: ~p\n" + "Line: ~s\n", + [EndFunc, Reason, + test_server_sup:format_loc( + mod_loc(get_loc()))]}, + {failed,{Mod,end_per_testcase,Why}}; + Other -> + comment(io_lib:format("<font color=\"red\">" + "WARNING: ~w thrown!" + "</font>\n",[EndFunc])), + group_leader() ! {printout,12, + "WARNING: ~w thrown!\n" + "Reason: ~p\n" + "Line: ~s\n", + [EndFunc, Other, + test_server_sup:format_loc( + mod_loc(get_loc()))]}, + {failed,{Mod,end_per_testcase,Other}} + end. + +get_loc() -> + case catch test_server_line:get_lines() of + [] -> + get(test_server_loc); + {'EXIT',_} -> + get(test_server_loc); + Loc -> + Loc + end. + +get_loc(Pid) -> + {dictionary,Dict} = process_info(Pid, dictionary), + lists:foreach(fun({Key,Val}) -> put(Key,Val) end,Dict), + get_loc(). + +get_mf([{M,F,_}|_]) -> {M,F}; +get_mf([{M,F}|_]) -> {M,F}; +get_mf(_) -> {undefined,undefined}. + +mod_loc(Loc) -> + %% handle diff line num versions + case Loc of + [{{_M,_F},_L}|_] -> + [{?pl2a(M),F,L} || {{M,F},L} <- Loc]; + [{_M,_F}|_] -> + [{?pl2a(M),F} || {M,F} <- Loc]; + {{M,F},L} -> + [{?pl2a(M),F,L}]; + {M,ForL} -> + [{?pl2a(M),ForL}]; + _ -> + Loc + end. + + +fw_error_notify(Mod, Func, Args, Error) -> + test_server_sup:framework_call(error_notification, + [?pl2a(Mod),Func,[Args], + {Error,unknown}]). +fw_error_notify(Mod, Func, Args, Error, Loc) -> + test_server_sup:framework_call(error_notification, + [?pl2a(Mod),Func,[Args], + {Error,Loc}]). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% 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,Args) -> + local_or_remote_apply({test_server_ctrl,print,[Detail,Format,Args]}). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% 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) -> + local_or_remote_apply({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. + +%% timer:tc/3 +ts_tc(M, F, A) -> + Before = erlang:now(), + Val = (catch my_apply(M, F, A)), + After = erlang:now(), + Result = case Val of + {'$test_server_ok', R} -> + R; % test case ok + {'EXIT',_Reason} = R -> + R; % test case crashed + Other -> + {failed, {thrown,Other}} % test case was thrown + end, + Elapsed = + (element(1,After)*1000000000000 + +element(2,After)*1000000+element(3,After)) - + (element(1,Before)*1000000000000 + +element(2,Before)*1000000+element(3,Before)), + {Elapsed, Result}. + +my_apply(M, F, A) -> + {'$test_server_ok',apply(M, F, A)}. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% 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!) %% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +unicode_to_latin1(Chars) when is_list(Chars); is_binary(Chars) -> + lists:flatten( + [ case X of + High when High > 255 -> + io_lib:format("\\{~.8B}",[X]); + Low -> + Low + end || X <- unicode:characters_to_list(Chars,unicode) ]); +unicode_to_latin1(Garbage) -> + Garbage. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% 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([]). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% 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. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% 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)), + exit({suite_failed,Reason}). + +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() -> + exit(suite_failed). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% break(Comment) -> ok +%% +%% Break a test case so part of the test can be done manually. +%% Use continue/0 to continue. +break(Comment) -> + case erase(test_server_timetraps) of + undefined -> ok; + List -> lists:foreach(fun(Ref) -> timetrap_cancel(Ref) end,List) + end, + io:format(user, + "\n\n\n--- SEMIAUTOMATIC TESTING ---" + "\nThe test case executes on process ~w" + "\n\n\n~s" + "\n\n\n-----------------------------\n\n" + "Continue with --> test_server:continue().\n", + [self(),Comment]), + case whereis(test_server_break_process) of + undefined -> + spawn_break_process(self()); + OldBreakProcess -> + OldBreakProcess ! cancel, + spawn_break_process(self()) + end, + receive continue -> ok end. + +spawn_break_process(Pid) -> + spawn(fun() -> + register(test_server_break_process,self()), + receive + continue -> continue(Pid); + cancel -> ok + end + end). + +continue() -> + case whereis(test_server_break_process) of + undefined -> + ok; + BreakProcess -> + BreakProcess ! continue + end. + +continue(Pid) -> + Pid ! continue. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% timetrap_scale_factor() -> Factor +%% +%% Returns the amount to scale timetraps with. + +timetrap_scale_factor() -> + F0 = case test_server:purify_is_running() of + true -> 5; + false -> 1 + end, + F1 = case {is_debug(), has_lock_checking()} of + {true,_} -> 6 * F0; + {false,true} -> 2 * F0; + {false,false} -> F0 + end, + F2 = case has_superfluous_schedulers() of + true -> 3*F1; + false -> F1 + end, + F = case test_server_sup:get_os_family() of + vxworks -> 5 * F2; + _ -> F2 + end, + case test_server:is_cover() of + true -> 10 * F; + false -> F + end. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% 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(Timeout0) -> + Timeout = time_ms(Timeout0), + cancel_default_timetrap(), + case get(test_server_multiply_timetraps) of + undefined -> timetrap1(Timeout); + infinity -> infinity; + Int -> timetrap1(Timeout*Int) + end. + +timetrap1(Timeout) -> + Ref = spawn_link(test_server_sup,timetrap,[Timeout,self()]), + case get(test_server_timetraps) of + undefined -> put(test_server_timetraps,[Ref]); + List -> put(test_server_timetraps,[Ref|List]) + end, + Ref. + +ensure_timetrap(Config) -> + %format("ensure_timetrap:~p~n",[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. + +cancel_default_timetrap() -> + 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_spec,Other}); +time_ms(Ms) when is_integer(Ms) -> Ms; +time_ms(Other) -> exit({invalid_time_spec,Other}). + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% timetrap_cancel(Handle) -> ok +%% Handle = term() +%% +%% Cancels a time trap. +timetrap_cancel(infinity) -> + ok; +timetrap_cancel(Handle) -> + case get(test_server_timetraps) of + undefined -> ok; + [Handle] -> erase(test_server_timetraps); + List -> put(test_server_timetraps,lists:delete(Handle,List)) + end, + test_server_sup:timetrap_cancel(Handle). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% 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). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% 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, as for the case of VxWorks and OSE, +%% 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() of + true -> + not is_shielded(Name) andalso same_version(Node); + false -> + false + end, + + net_adm:ping(Node), + case Cover of + true -> + Sticky = unstick_all_sticky(Node), + cover:start(Node), + stick_all_sticky(Node,Sticky); + _ -> + 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]}}, + receive {sync_result,R} -> R end. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% stop_node(Name) -> true|false +%% +%% Kills a (remote) node. +%% Also inform test_server_ctrl so it can clean up! +stop_node(Slave) -> + Nocover = is_shielded(Slave) orelse not same_version(Slave), + case is_cover() of + true when not Nocover -> + Sticky = unstick_all_sticky(Slave), + cover:stop(Slave), + stick_all_sticky(Slave,Sticky); + _ -> + 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: ~p", [Slave]), + format(major, "=node_stop ~p", [Slave]), + true + after 30000 -> + format("=== WARNING: Node ~p does not seem to terminate.", + [Slave]), + 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 (~p)~n" + "=== Trying to kill it anyway!!!", + [Slave]), + case net_adm:ping(Slave)of + pong -> + slave:stop(Slave), + true; + pang -> + 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) -> + {A,B,C} = now(), + Name = "shielded_node-" ++ integer_to_list(A) ++ "-" ++ integer_to_list(B) + ++ "-" ++ integer_to_list(C), + 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. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% 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) -> + {A,B,C} = erlang:now(), + RandomNum = A bxor B bxor C, + RandomName = Stem ++ integer_to_list(RandomNum), + {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) -> + case os:type() of + {ose,_} -> + Comment = "Skipping app_test on OSE", + comment(Comment), % in case user ignores the return value + {skip,Comment}; + _other -> + test_server_sup:app_test(App, Mode) + end. +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% is_native(Mod) -> true | false +%% +%% Checks wether the module is natively compiled or not. + +is_native(Mod) -> + case catch Mod:module_info(native_addresses) of + [_|_] -> true; + _Other -> false + end. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% 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. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% os_type() -> OsType +%% +%% Returns the OsType of the target node. OsType is +%% the same as returned from os:type() +os_type() -> + test_server_ctrl:get_target_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. + + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% Generic send functions for communication with host +%% +sync_local_or_remote_apply(Proxy,From,{M,F,A} = MFA) -> + case get(test_server_job_sock) of + undefined -> + %% i'm a local target + Result = apply(M,F,A), + if is_pid(Proxy) -> Proxy ! {sync_result_proxy,From,Result}; + true -> From ! {sync_result,Result} + end; + JobSock -> + %% i'm a remote target + request(JobSock,{sync_apply,MFA}), + {sync_result,Result} = recv(JobSock), + if is_pid(Proxy) -> Proxy ! {sync_result_proxy,From,Result}; + true -> From ! {sync_result,Result} + end + end. +local_or_remote_apply({M,F,A} = MFA) -> + case get(test_server_job_sock) of + undefined -> + %% i'm a local target + apply(M,F,A), + ok; + JobSock -> + %% i'm a remote target + request(JobSock,{apply,MFA}), + ok + end. + +request(Sock,Request) -> + gen_tcp:send(Sock,<<1,(term_to_binary(Request))/binary>>). + +%% +%% Generic receive function for communication with host +%% +recv(Sock) -> + case gen_tcp:recv(Sock,0) of + {error,closed} -> + gen_tcp:close(Sock), + exit(connection_lost); + {ok,<<1,Request/binary>>} -> + binary_to_term(Request); + {ok,<<0,B/binary>>} -> + B + end. |