redbug.erl

%%% -*- erlang-indent-level: 2 -*-
%%%-------------------------------------------------------------------
%%% File    : redbg.erl
%%% Author  : Mats Cronqvist <locmacr@mwlx084>
%%% Description :
%%%
%%% Created : 24 Jan 2007 by Mats Cronqvist <locmacr@mwlx084>
%%%-------------------------------------------------------------------
-module(redbug).

-export([help/0]).
% start from the unix shell
-export([unix/1]).
% start from erlang shell
-export([start/1,start/2,start/3,start/4,start/5]).
-export([stop/0]).

-import(lists,[foldl/3,usort/1,reverse/1,foreach/2,flatten/1]).

-include("log.hrl").

%-define(bla,erlang:display(process_info(self(),current_function))).

%% the redbug server data structure
%% most can be set in the input proplist
-record(cnf,{time         = 15000          % ms
             , msgs         = 10           % unit
             , proc         = all          % list of procs (or 'all')
             , target       = node()       % target node
             , cookie       = ''           % target node cookie
             , buffered     = no           % output buffering
             , arity        = false        % arity instead of args
             , print_call   = true         % print calls (see `return_only')
             , print_form   = "~s~n"       % format for printing
             , print_file   = ""           % file to print to (standard_io)
             , print_msec   = false        % print milliseconds in timestamps?
             , print_depth  = 999999       % Limit for "~P" formatting depth
             , print_re     = ""           % regexp that must match to print
             , max_queue    = 5000         % max # of msgs before suicide
             , max_msg_size = 50000        % max message size before suicide
             , file         = ""           % file to write trace msgs to
             , file_size    = 1            % file size (per file [Mb])
             , file_count   = 8            % number of files in wrap log

             , trc          = []           % cannot be set by user
             , print_pid    = []           % cannot be set by user
             , trc_pid      = []           % cannot be set by user
             , cons_pid     = []           % cannot be set by user
            }).

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
print_fun(FD,Form) -> fun(Str) -> io:fwrite(FD,Form,[Str]) end.

help() ->
  foreach(print_fun(standard_io,"~s~n"),
          ["redbug - the (sensibly) Restrictive Debugger"
           , ""
           , "  redbug:start(Trc) -> start(Trc,[])."
           , "  redbug:start(Trc,Opts)."
           , ""
           , "  redbug is a tool to interact with the Erlang trace facility."
           , "  It will instruct the Erlang VM to generate so called "
           , "  'trace messages' when certain events (such as a particular"
           , "  function being called) occur."
           , "  The trace messages are either printed (i.e. human readable)"
           , "  to a file or to the screen; or written to a trc file."
           , "  Using a trc file puts less stress on the system, but"
           , "  there is no way to count the messages (so the msgs opt"
           , "  is ignored), and the files can only be read by special tools"
           , "  (such as 'bread'). Printing and trc files cannot be combined."
           , "  By default (i.e. if the 'file' opt is not given), messages"
           , "  are printed."
           , ""
           , "Trc: list('send'|'receive'|string(RTP))"
           , "RTP:  restricted trace pattern"
           , "  the RTP has the form: \"<mfa> when <guards> -> <actions>\""
           , "  where <mfa> can be;"
           , "  \"mod\", \"mod:fun\", \"mod:fun/3\" or \"mod:fun('_',atom,X)\""
           , "  <guard> is something like;"
           , "  \"X==1\" or \"is_atom(A)\""
           , "  and <action> is;"
           , "  \"return\" and/or \"stack\" (separated by \";\")"
           , ""
           , "  E.g."
           , "  ets:lookup(T,hostname) when is_integer(T) ->stack"
           , ""
           , "Opts: list({Opt,Val})"
           , "  general opts:"
           , "time         (15000)       stop trace after this many ms"
           , "msgs         (10)          stop trace after this many msgs"
           , "proc         (all)         (list of) Erlang process(es)"
           , "                           all|pid()|atom(RegName)|{pid,I2,I3}"
           , "target       (node())      node to trace on"
           , "arity        (false)       print arity instead of arg list"
           , "  print-related opts"
           , "max_queue    (5000)        fail if internal queue gets this long"
           , "max_msg_size (50000)       fail if seeing a msg this big"
           , "buffered     (no)          buffer messages till end of trace"
           , "print_form   (\"~s~n\")      print msgs using this format"
           , "print_file   (standard_io) print to this file"
           , "print_msec   (false)       print milliseconds on timestamps"
           , "print_depth  (999999)      formatting depth for \"~P\""
           , "print_re     (\"\")          print only strings that match this"
           , "  trc file related opts"
           , "file         (none)        use a trc file based on this name"
           , "file_size    (1)           size of each trc file"
           , "file_count   (8)           number of trc files"
           , ""
          ]).

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% start from unix shell (e.g. the bin/redbug script)
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
unix([Node,Time,Msgs,Trc])      -> unix([Node,Time,Msgs,Trc,"all"]);
unix([Node,Time,Msgs,Trc,Proc]) ->
  try
    Cnf = #cnf{time = to_int(Time),
               msgs   = to_int(Msgs),
               trc    = to_term(Trc),
               proc   = to_atom(Proc),
               target = to_atom(Node)},
    self() ! {start,Cnf},
    init(),
    maybe_halt(0)
  catch
    exit:exiting ->
      maybe_halt(0);
    C:R ->
      io:fwrite("~p~n",[{C,R,erlang:get_stacktrace()}]),
      maybe_halt(1)
  end;
unix(X) ->
  io:fwrite("bad args: ~p~n",[X]),
  maybe_halt(1).

maybe_halt(Status) ->
  case is_in_shell() of
    true -> ok;
    false-> erlang:halt(Status)
  end.

is_in_shell() ->
  {_,{x,S}} = (catch erlang:error(x)),
  element(1,hd(lists:reverse(S))) == shell.

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% API from erlang shell
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
stop() ->
  case whereis(redbug) of
    undefined -> not_started;
    Pid -> Pid ! {stop,[]}
  end.

%% a bunch of aliases for start/2
start(Trc) -> start(Trc, []).

start(T,M,Trc) -> start(Trc, [{time,T},{msgs,M}]).

start(T,M,Trc,P) -> start(Trc, [{time,T},{msgs,M},{procs,P}]).

start(T,M,Trc,P,N)  -> start(Trc, [{time,T},{msgs,M},{procs,P},{target,N}]).

start(M,F) when is_atom(M), is_atom(F) -> start({M,F});
start(send,Props)                      -> start([send],Props);
start('receive',Props)                 -> start(['receive'],Props);
start(M,Props) when is_atom(M)         -> start([{M,'_'}],Props);
start(Trc,{Tag,Val})                   -> start(Trc, [{Tag,Val}]);
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%% the real start function!
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
start(Trc,Props) when is_list(Props) ->
  case whereis(redbug) of
    undefined ->
      Cnf = make_cnf(Trc,Props),
      assert_cookie(Cnf),
      try
        register(redbug, spawn(fun init/0)),
        redbug ! {start,Cnf},
        ok
      catch
        C:R -> {oops,{C,R}}
      end;
    _ -> redbug_already_started
  end.

assert_cookie(#cnf{cookie=''}) -> ok;
assert_cookie(Cnf) -> erlang:set_cookie(Cnf#cnf.target,Cnf#cnf.cookie).

%% turn the proplist inta a #cnf{}
make_cnf(Trc,Props) ->
  make_cnf(Props,#cnf{trc=Trc},record_info(fields,cnf)).

make_cnf([],Cnf,_) -> Cnf;
make_cnf([{Tag,Val}|Props],Cnf,Tags) ->
  make_cnf(Props,setelement(findex(Tag,Tags)+1,Cnf,Val),Tags).

findex(Tag,[])       -> exit({field_not_allowed,Tag});
findex(Tag,[Tag|_])  -> 1;
findex(Tag,[_|Tags]) -> findex(Tag,Tags)+1.
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%% the main redbug process
%%% a state machine. init, starting, running, stopping, maybe_stopping.
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
init() ->
  process_flag(trap_exit,true),
  receive
    {start,Cnf} ->
      try
        starting(do_start(Cnf))
      catch
        C:R -> ?log([{C,R},{stack,erlang:get_stacktrace()}])
      end
  end,
  exit(exiting).

starting(Cnf = #cnf{print_pid=PrintPid}) ->
  receive
    {stop,Args} -> prf:config(prf_redbug,prfTrc,{stop,{self(),Args}});
    {prfTrc,{starting,T,C}}      -> running(Cnf#cnf{trc_pid=T,cons_pid=C});
    {prfTrc,{already_started,_}} -> ?log(already_started);
    {'EXIT',PrintPid,R}          -> ?log([printer_died,{reason,R}]);
    {'EXIT',R}                   -> ?log([exited,{reason,R}]);
    X                            -> ?log([{unknown_message,X}])
  end.

running(Cnf = #cnf{trc_pid=TrcPid,print_pid=PrintPid}) ->
  maybe_alert_printer(Cnf),
  receive
    {stop,Args} -> prf:config(prf_redbug,prfTrc,{stop,{self(),Args}}),
                   stopping(Cnf);
    {prfTrc,{stopping,_,_}}         -> stopping(Cnf);
    {'EXIT',TrcPid,_}               -> stopping(Cnf);
    {prfTrc,{not_started,R,TrcPid}} -> ?log([{not_started,R}]);
    {'EXIT',PrintPid,_}             -> maybe_stopping(Cnf);
    X                               -> ?log([{unknown_message,X}])
  end.

maybe_stopping(#cnf{trc_pid=TrcPid}) ->
  receive
    {prfTrc,{stopping,_,_}} -> ok;
    {'EXIT',TrcPid,_}       -> ok;
    X                       -> ?log({unknown_message,X})
  end.

stopping(#cnf{print_pid=PrintPid}) ->
  receive
    {'EXIT',PrintPid,_} -> ok;
    X                   -> ?log([{unknown_message,X}])
  end.

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
do_start(OCnf) ->
  Cnf = maybe_print(maybe_new_target(OCnf)),
  prf:start(prf_redbug,Cnf#cnf.target,redbugConsumer),
  prf:config(prf_redbug,prfTrc,{start,{self(),pack(Cnf)}}),
  Cnf.

maybe_alert_printer(Cnf) ->
  Cnf#cnf.print_pid ! {trace_consumer,Cnf#cnf.cons_pid}.

maybe_new_target(Cnf = #cnf{target=Target}) ->
  case lists:member($@,Str=atom_to_list(Target)) of
    true -> Cnf;
    false-> Cnf#cnf{target=to_atom(Str++"@"++element(2,inet:gethostname()))}
  end.

maybe_print(#cnf{print_depth = Pdepth, print_msec = Pmsec} = Cnf) ->
  PF = the_print_fun(Cnf),
  Cnf#cnf{print_pid=spawn_link(fun()->printi(PF,Pdepth,Pmsec) end)}.

the_print_fun(Cnf) ->
  PrintFun = mk_the_print_fun(Cnf),
  fun(print_call)->Cnf#cnf.print_call;
     (Str) -> PrintFun(Str)
  end.

mk_the_print_fun(#cnf{file=[_|_]}) ->
  fun(_) -> ok end;
mk_the_print_fun(#cnf{print_re="",print_file=F,print_form=Form}) ->
  print_fun(get_fd(F),Form);
mk_the_print_fun(Cnf = #cnf{print_re=RE}) ->
  PF = mk_the_print_fun(Cnf#cnf{print_re=""}),
  fun(Str) ->
      case re:run(Str,RE) of
        nomatch -> ok;
        _       -> PF(Str)
      end
  end.

get_fd("") -> standard_io;
get_fd(FN) ->
  case file:open(FN,[write]) of
    {ok,FD} -> FD;
    _ -> exit({cannot_open,FN})
  end.

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%% pack the cnf record into a proplist for prf consumption
%%% Proplist = list({Tag,Val})
%%% Tag = time | flags | rtps | procs | where
%%% Where = {term_buffer,{Pid,Count,MaxQueue,MaxSize}} |
%%%         {term_stream,{Pid,Count,MaxQueue,MaxSize}} |
%%%         {file,File,Size,Count} |
%%%         {ip,Port,Queue}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
pack(Cnf) ->
  {Flags,RTPs} = foldl(fun chk_trc/2,{[],[]},slist(Cnf#cnf.trc)),
  dict:from_list([{time,chk_time(Cnf#cnf.time)},
                  {flags,[call,timestamp|maybe_arity(Cnf,Flags)]},
                  {rtps,RTPs},
                  {procs,chk_proc(Cnf#cnf.proc)},
                  {where,where(Cnf)}]).

where(Cnf) ->
  case Cnf#cnf.file of
    "" -> conf_term(Cnf);
    _  -> conf_file(Cnf)
  end.

conf_file(Cnf) ->
  {file,Cnf#cnf.file,Cnf#cnf.file_size,Cnf#cnf.file_count}.

conf_term(Cnf) ->
  {chk_buffered(Cnf#cnf.buffered),
   {Cnf#cnf.print_pid,
    chk_msgs(Cnf#cnf.msgs),
    Cnf#cnf.max_queue,
    Cnf#cnf.max_msg_size}}.

maybe_arity(#cnf{arity=true},Flags) -> [arity|Flags];
maybe_arity(_,Flags)                -> Flags.

chk_time(Time) when is_integer(Time) -> Time;
chk_time(X) -> exit({bad_time,X}).

chk_buffered(yes) -> term_buffer;
chk_buffered(no) -> term_stream.

chk_proc(Pid) when is_pid(Pid) -> Pid;
chk_proc(Atom) when is_atom(Atom)-> Atom;
chk_proc({pid,I1,I2}) when is_integer(I1), is_integer(I2) -> {pid,I1,I2};
chk_proc(X) -> exit({bad_proc,X}).

chk_msgs(Msgs) when is_integer(Msgs) -> Msgs;
chk_msgs(X) -> exit({bad_msgs,X}).

-define(is_string(Str), (Str=="" orelse (9=<hd(Str) andalso hd(Str)=<255))).

chk_trc('send',{Flags,RTPs})                   -> {['send'|Flags],RTPs};
chk_trc('receive',{Flags,RTPs})                -> {['receive'|Flags],RTPs};
chk_trc('arity',{Flags,RTPs})                  -> {['arity'|Flags],RTPs};
chk_trc(RTP,{Flags,RTPs}) when ?is_string(RTP) -> {Flags,[chk_rtp(RTP)|RTPs]};
chk_trc(RTP,{Flags,RTPs}) when is_tuple(RTP)   -> {Flags,[chk_rtp(RTP)|RTPs]};
chk_trc(X,_)                                   -> exit({bad_trc,X}).

-define(is_aal(M,F,MS), is_atom(M),is_atom(F),is_list(MS)).

chk_rtp(Str) when ?is_string(Str)      -> redbug_msc:transform(Str);
chk_rtp({M})                           -> chk_rtp({M,'_',[]});
chk_rtp({M,F}) when is_atom(F)         -> chk_rtp({M,F,[]});
chk_rtp({M,L}) when is_list(L)         -> chk_rtp({M,'_',L});
chk_rtp({'_',_,_})                     -> exit(dont_wildcard_module);
chk_rtp({M,F,MS}) when ?is_aal(M,F,MS) -> {{M,F,'_'},ms(MS),[local]};
chk_rtp(X)                             -> exit({bad_rtp,X}).

ms(MS) -> foldl(fun msf/2, [{'_',[],[]}], MS).

msf(stack,[{Head,Cond,Body}]) -> [{Head,Cond,[{message,{process_dump}}|Body]}];
msf(return,[{Head,Cond,Body}])-> [{Head,Cond,[{return_trace}|Body]}];
msf(Ari, [{_,Cond,Body}]) when is_integer(Ari)-> [{mk_head(Ari),Cond,Body}];
msf({Head,Cond},[{_,_,Body}]) when is_tuple(Head)->[{Head,slist(Cond),Body}];
msf(Head, [{_,Cond,Body}]) when is_tuple(Head)-> [{Head,Cond,Body}];
msf(X,_) -> exit({bad_match_spec,X}).

mk_head(N) -> erlang:make_tuple(N,'_').

slist(S) when ?is_string(S) -> [S];
slist(L) when is_list(L) -> usort(L);
slist(X) -> [X].

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
printi(PrintFun,Pdepth,Pmsec) ->
  receive
    {trace_consumer,TC} ->
      erlang:monitor(process,TC),
      printl(PrintFun,Pdepth,Pmsec)
  end.

printl(PrintFun,Pdepth,Pmsec) ->
  receive
    {'DOWN',_,_,_,R} -> io:fwrite("quitting: ~p~n",[R]);
    X -> outer(PrintFun,Pdepth,Pmsec,X),
         printl(PrintFun,Pdepth,Pmsec)
  end.

outer(_,_,_,[]) -> ok;
outer(PrintFun,Pdepth,Pmsec,[Msg|Msgs]) ->
  case Msg of
    {'call',{MFA,Bin},PI,TS} ->
      PrintFun(flat("~n~s <~p> ~P",[ts(TS,Pmsec),PI,MFA,Pdepth])),
      foreach(fun(L)->PrintFun(flat("  ~P",[L,Pdepth])) end, stak(Bin));
    {'retn',{MFA,Val},PI,TS} ->
      PrintFun(flat("~n~s <~p> ~p -> ~P",[ts(TS,Pmsec),PI,MFA,Val,Pdepth]));
    {'send',{MSG,To},PI,TS} ->
      PrintFun(flat("~n~s <~p> <~p> <<< ~P",[ts(TS,Pmsec),PI,To,MSG,Pdepth]));
    {'recv',MSG,PI,TS} ->
      PrintFun(flat("~n~s <~p> <<< ~P",[ts(TS,Pmsec),PI,MSG,Pdepth]));
    _ ->
      PrintFun(flat("~n~P", [Msg,Pdepth]))
  end,
  outer(PrintFun,Pdepth,Pmsec,Msgs).

ts({H,M,S,_Us},false) -> flat("~2.2.0w:~2.2.0w:~2.2.0w",[H,M,S]);
ts({H,M,S,Us},_) -> flat("~2.2.0w:~2.2.0w:~2.2.0w.~3.3.0w",[H,M,S,Us div 1000]).

flat(Form,List) -> flatten(io_lib:fwrite(Form,List)).

%%% call stack handler
stak(Bin) ->
  foldl(fun munge/2,[],string:tokens(binary_to_list(Bin),"\n")).

munge(I,Out) ->
  case reverse(I) of
    "..."++_ -> [truncated|Out];
    _ ->
      case string:str(I, "Return addr") of
        0 ->
          case string:str(I, "cp = ") of
            0 -> Out;
            _ -> [mfaf(I)|Out]
          end;
        _ ->
          case string:str(I, "erminate process normal") of
            0 -> [mfaf(I)|Out];
            _ -> Out
          end
      end
  end.

mfaf(I) ->
  [_, C|_] = string:tokens(I,"()+"),
  C.

to_int(L) -> list_to_integer(L).
to_atom(L) -> list_to_atom(L).

to_term("_") -> '_';
to_term(Str) ->
  {done, {ok, Toks, 1}, []} = erl_scan:tokens([], "["++Str++"]. ", 1),
  case erl_parse:parse_term(Toks) of
    {ok, [Term]} -> Term;
    {ok, L} when is_list(L) -> L
  end.