gproc/patches/stdlib/sys.erl

%% ``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 via the world wide web at http://www.erlang.org/.
%% 
%% Software distributed under the License is distributed on an "AS IS"
%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See
%% the License for the specific language governing rights and limitations
%% under the License.
%% 
%% The Initial Developer of the Original Code is Ericsson Utvecklings AB.
%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings
%% AB. All Rights Reserved.''
%% 
%%     $Id$
%%
-module(sys).

%% External exports
-export([suspend/1, suspend/2, resume/1, resume/2,
	 get_status/1, get_status/2,
	 change_code/4, change_code/5,
	 log/2, log/3, trace/2, trace/3, statistics/2, statistics/3,
	 log_to_file/2, log_to_file/3, no_debug/1, no_debug/2,
	 install/2, install/3, remove/2, remove/3]).
-export([reg/3, reg/4]).
-export([handle_system_msg/6, handle_debug/4,
	 print_log/1, get_debug/3, debug_options/1]).

%%-----------------------------------------------------------------
%% System messages
%%-----------------------------------------------------------------
suspend(Name) -> send_system_msg(Name, suspend).
suspend(Name, Timeout) -> send_system_msg(Name, suspend, Timeout).

resume(Name) -> send_system_msg(Name, resume).
resume(Name, Timeout) -> send_system_msg(Name, resume, Timeout).

get_status(Name) -> send_system_msg(Name, get_status).
get_status(Name, Timeout) -> send_system_msg(Name, get_status, Timeout).

change_code(Name, Mod, Vsn, Extra) ->
    send_system_msg(Name, {change_code, Mod, Vsn, Extra}).
change_code(Name, Mod, Vsn, Extra, Timeout) ->
    send_system_msg(Name, {change_code, Mod, Vsn, Extra}, Timeout).

reg(Name, Key, Value) ->
    send_system_msg(Name, {reg, Key, Value}).
reg(Name, Key, Value, Timeout) ->
    send_system_msg(Name, {reg, Key, Value}, Timeout).

%%-----------------------------------------------------------------
%% Debug commands
%%-----------------------------------------------------------------
log(Name, Flag) ->
    send_system_msg(Name, {debug, {log, Flag}}).
log(Name, Flag, Timeout) ->
    send_system_msg(Name, {debug, {log, Flag}}, Timeout).

trace(Name, Flag) ->
    send_system_msg(Name, {debug, {trace, Flag}}).
trace(Name, Flag, Timeout) ->
    send_system_msg(Name, {debug, {trace, Flag}}, Timeout).

log_to_file(Name, FileName) ->
    send_system_msg(Name, {debug, {log_to_file, FileName}}).
log_to_file(Name, FileName, Timeout) ->
    send_system_msg(Name, {debug, {log_to_file, FileName}}, Timeout).

statistics(Name, Flag) ->
    send_system_msg(Name, {debug, {statistics, Flag}}).
statistics(Name, Flag, Timeout) ->
    send_system_msg(Name, {debug, {statistics, Flag}}, Timeout).

no_debug(Name) -> send_system_msg(Name, {debug, no_debug}).
no_debug(Name, Timeout) -> send_system_msg(Name, {debug, no_debug}, Timeout).

install(Name, {Func, FuncState}) ->
    send_system_msg(Name, {debug, {install, {Func, FuncState}}}).
install(Name, {Func, FuncState}, Timeout) ->
    send_system_msg(Name, {debug, {install, {Func, FuncState}}}, Timeout).

remove(Name, Func) ->
    send_system_msg(Name, {debug, {remove, Func}}).
remove(Name, Func, Timeout) ->
    send_system_msg(Name, {debug, {remove, Func}}, Timeout).

%%-----------------------------------------------------------------
%% All system messages sent are on the form {system, From, Msg}
%% The receiving side should send Msg to handle_system_msg/5.
%%-----------------------------------------------------------------
send_system_msg(Name, Request) ->
    case catch gen:call(Name, system, Request) of
	{ok,Res} -> Res;
	{'EXIT', Reason} -> exit({Reason, mfa(Name, Request)})
    end.

