Introduce test_server_io and test_server_gl

1 files changed, 315 insertions, 0 deletions

diff --git a/lib/test_server/src/test_server_io.erl b/lib/test_server/src/test_server_io.erl
new file mode 100644
index 0000000000..abdfb71241
--- /dev/null
+++ b/lib/test_server/src/test_server_io.erl
@@ -0,0 +1,315 @@
+%%
+%% %CopyrightBegin%
+%%
+%% Copyright Ericsson AB 2012. 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%
+%%
+%% This module implements a process with the registered name 'test_server_io',
+%% which has two main responsibilities:
+%%
+%%   * Manage group leader processes (see the test_server_gl module)
+%%   for test cases. A group_leader process is obtained by calling
+%%   get_gl/1. Group leader processes will be kept alive as along as
+%%   the 'test_server_io' process is alive.
+%%
+%%   * Handle output to the common log files (stdout, major, html,
+%%   unexpected_io).
+%%
+
+-module(test_server_io).
+-export([start_link/0,stop/0,get_gl/1,set_fd/2,
+	 start_transaction/0,end_transaction/0,print_buffered/1,print/3,
+	 set_footer/1,set_job_name/1,set_gl_props/1]).
+
+-export([init/1,handle_call/3,handle_info/2,terminate/2]).
+
+-record(st, {fds,				%Singleton fds (gb_tree)
+	     shared_gl :: pid(),		%Shared group leader
+	     gls,				%Group leaders (gb_set)
+	     io_buffering=false,		%I/O buffering
+	     buffered,				%Buffered I/O requests
+	     html_footer,			%HTML footer
+	     job_name,				%Name of current job.
+	     gl_props,				%Properties for GL.
+	     stopping
+	    }).
+
+start_link() ->
+    case gen_server:start_link({local,?MODULE}, ?MODULE, [], []) of
+	{ok,Pid} ->
+	    {ok,Pid};
+	Other ->
+	    Other
+    end.
+
+stop() ->
+    OldGL = group_leader(),
+    group_leader(self(), self()),
+    req(stop),
+    group_leader(OldGL, self()),
+    ok.
+
+%% get_gl(Shared) -> Pid
+%%  Shared = boolean()
+%%  Pid = pid()
+%%
+%%  Return a group leader (a process using the test_server_gl module).
+%%  If Shared is true, the shared group leader is returned (suitable for
+%%  running sequential test cases), otherwise a new group leader process
+%%  is spawned. Group leader processes will live until they are garbaged
+%%  collected by a call to gc/0.
+
+get_gl(Shared) when is_boolean(Shared) ->
+    req({get_gl,Shared}).
+
+%% set_fd(Tag, Fd) -> ok.
+%%  Tag = major | html | unexpected_io
+%%  Fd = a file descriptor (as returned by file:open/2)
+%%
+%%  Associate a file descriptor with the given Tag. This
+%%  Tag can later be used in when calling to print/3.
+
+set_fd(Tag, Fd) ->
+    req({set_fd,Tag,Fd}).
+
+%% start_transaction()
+%%
+%%  Subsequent calls to print/3 from the process executing start_transaction/0
+%%  will cause the messages to be buffered instead of printed directly.
+
+start_transaction() ->
+    req({start_transaction,self()}).
+
+%% end_transaction()
+%%
+%%  End the transaction started by start_transaction/0. Subsequent calls to
+%%  print/3 will cause the message to be printed directory.
+
+end_transaction() ->
+    req({end_transaction,self()}).
+
+%% print(From, Tag, Msg)
+%%  From = pid()
+%%  Tag = stdout, or any tag that has been registered using set_fd/2
+%%  Msg = string or iolist
+%%
+%%  Either print Msg to the file identified by Tag, or buffer the message
+%%  start_transaction/0 has been called from the process From.
+%%
+%%  NOTE: The tags have various special meanings. For example, 'html'
+%%  is assumed to be a HTML file.
+
+print(From, Tag, Msg) ->
+    req({print,From,Tag,Msg}).
+
+%% print_buffered(Pid)
+%%  Pid = pid()
+%%
+%%  Print all messages buffered in the *first* transaction buffered for Pid.
+%%  (If start_transaction/0 and end_transaction/0 has been called N times,
+%%  print_buffered/1 must be called N times to print all transactions.)
+
+print_buffered(Pid) ->
+    req({print_buffered,Pid}).
+
+%% set_footer(IoData)
+%%
+%%  Set a footer for the file associated with the 'html' tag.
+%%  It will be used by print/3 to print a footer for the HTML file.
+
+set_footer(Footer) ->
+    req({set_footer,Footer}).
+
+%% set_job_name(Name)
+%%  Set a name for the currently running job. The name will be used
+%%  when printing to 'stdout'.
+%%
+set_job_name(Name) ->
+    req({set_job_name,Name}).
+
+%% set_gl_props(PropList)
+%%  Set properties for group leader processes. When a group_leader process
+%%  is created, test_server_gl:set_props(PropList) will be called.
+
+set_gl_props(PropList) ->
+    req({set_gl_props,PropList}).
+
+
+%%% Internal functions.
+
+init([]) ->
+    process_flag(trap_exit, true),
+    Empty = gb_trees:empty(),
+    {ok,Shared} = test_server_gl:start_link(),
+    {ok,#st{fds=Empty,shared_gl=Shared,gls=gb_sets:empty(),
+	    io_buffering=gb_sets:empty(),
+	    buffered=Empty,
+	    html_footer="</body>\n</html>\n",
+	    job_name="<name not set>",
+	    gl_props=[]}}.
+
+req(Req) ->
+    gen_server:call(?MODULE, Req, infinity).
+
+handle_call({get_gl,false}, _From, #st{gls=Gls,gl_props=Props}=St) ->
+    {ok,Pid} = test_server_gl:start_link(),
+    test_server_gl:set_props(Pid, Props),
+    {reply,Pid,St#st{gls=gb_sets:insert(Pid, Gls)}};
+handle_call({get_gl,true}, _From, #st{shared_gl=Shared}=St) ->
+    {reply,Shared,St};
+handle_call({set_fd,Tag,Fd}, _From, #st{fds=Fds0}=St) ->
+    Fds = gb_trees:enter(Tag, Fd, Fds0),
+    {reply,ok,St#st{fds=Fds}};
+handle_call({start_transaction,Pid}, _From, #st{io_buffering=Buffer0,
+						buffered=Buf0}=St) ->
+    Buf = case gb_trees:is_defined(Pid, Buf0) of
+	      false -> gb_trees:insert(Pid, queue:new(), Buf0);
+	      true -> Buf0
+	  end,
+    Buffer = gb_sets:add(Pid, Buffer0),
+    {reply,ok,St#st{io_buffering=Buffer,buffered=Buf}};
+handle_call({print,From,Tag,Str}, _From, St0) ->
+    St = output(From, Tag, Str, St0),
+    {reply,ok,St};
+handle_call({end_transaction,Pid}, _From, #st{io_buffering=Buffer0,
+					      buffered=Buffered0}=St0) ->
+    Q0 = gb_trees:get(Pid, Buffered0),
+    Q = queue:in(eot, Q0),
+    Buffered = gb_trees:update(Pid, Q, Buffered0),
+    Buffer = gb_sets:delete_any(Pid, Buffer0),
+    St = St0#st{io_buffering=Buffer,buffered=Buffered},
+    {reply,ok,St};
+handle_call({print_buffered,Pid}, _From, #st{buffered=Buffered0}=St0) ->
+    Q0 = gb_trees:get(Pid, Buffered0),
+    Q = do_print_buffered(Q0, St0),
+    Buffered = gb_trees:update(Pid, Q, Buffered0),
+    St = St0#st{buffered=Buffered},
+    {reply,ok,St};
+handle_call({set_footer,Footer}, _From, St) ->
+    {reply,ok,St#st{html_footer=Footer}};
+handle_call({set_job_name,Name}, _From, St) ->
+    {reply,ok,St#st{job_name=Name}};
+handle_call({set_gl_props,Props}, _From, #st{shared_gl=Shared}=St) ->
+    test_server_gl:set_props(Shared, Props),
+    {reply,ok,St#st{gl_props=Props}};
+handle_call(stop, From, #st{shared_gl=SGL,gls=Gls0}=St0) ->
+    St = St0#st{gls=gb_sets:insert(SGL, Gls0),stopping=From},
+    gc(St),
+    %% Give the users of the surviving group leaders some
+    %% time to finish.
+    erlang:send_after(2000, self(), stop_group_leaders),
+    {noreply,St}.
+
+handle_info({'EXIT',Pid,normal}, #st{gls=Gls0,stopping=From}=St) ->
+    Gls = gb_sets:delete_any(Pid, Gls0),
+    case gb_sets:is_empty(Gls) andalso stopping =/= undefined of
+	true ->
+	    %% No more group leaders left.
+	    gen_server:reply(From, ok),
+	    {stop,normal,St#st{gls=Gls,stopping=undefined}};
+	false ->
+	    %% Wait for more group leaders to finish.
+	    {noreply,St#st{gls=Gls}}
+    end;
+handle_info({'EXIT',_Pid,Reason}, _St) ->
+    exit(Reason);
+handle_info(stop_group_leaders, #st{gls=Gls}=St) ->
+    %% Stop the remaining group leaders.
+    [test_server_gl:stop(GL) || GL <- gb_sets:to_list(Gls)],
+    erlang:send_after(2000, self(), kill_group_leaders),
+    {noreply,St};
+handle_info(kill_group_leaders, #st{gls=Gls,stopping=From}=St) ->
+    [exit(GL, kill) || GL <- gb_sets:to_list(Gls)],
+    gen_server:reply(From, ok),
+    {stop,normal,St};
+handle_info(Other, St) ->
+    io:format("Ignoring: ~p\n", [Other]),
+    {noreply,St}.
+
+terminate(_, _) ->
+    ok.
+
+output(From, Tag, Str, #st{io_buffering=Buffered,buffered=Buf0}=St) ->
+    case gb_sets:is_member(From, Buffered) of
+	false ->
+	    do_output(Tag, Str, St),
+	    St;
+	true ->
+	    Q0 = gb_trees:get(From, Buf0),
+	    Q = queue:in({Tag,Str}, Q0),
+	    Buf = gb_trees:update(From, Q, Buf0),
+	    St#st{buffered=Buf}
+    end.
+
+do_output(stdout, Str0, #st{job_name=Name}) ->
+    Str = io_lib:format("Testing ~s: ~s\n", [Name,Str0]),
+    io:put_chars(Str);
+do_output(Tag, Str, #st{fds=Fds}=St) ->
+    case gb_trees:lookup(Tag, Fds) of
+	none ->
+	    S = io_lib:format("\n*** ERROR: ~p, line ~p: No known '~p' log file\n",
+			      [?MODULE,?LINE,Tag]),
+	    do_output(stdout, [S,Str], St);
+	{value,Fd} ->
+	    try
+		io:put_chars(Fd, Str),
+		case Tag of
+		    html -> finalise_table(Fd, St);
+		    _ -> ok
+		end
+	    catch _:Error ->
+		    S = io_lib:format("\n*** ERROR: ~p, line ~p: Error writing to "
+				      "log file '~p': ~p\n",
+				      [?MODULE,?LINE,Tag,Error]),
+		    do_output(stdout, [S,Str], St)
+	    end
+    end.
+
+finalise_table(Fd, #st{html_footer=Footer}) ->
+    case file:position(Fd, {cur,0}) of
+	{ok,Pos} ->
+	    %% We are writing to a seekable file.  Finalise so
+	    %% we get complete valid (and viewable) HTML code.
+	    %% Then rewind to overwrite the finalising code.
+	    io:put_chars(Fd, ["\n</table>\n",Footer]),
+	    file:position(Fd, Pos);
+	{error,epipe} ->
+	    %% The file is not seekable.  We cannot erase what
+	    %% we've already written --- so the reader will
+	    %% have to wait until we're done.
+	    ok
+    end.
+
+do_print_buffered(Q0, St) ->
+    Item = queue:get(Q0),
+    Q = queue:drop(Q0),
+    case Item of
+	eot ->
+	    Q;
+	{Tag,Str} ->
+	    do_output(Tag, Str, St),
+	    do_print_buffered(Q, St)
+    end.
+
+gc(#st{gls=Gls0}) ->
+    InUse0 = [begin
+		  {group_leader,GL} = process_info(P, group_leader),
+		  GL
+	      end || P <- processes()],
+    InUse = ordsets:from_list(InUse0),
+    Gls = gb_sets:to_list(Gls0),
+    NotUsed = ordsets:subtract(Gls, InUse),
+    [test_server_gl:stop(Pid) || Pid <- NotUsed],
+    ok.