send_system_msg(Name, Request, Timeout) ->
    case catch gen:call(Name, system, Request, Timeout) of
	{ok,Res} -> Res;
	{'EXIT', Reason} -> exit({Reason, mfa(Name, Request, Timeout)})
    end.

mfa(Name, {debug, {Func, Arg2}}) ->
    {sys, Func, [Name, Arg2]};
mfa(Name, {change_code, Mod, Vsn, Extra}) ->
    {sys, change_code, [Name, Mod, Vsn, Extra]};
mfa(Name, Atom) ->
    {sys, Atom, [Name]}.
mfa(Name, Req, Timeout) ->
    {M, F, A} = mfa(Name, Req),
    {M, F, A ++ [Timeout]}.

%%-----------------------------------------------------------------
%% Func: handle_system_msg/6
%% Args: Msg    ::= term()
%%       From   ::= {pid(),Ref} but don't count on that
%%       Parent ::= pid()
%%       Module ::= atom()
%%       Debug  ::= [debug_opts()]
%%       Misc   ::= term()
%% Purpose: Used by a process module that wishes to take care of
%%          system messages.  The process receives a {system, From,
%%          Msg} message, and passes the Msg to this function.
%% Returns: This function *never* returns! It calls the function
%%          Module:system_continue(Parent, NDebug, Misc)
%%          there the process continues the execution or
%%          Module:system_terminate(Raeson, Parent, Debug, Misc) if
%%          the process should terminate.
%%          The Module must export system_continue/3, system_terminate/4
%%          and format_status/2 for status information.
%%-----------------------------------------------------------------
handle_system_msg(Msg, From, Parent, Module, Debug, Misc) ->
    handle_system_msg(running, Msg, From, Parent, Module, Debug, Misc).

handle_system_msg(SysState, Msg, From, Parent, Mod, Debug, Misc) ->
    case do_cmd(SysState, Msg, Parent, Mod, Debug, Misc) of
	{suspended, Reply, NDebug, NMisc} ->
	    gen:reply(From, Reply),
	    suspend_loop(suspended, Parent, Mod, NDebug, NMisc);
	{running, Reply, NDebug, NMisc} ->
	    gen:reply(From, Reply),
            Mod:system_continue(Parent, NDebug, NMisc)
    end.

%%-----------------------------------------------------------------
%% Func: handle_debug/4
%% Args: Debug ::= [debug_opts()]
%%       Func  ::= {M,F} | fun()  arity 3
%%       State ::= term()
%%       Event ::= {in, Msg} | {in, Msg, From} | {out, Msg, To} | term()
%% Purpose: Called by a process that wishes to debug an event.
%%          Func is a formatting function, called as Func(Device, Event).
%% Returns: [debug_opts()]
%%-----------------------------------------------------------------
handle_debug([{trace, true} | T], FormFunc, State, Event) ->
    print_event({Event, State, FormFunc}),
    [{trace, true} | handle_debug(T, FormFunc, State, Event)];
handle_debug([{log, {N, LogData}} | T], FormFunc, State, Event) ->
    NLogData = [{Event, State, FormFunc} | trim(N, LogData)],
    [{log, {N, NLogData}} | handle_debug(T, FormFunc, State, Event)];
handle_debug([{log_to_file, Fd} | T], FormFunc, State, Event) ->
    print_event(Fd, {Event, State, FormFunc}),
    [{log_to_file, Fd} | handle_debug(T, FormFunc, State, Event)];
handle_debug([{statistics, StatData} | T], FormFunc, State, Event) ->
    NStatData = stat(Event, StatData),
    [{statistics, NStatData} | handle_debug(T, FormFunc, State, Event)];
handle_debug([{Func, FuncState} | T], FormFunc, State, Event) ->
    case catch Func(FuncState, Event, State) of
	done -> handle_debug(T, FormFunc, State, Event);
	{'EXIT', _} -> handle_debug(T, FormFunc, State, Event);
	NFuncState ->		     
	    [{Func, NFuncState} | handle_debug(T, FormFunc, State, Event)]
    end;
handle_debug([], _FormFunc, _State, _Event) ->
    [].


%%-----------------------------------------------------------------
%% When a process is suspended, it can only respond to system
%% messages.
%%-----------------------------------------------------------------
suspend_loop(SysState, Parent, Mod, Debug, Misc) ->
    receive
	{system, From, Msg} ->
	    handle_system_msg(SysState, Msg, From, Parent, Mod, Debug, Misc);
	{'EXIT', Parent, Reason} ->
            Mod:system_terminate(Reason, Parent, Debug, Misc)
    end.

do_cmd(_, suspend, _Parent, _Mod, Debug, Misc) ->
    {suspended, ok, Debug, Misc};
do_cmd(_, resume, _Parent, _Mod, Debug, Misc) ->
    {running, ok, Debug, Misc};
do_cmd(SysState, {reg, Key, Value}, _Parent, Mod, Debug, Misc) ->
    Res = case erlang:function_exported(Mod, system_reg, 3) of
	      true ->
		  catch Mod:system_reg(Misc, Key, Value);
	      false ->
		  catch gproc:reg(Key, Value)
	  end,
    {SysState, Res, Debug, Misc};
do_cmd(SysState, get_status, Parent, Mod, Debug, Misc) ->
    Res = get_status(SysState, Parent, Mod, Debug, Misc),
    {SysState, Res, Debug, Misc};
do_cmd(SysState, {debug, What}, _Parent, _Mod, Debug, Misc) ->
    {Res, NDebug} = debug_cmd(What, Debug),
    {SysState, Res, NDebug, Misc};
do_cmd(suspended, {change_code, Module, Vsn, Extra}, _Parent,
       Mod, Debug, Misc) ->
    {Res, NMisc} = do_change_code(Mod, Module, Vsn, Extra, Misc),
    {suspended, Res, Debug, NMisc};
do_cmd(SysState, Other, _Parent, _Mod, Debug, Misc) ->
    {SysState, {error, {unknown_system_msg, Other}}, Debug, Misc}.

get_status(SysState, Parent, Mod, Debug, Misc) ->
    {status, self(), {module, Mod},
     [get(), SysState, Parent, Debug, Misc]}.

%%-----------------------------------------------------------------
%% These are the system debug commands.
%% {trace,       true|false} -> io:format
%% {log,         true|false|get|print} -> keeps the 10 last debug messages
%% {log_to_file, FileName | false} -> io:format to file.
%% {statistics,  true|false|get}   -> keeps track of messages in/out + reds.
%%-----------------------------------------------------------------
debug_cmd({trace, true}, Debug) ->
    {ok, install_debug(trace, true, Debug)};
debug_cmd({trace, false}, Debug) ->
    {ok, remove_debug(trace, Debug)};
debug_cmd({log, true}, Debug) ->
    {_N, Logs} = get_debug(log, Debug, {0, []}),
    {ok, install_debug(log, {10, trim(10, Logs)}, Debug)};
debug_cmd({log, {true, N}}, Debug) when is_integer(N), N > 0 ->
    {_N, Logs} = get_debug(log, Debug, {0, []}),
    {ok, install_debug(log, {N, trim(N, Logs)}, Debug)};
debug_cmd({log, false}, Debug) ->
    {ok, remove_debug(log, Debug)};
debug_cmd({log, print}, Debug) ->
    print_log(Debug),
    {ok, Debug};
debug_cmd({log, get}, Debug) ->
    {_N, Logs} = get_debug(log, Debug, {0, []}),
    {{ok, lists:reverse(Logs)}, Debug};
debug_cmd({log_to_file, false}, Debug) ->
    NDebug = close_log_file(Debug),
    {ok, NDebug};
debug_cmd({log_to_file, FileName}, Debug) ->
    NDebug = close_log_file(Debug),
    case file:open(FileName, write) of
	{ok, Fd} ->
	    {ok, install_debug(log_to_file, Fd, NDebug)};
	_Error ->
	    {{error, open_file}, NDebug}
    end;
debug_cmd({statistics, true}, Debug) ->
    {ok, install_debug(statistics, init_stat(), Debug)};
debug_cmd({statistics, false}, Debug) ->
    {ok, remove_debug(statistics, Debug)};
debug_cmd({statistics, get}, Debug) ->
    {{ok, get_stat(get_debug(statistics, Debug, []))}, Debug};
debug_cmd(no_debug, Debug) ->
    close_log_file(Debug),
    {ok, []};
debug_cmd({install, {Func, FuncState}}, Debug) ->
    {ok, install_debug(Func, FuncState, Debug)};
debug_cmd({remove, Func}, Debug) ->
    {ok, remove_debug(Func, Debug)};
debug_cmd(_Unknown, Debug) ->
    {unknown_debug, Debug}.


do_change_code(Mod, Module, Vsn, Extra, Misc) ->
    case catch Mod:system_code_change(Misc, Module, Vsn, Extra) of
	{ok, NMisc} -> {ok, NMisc};
	Else -> {{error, Else}, Misc}
    end.

print_event(X) -> print_event(standard_io, X).

print_event(Dev, {Event, State, FormFunc}) ->
    FormFunc(Dev, Event, State).

init_stat() -> {erlang:localtime(), process_info(self(), reductions), 0, 0}.
get_stat({Time, {reductions, Reds}, In, Out}) ->
    {reductions, Reds2} = process_info(self(), reductions),
    [{start_time, Time}, {current_time, erlang:localtime()},
     {reductions, Reds2 - Reds}, {messages_in, In}, {messages_out, Out}];
get_stat(_) ->
    no_statistics.

stat({in, _Msg}, {Time, Reds, In, Out}) -> {Time, Reds, In+1, Out};
stat({in, _Msg, _From}, {Time, Reds, In, Out}) -> {Time, Reds, In+1, Out};
stat({out, _Msg, _To}, {Time, Reds, In, Out}) -> {Time, Reds, In, Out+1};
stat(_, StatData) -> StatData.

trim(N, LogData) ->
    lists:sublist(LogData, 1, N-1).

%%-----------------------------------------------------------------
%% Debug structure manipulating functions
%%-----------------------------------------------------------------
install_debug(Item, Data, Debug) ->
    case get_debug(Item, Debug, undefined) of
	undefined -> [{Item, Data} | Debug];
	_ -> Debug
    end.
remove_debug(Item, Debug) -> lists:keydelete(Item, 1, Debug).
get_debug(Item, Debug, Default) -> 
    case lists:keysearch(Item, 1, Debug) of
	{value, {Item, Data}} -> Data;
	_ -> Default
    end.

print_log(Debug) ->
    {_N, Logs} = get_debug(log, Debug, {0, []}),
    lists:foreach(fun print_event/1,
		  lists:reverse(Logs)).
    
close_log_file(Debug) ->
    case get_debug(log_to_file, Debug, []) of
	[] ->
	    Debug;
	Fd -> 
	    file:close(Fd),
	    remove_debug(log_to_file, Debug)
    end.

%%-----------------------------------------------------------------
%% Func: debug_options/1
%% Args: [trace|log|{log,N}|statistics|{log_to_file, FileName}|
%%        {install, {Func, FuncState}}]
%% Purpose: Initiate a debug structure.  Called by a process that
%%          wishes to initiate the debug structure without the
%%          system messages.
%% Returns: [debug_opts()]
%%-----------------------------------------------------------------
debug_options(Options) ->
    debug_options(Options, []).
debug_options([trace | T], Debug) ->
    debug_options(T, install_debug(trace, true, Debug));
debug_options([log | T], Debug) ->
    debug_options(T, install_debug(log, {10, []}, Debug));
debug_options([{log, N} | T], Debug) when is_integer(N), N > 0 ->
    debug_options(T, install_debug(log, {N, []}, Debug));
debug_options([statistics | T], Debug) ->
    debug_options(T, install_debug(statistics, init_stat(), Debug));
debug_options([{log_to_file, FileName} | T], Debug) ->
    case file:open(FileName, write) of
	{ok, Fd} ->
	    debug_options(T, install_debug(log_to_file, Fd, Debug));
	_Error ->
	    debug_options(T, Debug)
    end;
debug_options([{install, {Func, FuncState}} | T], Debug) ->
    debug_options(T, install_debug(Func, FuncState, Debug));
debug_options([_ | T], Debug) ->
    debug_options(T, Debug);
debug_options([], Debug) -> 
    Debug.