From 84adefa331c4159d432d22840663c38f155cd4c1 Mon Sep 17 00:00:00 2001 From: Erlang/OTP Date: Fri, 20 Nov 2009 14:54:40 +0000 Subject: The R13B03 release. --- lib/tools/src/Makefile | 112 ++ lib/tools/src/cover.erl | 2178 ++++++++++++++++++++++++++++++ lib/tools/src/cover_web.erl | 1184 +++++++++++++++++ lib/tools/src/cprof.erl | 142 ++ lib/tools/src/eprof.erl | 478 +++++++ lib/tools/src/fprof.erl | 2762 +++++++++++++++++++++++++++++++++++++++ lib/tools/src/instrument.erl | 427 ++++++ lib/tools/src/make.erl | 324 +++++ lib/tools/src/tags.erl | 344 +++++ lib/tools/src/tools.app.src | 60 + lib/tools/src/tools.appup.src | 19 + lib/tools/src/xref.erl | 607 +++++++++ lib/tools/src/xref.hrl | 106 ++ lib/tools/src/xref_base.erl | 1804 +++++++++++++++++++++++++ lib/tools/src/xref_compiler.erl | 928 +++++++++++++ lib/tools/src/xref_parser.yrl | 303 +++++ lib/tools/src/xref_reader.erl | 352 +++++ lib/tools/src/xref_scanner.erl | 91 ++ lib/tools/src/xref_utils.erl | 725 ++++++++++ 19 files changed, 12946 insertions(+) create mode 100644 lib/tools/src/Makefile create mode 100644 lib/tools/src/cover.erl create mode 100644 lib/tools/src/cover_web.erl create mode 100644 lib/tools/src/cprof.erl create mode 100644 lib/tools/src/eprof.erl create mode 100644 lib/tools/src/fprof.erl create mode 100644 lib/tools/src/instrument.erl create mode 100644 lib/tools/src/make.erl create mode 100644 lib/tools/src/tags.erl create mode 100644 lib/tools/src/tools.app.src create mode 100644 lib/tools/src/tools.appup.src create mode 100644 lib/tools/src/xref.erl create mode 100644 lib/tools/src/xref.hrl create mode 100644 lib/tools/src/xref_base.erl create mode 100644 lib/tools/src/xref_compiler.erl create mode 100644 lib/tools/src/xref_parser.yrl create mode 100644 lib/tools/src/xref_reader.erl create mode 100644 lib/tools/src/xref_scanner.erl create mode 100644 lib/tools/src/xref_utils.erl (limited to 'lib/tools/src') diff --git a/lib/tools/src/Makefile b/lib/tools/src/Makefile new file mode 100644 index 0000000000..81933cda14 --- /dev/null +++ b/lib/tools/src/Makefile @@ -0,0 +1,112 @@ +# +# %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% +# +include $(ERL_TOP)/make/target.mk +include $(ERL_TOP)/make/$(TARGET)/otp.mk + +# ---------------------------------------------------- +# Application version +# ---------------------------------------------------- +include ../vsn.mk +VSN=$(TOOLS_VSN) + +# ---------------------------------------------------- +# Release directory specification +# ---------------------------------------------------- +RELSYSDIR = $(RELEASE_PATH)/lib/tools-$(VSN) + +# ---------------------------------------------------- +# Common Macros +# ---------------------------------------------------- + +MODULES= cover \ + cover_web \ + eprof \ + fprof \ + cprof \ + instrument \ + make \ + tags \ + xref \ + xref_base \ + xref_compiler \ + xref_parser \ + xref_reader \ + xref_scanner \ + xref_utils + + +HRL_FILES= \ + xref.hrl + + +ERL_FILES= $(MODULES:%=%.erl) + +TARGET_FILES = $(MODULES:%=$(EBIN)/%.$(EMULATOR)) + +YRL_FILE = xref_parser.yrl + +APP_FILE = tools.app +APPUP_FILE = tools.appup + +APP_SRC = $(APP_FILE).src +APP_TARGET = $(EBIN)/$(APP_FILE) + +APPUP_SRC = $(APPUP_FILE).src +APPUP_TARGET = $(EBIN)/$(APPUP_FILE) + +# ---------------------------------------------------- +# FLAGS +# ---------------------------------------------------- +ERL_COMPILE_FLAGS += + +# ---------------------------------------------------- +# Targets +# ---------------------------------------------------- + +debug opt: $(TARGET_FILES) $(APP_TARGET) $(APPUP_TARGET) + +clean: + rm -f $(TARGET_FILES) $(APP_TARGET) $(APPUP_TARGET) + rm -f errs core *~ + +docs: + +# ---------------------------------------------------- +# Special Build Targets +# ---------------------------------------------------- + +$(APP_TARGET): $(APP_SRC) ../vsn.mk + sed -e 's;%VSN%;$(VSN);' $< > $@ + +$(APPUP_TARGET): $(APPUP_SRC) ../vsn.mk + sed -e 's;%VSN%;$(VSN);' $< > $@ + +# ---------------------------------------------------- +# Release Target +# ---------------------------------------------------- +include $(ERL_TOP)/make/otp_release_targets.mk + +release_spec: opt + $(INSTALL_DIR) $(RELSYSDIR)/src + $(INSTALL_DATA) $(ERL_FILES) $(YRL_FILE) $(HRL_FILES) $(RELSYSDIR)/src + $(INSTALL_DIR) $(RELSYSDIR)/ebin + $(INSTALL_DATA) $(TARGET_FILES) $(APP_TARGET) $(APPUP_TARGET) \ + $(RELSYSDIR)/ebin + +release_docs_spec: diff --git a/lib/tools/src/cover.erl b/lib/tools/src/cover.erl new file mode 100644 index 0000000000..aff3927db3 --- /dev/null +++ b/lib/tools/src/cover.erl @@ -0,0 +1,2178 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2001-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(cover). + +%% +%% This module implements the Erlang coverage tool. The module named +%% cover_web implements a user interface for the coverage tool to run +%% under webtool. +%% +%% ARCHITECTURE +%% The coverage tool consists of one process on each node involved in +%% coverage analysis. The process is registered as 'cover_server' +%% (?SERVER). All cover_servers in the distributed system are linked +%% together. The cover_server on the 'main' node is in charge, and it +%% traps exits so it can detect nodedown or process crashes on the +%% remote nodes. This process is implemented by the functions +%% init_main/1 and main_process_loop/1. The cover_server on the remote +%% nodes are implemented by the functions init_remote/2 and +%% remote_process_loop/1. +%% +%% TABLES +%% Each nodes has an ets table named 'cover_internal_data_table' +%% (?COVER_TABLE). This table contains the coverage data and is +%% continously updated when cover compiled code is executed. +%% +%% The main node owns a table named +%% 'cover_collected_remote_data_table' (?COLLECTION_TABLE). This table +%% contains data which is collected from remote nodes (either when a +%% remote node is stopped with cover:stop/1 or when analysing. When +%% analysing, data is even moved from the ?COVER_TABLE on the main +%% node to the ?COLLECTION_TABLE. +%% +%% The main node also has a table named 'cover_binary_code_table' +%% (?BINARY_TABLE). This table contains the binary code for each cover +%% compiled module. This is necessary so that the code can be loaded +%% on remote nodes that are started after the compilation. +%% + + +%% External exports +-export([start/0, start/1, + compile/1, compile/2, compile_module/1, compile_module/2, + compile_directory/0, compile_directory/1, compile_directory/2, + compile_beam/1, compile_beam_directory/0, compile_beam_directory/1, + analyse/1, analyse/2, analyse/3, analyze/1, analyze/2, analyze/3, + analyse_to_file/1, analyse_to_file/2, analyse_to_file/3, + analyze_to_file/1, analyze_to_file/2, analyze_to_file/3, + export/1, export/2, import/1, + modules/0, imported/0, imported_modules/0, which_nodes/0, is_compiled/1, + reset/1, reset/0, + stop/0, stop/1]). +-export([remote_start/1]). +%-export([bump/5]). +-export([transform/4]). % for test purposes + +-record(main_state, {compiled=[], % [{Module,File}] + imported=[], % [{Module,File,ImportFile}] + stopper, % undefined | pid() + nodes=[]}). % [Node] + +-record(remote_state, {compiled=[], % [{Module,File}] + main_node}). % atom() + +-record(bump, {module = '_', % atom() + function = '_', % atom() + arity = '_', % integer() + clause = '_', % integer() + line = '_' % integer() + }). +-define(BUMP_REC_NAME,bump). + +-record(vars, {module, % atom() Module name + vsn, % atom() + + init_info=[], % [{M,F,A,C,L}] + + function, % atom() + arity, % int() + clause, % int() + lines, % [int()] + no_bump_lines, % [int()] + depth, % int() + is_guard=false % boolean + }). + +-define(COVER_TABLE, 'cover_internal_data_table'). +-define(BINARY_TABLE, 'cover_binary_code_table'). +-define(COLLECTION_TABLE, 'cover_collected_remote_data_table'). +-define(TAG, cover_compiled). +-define(SERVER, cover_server). + +%% Line doesn't matter. +-define(BLOCK(Expr), {block,0,[Expr]}). +-define(BLOCK1(Expr), + if + element(1, Expr) =:= block -> + Expr; + true -> ?BLOCK(Expr) + end). + +-include_lib("stdlib/include/ms_transform.hrl"). + +%%%---------------------------------------------------------------------- +%%% External exports +%%%---------------------------------------------------------------------- + +%% start() -> {ok,Pid} | {error,Reason} +%% Pid = pid() +%% Reason = {already_started,Pid} | term() +start() -> + case whereis(?SERVER) of + undefined -> + Starter = self(), + Pid = spawn(fun() -> init_main(Starter) end), + Ref = erlang:monitor(process,Pid), + Return = + receive + {?SERVER,started} -> + {ok,Pid}; + {'DOWN', Ref, _Type, _Object, Info} -> + {error,Info} + end, + erlang:demonitor(Ref), + Return; + Pid -> + {error,{already_started,Pid}} + end. + +%% start(Nodes) -> {ok,StartedNodes} +%% Nodes = Node | [Node,...] +%% Node = atom() +start(Node) when is_atom(Node) -> + start([Node]); +start(Nodes) -> + call({start_nodes,remove_myself(Nodes,[])}). + +%% compile(ModFile) -> +%% compile(ModFile, Options) -> +%% compile_module(ModFile) -> Result +%% compile_module(ModFile, Options) -> Result +%% ModFile = Module | File +%% Module = atom() +%% File = string() +%% Options = [Option] +%% Option = {i,Dir} | {d,Macro} | {d,Macro,Value} +%% Result = {ok,Module} | {error,File} +compile(ModFile) -> + compile_module(ModFile, []). +compile(ModFile, Options) -> + compile_module(ModFile, Options). +compile_module(ModFile) when is_atom(ModFile); + is_list(ModFile) -> + compile_module(ModFile, []). +compile_module(Module, Options) when is_atom(Module), is_list(Options) -> + compile_module(atom_to_list(Module), Options); +compile_module(File, Options) when is_list(File), is_list(Options) -> + WithExt = case filename:extension(File) of + ".erl" -> + File; + _ -> + File++".erl" + end, + AbsFile = filename:absname(WithExt), + [R] = compile_modules([AbsFile], Options), + R. + +%% compile_directory() -> +%% compile_directory(Dir) -> +%% compile_directory(Dir, Options) -> [Result] | {error,Reason} +%% Dir = string() +%% Options - see compile/1 +%% Result - see compile/1 +%% Reason = eacces | enoent +compile_directory() -> + case file:get_cwd() of + {ok, Dir} -> + compile_directory(Dir, []); + Error -> + Error + end. +compile_directory(Dir) when is_list(Dir) -> + compile_directory(Dir, []). +compile_directory(Dir, Options) when is_list(Dir), is_list(Options) -> + case file:list_dir(Dir) of + {ok, Files} -> + + %% Filter out all erl files (except cover.erl) + ErlFileNames = + lists:filter(fun("cover.erl") -> + false; + (File) -> + case filename:extension(File) of + ".erl" -> true; + _ -> false + end + end, + Files), + + %% Create a list of .erl file names (incl path) and call + %% compile_modules/2 with the list of file names. + ErlFiles = lists:map(fun(ErlFileName) -> + filename:join(Dir, ErlFileName) + end, + ErlFileNames), + compile_modules(ErlFiles, Options); + Error -> + Error + end. + +compile_modules(Files,Options) -> + Options2 = lists:filter(fun(Option) -> + case Option of + {i, Dir} when is_list(Dir) -> true; + {d, _Macro} -> true; + {d, _Macro, _Value} -> true; + _ -> false + end + end, + Options), + compile_modules(Files,Options2,[]). + +compile_modules([File|Files], Options, Result) -> + R = call({compile, File, Options}), + compile_modules(Files,Options,[R|Result]); +compile_modules([],_Opts,Result) -> + reverse(Result). + + +%% compile_beam(ModFile) -> Result | {error,Reason} +%% ModFile - see compile/1 +%% Result - see compile/1 +%% Reason = non_existing | already_cover_compiled +compile_beam(Module) when is_atom(Module) -> + case code:which(Module) of + non_existing -> + {error,non_existing}; + ?TAG -> + compile_beam(Module,?TAG); + File -> + compile_beam(Module,File) + end; +compile_beam(File) when is_list(File) -> + {WithExt,WithoutExt} + = case filename:rootname(File,".beam") of + File -> + {File++".beam",File}; + Rootname -> + {File,Rootname} + end, + AbsFile = filename:absname(WithExt), + Module = list_to_atom(filename:basename(WithoutExt)), + compile_beam(Module,AbsFile). + +compile_beam(Module,File) -> + call({compile_beam,Module,File}). + + + +%% compile_beam_directory(Dir) -> [Result] | {error,Reason} +%% Dir - see compile_directory/1 +%% Result - see compile/1 +%% Reason = eacces | enoent +compile_beam_directory() -> + case file:get_cwd() of + {ok, Dir} -> + compile_beam_directory(Dir); + Error -> + Error + end. +compile_beam_directory(Dir) when is_list(Dir) -> + case file:list_dir(Dir) of + {ok, Files} -> + + %% Filter out all beam files (except cover.beam) + BeamFileNames = + lists:filter(fun("cover.beam") -> + false; + (File) -> + case filename:extension(File) of + ".beam" -> true; + _ -> false + end + end, + Files), + + %% Create a list of .beam file names (incl path) and call + %% compile_beam/1 for each such file name + BeamFiles = lists:map(fun(BeamFileName) -> + filename:join(Dir, BeamFileName) + end, + BeamFileNames), + compile_beams(BeamFiles); + Error -> + Error + end. + +compile_beams(Files) -> + compile_beams(Files,[]). +compile_beams([File|Files],Result) -> + R = compile_beam(File), + compile_beams(Files,[R|Result]); +compile_beams([],Result) -> + reverse(Result). + + +%% analyse(Module) -> +%% analyse(Module, Analysis) -> +%% analyse(Module, Level) -> +%% analyse(Module, Analysis, Level) -> {ok,Answer} | {error,Error} +%% Module = atom() +%% Analysis = coverage | calls +%% Level = line | clause | function | module +%% Answer = {Module,Value} | [{Item,Value}] +%% Item = Line | Clause | Function +%% Line = {M,N} +%% Clause = {M,F,A,C} +%% Function = {M,F,A} +%% M = F = atom() +%% N = A = C = integer() +%% Value = {Cov,NotCov} | Calls +%% Cov = NotCov = Calls = integer() +%% Error = {not_cover_compiled,Module} +analyse(Module) -> + analyse(Module, coverage). +analyse(Module, Analysis) when Analysis=:=coverage; Analysis=:=calls -> + analyse(Module, Analysis, function); +analyse(Module, Level) when Level=:=line; Level=:=clause; Level=:=function; + Level=:=module -> + analyse(Module, coverage, Level). +analyse(Module, Analysis, Level) when is_atom(Module), + Analysis=:=coverage; Analysis=:=calls, + Level=:=line; Level=:=clause; + Level=:=function; Level=:=module -> + call({{analyse, Analysis, Level}, Module}). + +analyze(Module) -> analyse(Module). +analyze(Module, Analysis) -> analyse(Module, Analysis). +analyze(Module, Analysis, Level) -> analyse(Module, Analysis, Level). + +%% analyse_to_file(Module) -> +%% analyse_to_file(Module, Options) -> +%% analyse_to_file(Module, OutFile) -> +%% analyse_to_file(Module, OutFile, Options) -> {ok,OutFile} | {error,Error} +%% Module = atom() +%% OutFile = string() +%% Options = [Option] +%% Option = html +%% Error = {not_cover_compiled,Module} | no_source_code_found | +%% {file,File,Reason} +%% File = string() +%% Reason = term() +analyse_to_file(Module) when is_atom(Module) -> + analyse_to_file(Module, outfilename(Module,[]), []). +analyse_to_file(Module, []) when is_atom(Module) -> + analyse_to_file(Module, outfilename(Module,[]), []); +analyse_to_file(Module, Options) when is_atom(Module), + is_list(Options), is_atom(hd(Options)) -> + analyse_to_file(Module, outfilename(Module,Options), Options); +analyse_to_file(Module, OutFile) when is_atom(Module), is_list(OutFile) -> + analyse_to_file(Module, OutFile, []). +analyse_to_file(Module, OutFile, Options) when is_atom(Module), is_list(OutFile) -> + call({{analyse_to_file, OutFile, Options}, Module}). + +analyze_to_file(Module) -> analyse_to_file(Module). +analyze_to_file(Module, OptOrOut) -> analyse_to_file(Module, OptOrOut). +analyze_to_file(Module, OutFile, Options) -> + analyse_to_file(Module, OutFile, Options). + +outfilename(Module,Opts) -> + case lists:member(html,Opts) of + true -> + atom_to_list(Module)++".COVER.html"; + false -> + atom_to_list(Module)++".COVER.out" + end. + +%% export(File) +%% export(File,Module) -> ok | {error,Reason} +%% File = string(); file to write the exported data to +%% Module = atom() +export(File) -> + export(File, '_'). +export(File, Module) -> + call({export,File,Module}). + +%% import(File) -> ok | {error, Reason} +%% File = string(); file created with cover:export/1,2 +import(File) -> + call({import,File}). + +%% modules() -> [Module] +%% Module = atom() +modules() -> + call(modules). + +%% imported_modules() -> [Module] +%% Module = atom() +imported_modules() -> + call(imported_modules). + +%% imported() -> [ImportFile] +%% ImportFile = string() +imported() -> + call(imported). + +%% which_nodes() -> [Node] +%% Node = atom() +which_nodes() -> + call(which_nodes). + +%% is_compiled(Module) -> {file,File} | false +%% Module = atom() +%% File = string() +is_compiled(Module) when is_atom(Module) -> + call({is_compiled, Module}). + +%% reset(Module) -> ok | {error,Error} +%% reset() -> ok +%% Module = atom() +%% Error = {not_cover_compiled,Module} +reset(Module) when is_atom(Module) -> + call({reset, Module}). +reset() -> + call(reset). + +%% stop() -> ok +stop() -> + call(stop). + +stop(Node) when is_atom(Node) -> + stop([Node]); +stop(Nodes) -> + call({stop,remove_myself(Nodes,[])}). + +%% bump(Module, Function, Arity, Clause, Line) +%% Module = Function = atom() +%% Arity = Clause = Line = integer() +%% This function is inserted into Cover compiled modules, once for each +%% executable line. +%bump(Module, Function, Arity, Clause, Line) -> +% Key = #bump{module=Module, function=Function, arity=Arity, clause=Clause, +% line=Line}, +% ets:update_counter(?COVER_TABLE, Key, 1). + +call(Request) -> + Ref = erlang:monitor(process,?SERVER), + receive {'DOWN', Ref, _Type, _Object, noproc} -> + erlang:demonitor(Ref), + start(), + call(Request) + after 0 -> + ?SERVER ! {self(),Request}, + Return = + receive + {'DOWN', Ref, _Type, _Object, Info} -> + exit(Info); + {?SERVER,Reply} -> + Reply + end, + erlang:demonitor(Ref), + Return + end. + +reply(From, Reply) -> + From ! {?SERVER,Reply}. +is_from(From) -> + is_pid(From). + +remote_call(Node,Request) -> + Ref = erlang:monitor(process,{?SERVER,Node}), + receive {'DOWN', Ref, _Type, _Object, noproc} -> + erlang:demonitor(Ref), + {error,node_dead} + after 0 -> + {?SERVER,Node} ! Request, + Return = + receive + {'DOWN', Ref, _Type, _Object, _Info} -> + {error,node_dead}; + {?SERVER,Reply} -> + Reply + end, + erlang:demonitor(Ref), + Return + end. + +remote_reply(MainNode,Reply) -> + {?SERVER,MainNode} ! {?SERVER,Reply}. + +%%%---------------------------------------------------------------------- +%%% cover_server on main node +%%%---------------------------------------------------------------------- + +init_main(Starter) -> + register(?SERVER,self()), + ets:new(?COVER_TABLE, [set, public, named_table]), + ets:new(?BINARY_TABLE, [set, named_table]), + ets:new(?COLLECTION_TABLE, [set, public, named_table]), + process_flag(trap_exit,true), + Starter ! {?SERVER,started}, + main_process_loop(#main_state{}). + +main_process_loop(State) -> + receive + {From, {start_nodes,Nodes}} -> + ThisNode = node(), + StartedNodes = + lists:foldl( + fun(Node,Acc) -> + case rpc:call(Node,cover,remote_start,[ThisNode]) of + {ok,RPid} -> + link(RPid), + [Node|Acc]; + Error -> + io:format("Could not start cover on ~w: ~p\n", + [Node,Error]), + Acc + end + end, + [], + Nodes), + + %% In case some of the compiled modules have been unloaded they + %% should not be loaded on the new node. + {_LoadedModules,Compiled} = + get_compiled_still_loaded(State#main_state.nodes, + State#main_state.compiled), + remote_load_compiled(StartedNodes,Compiled), + + State1 = + State#main_state{nodes = State#main_state.nodes ++ StartedNodes, + compiled = Compiled}, + reply(From, {ok,StartedNodes}), + main_process_loop(State1); + + {From, {compile, File, Options}} -> + case do_compile(File, Options) of + {ok, Module} -> + remote_load_compiled(State#main_state.nodes,[{Module,File}]), + reply(From, {ok, Module}), + Compiled = add_compiled(Module, File, + State#main_state.compiled), + Imported = remove_imported(Module,State#main_state.imported), + main_process_loop(State#main_state{compiled = Compiled, + imported = Imported}); + error -> + reply(From, {error, File}), + main_process_loop(State) + end; + + {From, {compile_beam, Module, BeamFile0}} -> + Compiled0 = State#main_state.compiled, + case get_beam_file(Module,BeamFile0,Compiled0) of + {ok,BeamFile} -> + {Reply,Compiled} = + case do_compile_beam(Module,BeamFile) of + {ok, Module} -> + remote_load_compiled(State#main_state.nodes, + [{Module,BeamFile}]), + C = add_compiled(Module,BeamFile,Compiled0), + {{ok,Module},C}; + error -> + {{error, BeamFile}, Compiled0}; + {error,Reason} -> % no abstract code + {{error, {Reason, BeamFile}}, Compiled0} + end, + reply(From,Reply), + Imported = remove_imported(Module,State#main_state.imported), + main_process_loop(State#main_state{compiled = Compiled, + imported = Imported}); + {error,no_beam} -> + %% The module has first been compiled from .erl, and now + %% someone tries to compile it from .beam + reply(From, + {error,{already_cover_compiled,no_beam_found,Module}}), + main_process_loop(State) + end; + + {From, {export,OutFile,Module}} -> + case file:open(OutFile,[write,binary,raw]) of + {ok,Fd} -> + Reply = + case Module of + '_' -> + export_info(State#main_state.imported), + collect(State#main_state.nodes), + do_export_table(State#main_state.compiled, + State#main_state.imported, + Fd); + _ -> + export_info(Module,State#main_state.imported), + case is_loaded(Module, State) of + {loaded, File} -> + [{Module,Clauses}] = + ets:lookup(?COVER_TABLE,Module), + collect(Module, Clauses, + State#main_state.nodes), + do_export_table([{Module,File}],[],Fd); + {imported, File, ImportFiles} -> + %% don't know if I should allow this - + %% export a module which is only imported + Imported = [{Module,File,ImportFiles}], + do_export_table([],Imported,Fd); + _NotLoaded -> + {error,{not_cover_compiled,Module}} + end + end, + file:close(Fd), + reply(From, Reply); + {error,Reason} -> + reply(From, {error, {cant_open_file,OutFile,Reason}}) + + end, + main_process_loop(State); + + {From, {import,File}} -> + case file:open(File,[read,binary,raw]) of + {ok,Fd} -> + Imported = do_import_to_table(Fd,File, + State#main_state.imported), + reply(From, ok), + main_process_loop(State#main_state{imported=Imported}); + {error,Reason} -> + reply(From, {error, {cant_open_file,File,Reason}}), + main_process_loop(State) + end; + + {From, modules} -> + %% Get all compiled modules which are still loaded + {LoadedModules,Compiled} = + get_compiled_still_loaded(State#main_state.nodes, + State#main_state.compiled), + + reply(From, LoadedModules), + main_process_loop(State#main_state{compiled=Compiled}); + + {From, imported_modules} -> + %% Get all modules with imported data + ImportedModules = lists:map(fun({Mod,_File,_ImportFile}) -> Mod end, + State#main_state.imported), + reply(From, ImportedModules), + main_process_loop(State); + + {From, imported} -> + %% List all imported files + reply(From, get_all_importfiles(State#main_state.imported,[])), + main_process_loop(State); + + {From, which_nodes} -> + %% List all imported files + reply(From, State#main_state.nodes), + main_process_loop(State); + + {From, reset} -> + lists:foreach( + fun({Module,_File}) -> + do_reset_main_node(Module,State#main_state.nodes) + end, + State#main_state.compiled), + reply(From, ok), + main_process_loop(State#main_state{imported=[]}); + + {From, {stop,Nodes}} -> + remote_collect('_',Nodes,true), + reply(From, ok), + State1 = State#main_state{nodes=State#main_state.nodes--Nodes}, + main_process_loop(State1); + + {From, stop} -> + lists:foreach( + fun(Node) -> + remote_call(Node,{remote,stop}) + end, + State#main_state.nodes), + reload_originals(State#main_state.compiled), + reply(From, ok); + + {From, {Request, Module}} -> + case is_loaded(Module, State) of + {loaded, File} -> + {Reply,State1} = + case Request of + {analyse, Analysis, Level} -> + analyse_info(Module,State#main_state.imported), + [{Module,Clauses}] = + ets:lookup(?COVER_TABLE,Module), + collect(Module,Clauses,State#main_state.nodes), + R = do_analyse(Module, Analysis, Level, Clauses), + {R,State}; + + {analyse_to_file, OutFile, Opts} -> + R = case find_source(File) of + {beam,_BeamFile} -> + {error,no_source_code_found}; + ErlFile -> + Imported = State#main_state.imported, + analyse_info(Module,Imported), + [{Module,Clauses}] = + ets:lookup(?COVER_TABLE,Module), + collect(Module, Clauses, + State#main_state.nodes), + HTML = lists:member(html,Opts), + do_analyse_to_file(Module,OutFile, + ErlFile,HTML) + end, + {R,State}; + + is_compiled -> + {{file, File},State}; + + reset -> + R = do_reset_main_node(Module, + State#main_state.nodes), + Imported = + remove_imported(Module, + State#main_state.imported), + {R,State#main_state{imported=Imported}} + end, + reply(From, Reply), + main_process_loop(State1); + + {imported,File,_ImportFiles} -> + {Reply,State1} = + case Request of + {analyse, Analysis, Level} -> + analyse_info(Module,State#main_state.imported), + [{Module,Clauses}] = + ets:lookup(?COLLECTION_TABLE,Module), + R = do_analyse(Module, Analysis, Level, Clauses), + {R,State}; + + {analyse_to_file, OutFile, Opts} -> + R = case find_source(File) of + {beam,_BeamFile} -> + {error,no_source_code_found}; + ErlFile -> + Imported = State#main_state.imported, + analyse_info(Module,Imported), + HTML = lists:member(html,Opts), + do_analyse_to_file(Module,OutFile, + ErlFile,HTML) + end, + {R,State}; + + is_compiled -> + {false,State}; + + reset -> + R = do_reset_collection_table(Module), + Imported = + remove_imported(Module, + State#main_state.imported), + {R,State#main_state{imported=Imported}} + end, + reply(From, Reply), + main_process_loop(State1); + + NotLoaded -> + Reply = + case Request of + is_compiled -> + false; + _ -> + {error, {not_cover_compiled,Module}} + end, + Compiled = + case NotLoaded of + unloaded -> + do_clear(Module), + remote_unload(State#main_state.nodes,[Module]), + update_compiled([Module], + State#main_state.compiled); + false -> + State#main_state.compiled + end, + reply(From, Reply), + main_process_loop(State#main_state{compiled=Compiled}) + end; + + {'EXIT',Pid,_Reason} -> + %% Exit is trapped on the main node only, so this will only happen + %% there. I assume that I'm only linked to cover_servers on remote + %% nodes, so this must be one of them crashing. + %% Remove node from list! + State1 = State#main_state{nodes=State#main_state.nodes--[node(Pid)]}, + main_process_loop(State1); + + get_status -> + io:format("~p~n",[State]), + main_process_loop(State) + end. + + + + + +%%%---------------------------------------------------------------------- +%%% cover_server on remote node +%%%---------------------------------------------------------------------- + +init_remote(Starter,MainNode) -> + register(?SERVER,self()), + ets:new(?COVER_TABLE, [set, public, named_table]), + Starter ! {self(),started}, + remote_process_loop(#remote_state{main_node=MainNode}). + + + +remote_process_loop(State) -> + receive + {remote,load_compiled,Compiled} -> + Compiled1 = load_compiled(Compiled,State#remote_state.compiled), + remote_reply(State#remote_state.main_node, ok), + remote_process_loop(State#remote_state{compiled=Compiled1}); + + {remote,unload,UnloadedModules} -> + unload(UnloadedModules), + Compiled = + update_compiled(UnloadedModules, State#remote_state.compiled), + remote_reply(State#remote_state.main_node, ok), + remote_process_loop(State#remote_state{compiled=Compiled}); + + {remote,reset,Module} -> + do_reset(Module), + remote_reply(State#remote_state.main_node, ok), + remote_process_loop(State); + + {remote,collect,Module,CollectorPid} -> + MS = + case Module of + '_' -> ets:fun2ms(fun({M,C}) when is_atom(M) -> C end); + _ -> ets:fun2ms(fun({M,C}) when M=:=Module -> C end) + end, + AllClauses = lists:flatten(ets:select(?COVER_TABLE,MS)), + + %% Sending clause by clause in order to avoid large lists + lists:foreach( + fun({M,F,A,C,_L}) -> + Pattern = + {#bump{module=M, function=F, arity=A, clause=C}, '_'}, + Bumps = ets:match_object(?COVER_TABLE, Pattern), + %% Reset + lists:foreach(fun({Bump,_N}) -> + ets:insert(?COVER_TABLE, {Bump,0}) + end, + Bumps), + CollectorPid ! {chunk,Bumps} + end, + AllClauses), + CollectorPid ! done, + remote_reply(State#remote_state.main_node, ok), + remote_process_loop(State); + + {remote,stop} -> + reload_originals(State#remote_state.compiled), + remote_reply(State#remote_state.main_node, ok); + + get_status -> + io:format("~p~n",[State]), + remote_process_loop(State); + + M -> + io:format("WARNING: remote cover_server received\n~p\n",[M]), + case M of + {From,_} -> + case is_from(From) of + true -> + reply(From,{error,not_main_node}); + false -> + ok + end; + _ -> + ok + end, + remote_process_loop(State) + + end. + + +reload_originals([{Module,_File}|Compiled]) -> + do_reload_original(Module), + reload_originals(Compiled); +reload_originals([]) -> + ok. + +do_reload_original(Module) -> + case code:which(Module) of + ?TAG -> + code:purge(Module), % remove code marked as 'old' + code:delete(Module), % mark cover compiled code as 'old' + %% Note: original beam code must be loaded before the cover + %% compiled code is purged, in order to for references to + %% 'fun M:F/A' and %% 'fun F/A' funs to be correct (they + %% refer to (M:)F/A in the *latest* version of the module) + code:load_file(Module), % load original code + code:purge(Module); % remove cover compiled code + _ -> + ignore + end. + +load_compiled([{Module,File,Binary,InitialTable}|Compiled],Acc) -> + %% Make sure the #bump{} records are available *before* the + %% module is loaded. + insert_initial_data(InitialTable), + NewAcc = + case code:load_binary(Module, ?TAG, Binary) of + {module,Module} -> + add_compiled(Module, File, Acc); + _ -> + do_clear(Module), + Acc + end, + load_compiled(Compiled,NewAcc); +load_compiled([],Acc) -> + Acc. + +insert_initial_data([Item|Items]) -> + ets:insert(?COVER_TABLE, Item), + insert_initial_data(Items); +insert_initial_data([]) -> + ok. + + +unload([Module|Modules]) -> + do_clear(Module), + do_reload_original(Module), + unload(Modules); +unload([]) -> + ok. + +%%%---------------------------------------------------------------------- +%%% Internal functions +%%%---------------------------------------------------------------------- + +%%%--Handling of remote nodes-------------------------------------------- + +%% start the cover_server on a remote node +remote_start(MainNode) -> + case whereis(?SERVER) of + undefined -> + Starter = self(), + Pid = spawn(fun() -> init_remote(Starter,MainNode) end), + Ref = erlang:monitor(process,Pid), + Return = + receive + {Pid,started} -> + {ok,Pid}; + {'DOWN', Ref, _Type, _Object, Info} -> + {error,Info} + end, + erlang:demonitor(Ref), + Return; + Pid -> + {error,{already_started,Pid}} + end. + +%% Load a set of cover compiled modules on remote nodes +remote_load_compiled(Nodes,Compiled0) -> + Compiled = lists:map(fun get_data_for_remote_loading/1,Compiled0), + lists:foreach( + fun(Node) -> + remote_call(Node,{remote,load_compiled,Compiled}) + end, + Nodes). + +%% Read all data needed for loading a cover compiled module on a remote node +%% Binary is the beam code for the module and InitialTable is the initial +%% data to insert in ?COVER_TABLE. +get_data_for_remote_loading({Module,File}) -> + [{Module,Binary}] = ets:lookup(?BINARY_TABLE,Module), + %%! The InitialTable list will be long if the module is big - what to do?? + InitialTable = ets:select(?COVER_TABLE,ms(Module)), + {Module,File,Binary,InitialTable}. + +%% Create a match spec which returns the clause info {Module,InitInfo} and +%% all #bump keys for the given module with 0 number of calls. +ms(Module) -> + ets:fun2ms(fun({Module,InitInfo}) -> + {Module,InitInfo}; + ({Key,_}) when is_record(Key,bump),Key#bump.module=:=Module -> + {Key,0} + end). + +%% Unload modules on remote nodes +remote_unload(Nodes,UnloadedModules) -> + lists:foreach( + fun(Node) -> + remote_call(Node,{remote,unload,UnloadedModules}) + end, + Nodes). + +%% Reset one or all modules on remote nodes +remote_reset(Module,Nodes) -> + lists:foreach( + fun(Node) -> + remote_call(Node,{remote,reset,Module}) + end, + Nodes). + +%% Collect data from remote nodes - used for analyse or stop(Node) +remote_collect(Module,Nodes,Stop) -> + CollectorPid = spawn(fun() -> collector_proc(length(Nodes)) end), + lists:foreach( + fun(Node) -> + remote_call(Node,{remote,collect,Module,CollectorPid}), + if Stop -> remote_call(Node,{remote,stop}); + true -> ok + end + end, + Nodes). + +%% Process which receives chunks of data from remote nodes - either when +%% analysing or when stopping cover on the remote nodes. +collector_proc(0) -> + ok; +collector_proc(N) -> + receive + {chunk,Chunk} -> + insert_in_collection_table(Chunk), + collector_proc(N); + done -> + collector_proc(N-1) + end. + +insert_in_collection_table([{Key,Val}|Chunk]) -> + insert_in_collection_table(Key,Val), + insert_in_collection_table(Chunk); +insert_in_collection_table([]) -> + ok. + +insert_in_collection_table(Key,Val) -> + case ets:member(?COLLECTION_TABLE,Key) of + true -> + ets:update_counter(?COLLECTION_TABLE, + Key,Val); + false -> + ets:insert(?COLLECTION_TABLE,{Key,Val}) + end. + + +remove_myself([Node|Nodes],Acc) when Node=:=node() -> + remove_myself(Nodes,Acc); +remove_myself([Node|Nodes],Acc) -> + remove_myself(Nodes,[Node|Acc]); +remove_myself([],Acc) -> + Acc. + + +%%%--Handling of modules state data-------------------------------------- + +analyse_info(_Module,[]) -> + ok; +analyse_info(Module,Imported) -> + imported_info("Analysis",Module,Imported). + +export_info(_Module,[]) -> + ok; +export_info(Module,Imported) -> + imported_info("Export",Module,Imported). + +export_info([]) -> + ok; +export_info(Imported) -> + AllImportFiles = get_all_importfiles(Imported,[]), + io:format("Export includes data from imported files\n~p\n",[AllImportFiles]). + +get_all_importfiles([{_M,_F,ImportFiles}|Imported],Acc) -> + NewAcc = do_get_all_importfiles(ImportFiles,Acc), + get_all_importfiles(Imported,NewAcc); +get_all_importfiles([],Acc) -> + Acc. + +do_get_all_importfiles([ImportFile|ImportFiles],Acc) -> + case lists:member(ImportFile,Acc) of + true -> + do_get_all_importfiles(ImportFiles,Acc); + false -> + do_get_all_importfiles(ImportFiles,[ImportFile|Acc]) + end; +do_get_all_importfiles([],Acc) -> + Acc. + +imported_info(Text,Module,Imported) -> + case lists:keysearch(Module,1,Imported) of + {value,{Module,_File,ImportFiles}} -> + io:format("~s includes data from imported files\n~p\n", + [Text,ImportFiles]); + false -> + ok + end. + + + +add_imported(Module, File, ImportFile, Imported) -> + add_imported(Module, File, filename:absname(ImportFile), Imported, []). + +add_imported(M, F1, ImportFile, [{M,_F2,ImportFiles}|Imported], Acc) -> + case lists:member(ImportFile,ImportFiles) of + true -> + io:fwrite("WARNING: Module ~w already imported from ~p~n" + "Not importing again!~n",[M,ImportFile]), + dont_import; + false -> + NewEntry = {M, F1, [ImportFile | ImportFiles]}, + {ok, reverse([NewEntry | Acc]) ++ Imported} + end; +add_imported(M, F, ImportFile, [H|Imported], Acc) -> + add_imported(M, F, ImportFile, Imported, [H|Acc]); +add_imported(M, F, ImportFile, [], Acc) -> + {ok, reverse([{M, F, [ImportFile]} | Acc])}. + +%% Removes a module from the list of imported modules and writes a warning +%% This is done when a module is compiled. +remove_imported(Module,Imported) -> + case lists:keysearch(Module,1,Imported) of + {value,{Module,_,ImportFiles}} -> + io:fwrite("WARNING: Deleting data for module ~w imported from~n" + "~p~n",[Module,ImportFiles]), + lists:keydelete(Module,1,Imported); + false -> + Imported + end. + +%% Adds information to the list of compiled modules, preserving time order +%% and without adding duplicate entries. +add_compiled(Module, File1, [{Module,_File2}|Compiled]) -> + [{Module,File1}|Compiled]; +add_compiled(Module, File, [H|Compiled]) -> + [H|add_compiled(Module, File, Compiled)]; +add_compiled(Module, File, []) -> + [{Module,File}]. + +is_loaded(Module, State) -> + case get_file(Module, State#main_state.compiled) of + {ok, File} -> + case code:which(Module) of + ?TAG -> {loaded, File}; + _ -> unloaded + end; + false -> + case get_file(Module,State#main_state.imported) of + {ok,File,ImportFiles} -> + {imported, File, ImportFiles}; + false -> + false + end + end. + +get_file(Module, [{Module, File}|_T]) -> + {ok, File}; +get_file(Module, [{Module, File, ImportFiles}|_T]) -> + {ok, File, ImportFiles}; +get_file(Module, [_H|T]) -> + get_file(Module, T); +get_file(_Module, []) -> + false. + +get_beam_file(Module,?TAG,Compiled) -> + {value,{Module,File}} = lists:keysearch(Module,1,Compiled), + case filename:extension(File) of + ".erl" -> {error,no_beam}; + ".beam" -> {ok,File} + end; +get_beam_file(_Module,BeamFile,_Compiled) -> + {ok,BeamFile}. + +get_modules(Compiled) -> + lists:map(fun({Module, _File}) -> Module end, Compiled). + +update_compiled([Module|Modules], [{Module,_File}|Compiled]) -> + update_compiled(Modules, Compiled); +update_compiled(Modules, [H|Compiled]) -> + [H|update_compiled(Modules, Compiled)]; +update_compiled(_Modules, []) -> + []. + +%% Get all compiled modules which are still loaded, and possibly an +%% updated version of the Compiled list. +get_compiled_still_loaded(Nodes,Compiled0) -> + %% Find all Cover compiled modules which are still loaded + CompiledModules = get_modules(Compiled0), + LoadedModules = lists:filter(fun(Module) -> + case code:which(Module) of + ?TAG -> true; + _ -> false + end + end, + CompiledModules), + + %% If some Cover compiled modules have been unloaded, update the database. + UnloadedModules = CompiledModules--LoadedModules, + Compiled = + case UnloadedModules of + [] -> + Compiled0; + _ -> + lists:foreach(fun(Module) -> do_clear(Module) end, + UnloadedModules), + remote_unload(Nodes,UnloadedModules), + update_compiled(UnloadedModules, Compiled0) + end, + {LoadedModules,Compiled}. + + +%%%--Compilation--------------------------------------------------------- + +%% do_compile(File, Options) -> {ok,Module} | {error,Error} +do_compile(File, UserOptions) -> + Options = [debug_info,binary,report_errors,report_warnings] ++ UserOptions, + case compile:file(File, Options) of + {ok, Module, Binary} -> + do_compile_beam(Module,Binary); + error -> + error + end. + +%% Beam is a binary or a .beam file name +do_compile_beam(Module,Beam) -> + %% Clear database + do_clear(Module), + + %% Extract the abstract format and insert calls to bump/6 at + %% every executable line and, as a side effect, initiate + %% the database + + case get_abstract_code(Module, Beam) of + no_abstract_code=E -> + {error,E}; + encrypted_abstract_code=E -> + {error,E}; + {Vsn,Code} -> + Forms0 = epp:interpret_file_attribute(Code), + {Forms,Vars} = transform(Vsn, Forms0, Module, Beam), + + %% Compile and load the result + %% It's necessary to check the result of loading since it may + %% fail, for example if Module resides in a sticky directory + {ok, Module, Binary} = compile:forms(Forms, []), + case code:load_binary(Module, ?TAG, Binary) of + {module, Module} -> + + %% Store info about all function clauses in database + InitInfo = reverse(Vars#vars.init_info), + ets:insert(?COVER_TABLE, {Module, InitInfo}), + + %% Store binary code so it can be loaded on remote nodes + ets:insert(?BINARY_TABLE, {Module, Binary}), + + {ok, Module}; + + _Error -> + do_clear(Module), + error + end + end. + +get_abstract_code(Module, Beam) -> + case beam_lib:chunks(Beam, [abstract_code]) of + {ok, {Module, [{abstract_code, AbstractCode}]}} -> + AbstractCode; + {error,beam_lib,{key_missing_or_invalid,_,_}} -> + encrypted_abstract_code; + Error -> Error + end. + +transform(Vsn, Code, Module, Beam) when Vsn=:=abstract_v1; Vsn=:=abstract_v2 -> + Vars0 = #vars{module=Module, vsn=Vsn}, + MainFile=find_main_filename(Code), + {ok, MungedForms,Vars} = transform_2(Code,[],Vars0,MainFile,on), + + %% Add module and export information to the munged forms + %% Information about module_info must be removed as this function + %% is added at compilation + {ok, {Module, [{exports,Exports1}]}} = beam_lib:chunks(Beam, [exports]), + Exports2 = lists:filter(fun(Export) -> + case Export of + {module_info,_} -> false; + _ -> true + end + end, + Exports1), + Forms = [{attribute,1,module,Module}, + {attribute,2,export,Exports2}]++ MungedForms, + {Forms,Vars}; +transform(Vsn=raw_abstract_v1, Code, Module, _Beam) -> + MainFile=find_main_filename(Code), + Vars0 = #vars{module=Module, vsn=Vsn}, + {ok,MungedForms,Vars} = transform_2(Code,[],Vars0,MainFile,on), + {MungedForms,Vars}. + +%% Helpfunction which returns the first found file-attribute, which can +%% be interpreted as the name of the main erlang source file. +find_main_filename([{attribute,_,file,{MainFile,_}}|_]) -> + MainFile; +find_main_filename([_|Rest]) -> + find_main_filename(Rest). + +transform_2([Form0|Forms],MungedForms,Vars,MainFile,Switch) -> + Form = expand(Form0), + case munge(Form,Vars,MainFile,Switch) of + ignore -> + transform_2(Forms,MungedForms,Vars,MainFile,Switch); + {MungedForm,Vars2,NewSwitch} -> + transform_2(Forms,[MungedForm|MungedForms],Vars2,MainFile,NewSwitch) + end; +transform_2([],MungedForms,Vars,_,_) -> + {ok, reverse(MungedForms), Vars}. + +%% Expand short-circuit Boolean expressions. +expand(Expr) -> + AllVars = sets:from_list(ordsets:to_list(vars([], Expr))), + {Expr1,_} = expand(Expr, AllVars, 1), + Expr1. + +expand({clause,Line,Pattern,Guards,Body}, Vs, N) -> + {ExpandedBody,N2} = expand(Body, Vs, N), + {{clause,Line,Pattern,Guards,ExpandedBody},N2}; +expand({op,_Line,'andalso',ExprL,ExprR}, Vs, N) -> + {ExpandedExprL,N2} = expand(ExprL, Vs, N), + {ExpandedExprR,N3} = expand(ExprR, Vs, N2), + LineL = element(2, ExpandedExprL), + {bool_switch(ExpandedExprL, + ExpandedExprR, + {atom,LineL,false}, + Vs, N3), + N3 + 1}; +expand({op,_Line,'orelse',ExprL,ExprR}, Vs, N) -> + {ExpandedExprL,N2} = expand(ExprL, Vs, N), + {ExpandedExprR,N3} = expand(ExprR, Vs, N2), + LineL = element(2, ExpandedExprL), + {bool_switch(ExpandedExprL, + {atom,LineL,true}, + ExpandedExprR, + Vs, N3), + N3 + 1}; +expand(T, Vs, N) when is_tuple(T) -> + {TL,N2} = expand(tuple_to_list(T), Vs, N), + {list_to_tuple(TL),N2}; +expand([E|Es], Vs, N) -> + {E2,N2} = expand(E, Vs, N), + {Es2,N3} = expand(Es, Vs, N2), + {[E2|Es2],N3}; +expand(T, _Vs, N) -> + {T,N}. + +vars(A, {var,_,V}) when V =/= '_' -> + [V|A]; +vars(A, T) when is_tuple(T) -> + vars(A, tuple_to_list(T)); +vars(A, [E|Es]) -> + vars(vars(A, E), Es); +vars(A, _T) -> + A. + +bool_switch(E, T, F, AllVars, AuxVarN) -> + Line = element(2, E), + AuxVar = {var,Line,aux_var(AllVars, AuxVarN)}, + {'case',Line,E, + [{clause,Line,[{atom,Line,true}],[],[T]}, + {clause,Line,[{atom,Line,false}],[],[F]}, + {clause,Line,[AuxVar],[], + [{call,Line, + {remote,Line,{atom,Line,erlang},{atom,Line,error}}, + [{tuple,Line,[{atom,Line,badarg},AuxVar]}]}]}]}. + +aux_var(Vars, N) -> + Name = list_to_atom(lists:concat(['_', N])), + case sets:is_element(Name, Vars) of + true -> aux_var(Vars, N + 1); + false -> Name + end. + +%% This code traverses the abstract code, stored as the abstract_code +%% chunk in the BEAM file, as described in absform(3) for Erlang/OTP R8B +%% (Vsn=abstract_v2). +%% The abstract format after preprocessing differs slightly from the abstract +%% format given eg using epp:parse_form, this has been noted in comments. +%% The switch is turned off when we encounter other files then the main file. +%% This way we will be able to exclude functions defined in include files. +munge({function,0,module_info,_Arity,_Clauses},_Vars,_MainFile,_Switch) -> + ignore; % module_info will be added again when the forms are recompiled +munge(Form={function,_,'MNEMOSYNE QUERY',_,_},Vars,_MainFile,Switch) -> + {Form,Vars,Switch}; % No bumps in Mnemosyne code. +munge(Form={function,_,'MNEMOSYNE RULE',_,_},Vars,_MainFile,Switch) -> + {Form,Vars,Switch}; +munge(Form={function,_,'MNEMOSYNE RECFUNDEF',_,_},Vars,_MainFile,Switch) -> + {Form,Vars,Switch}; +munge({function,Line,Function,Arity,Clauses},Vars,_MainFile,on) -> + Vars2 = Vars#vars{function=Function, + arity=Arity, + clause=1, + lines=[], + no_bump_lines=[], + depth=1}, + {MungedClauses, Vars3} = munge_clauses(Clauses, Vars2), + {{function,Line,Function,Arity,MungedClauses},Vars3,on}; +munge(Form={attribute,_,file,{MainFile,_}},Vars,MainFile,_Switch) -> + {Form,Vars,on}; % Switch on tranformation! +munge(Form={attribute,_,file,{_InclFile,_}},Vars,_MainFile,_Switch) -> + {Form,Vars,off}; % Switch off transformation! +munge({attribute,_,compile,{parse_transform,_}},_Vars,_MainFile,_Switch) -> + %% Don't want to run parse transforms more than once. + ignore; +munge(Form,Vars,_MainFile,Switch) -> % Other attributes and skipped includes. + {Form,Vars,Switch}. + +munge_clauses(Clauses, Vars) -> + munge_clauses(Clauses, Vars, Vars#vars.lines, []). + +munge_clauses([Clause|Clauses], Vars, Lines, MClauses) -> + {clause,Line,Pattern,Guards,Body} = Clause, + {MungedGuards, _Vars} = munge_exprs(Guards, Vars#vars{is_guard=true},[]), + + case Vars#vars.depth of + 1 -> % function clause + {MungedBody, Vars2} = munge_body(Body, Vars#vars{depth=2}), + ClauseInfo = {Vars2#vars.module, + Vars2#vars.function, + Vars2#vars.arity, + Vars2#vars.clause, + length(Vars2#vars.lines)}, % Not used? + InitInfo = [ClauseInfo | Vars2#vars.init_info], + Vars3 = Vars2#vars{init_info=InitInfo, + clause=(Vars2#vars.clause)+1, + lines=[], + no_bump_lines=[], + depth=1}, + NewBumps = Vars2#vars.lines, + NewLines = NewBumps ++ Lines, + munge_clauses(Clauses, Vars3, NewLines, + [{clause,Line,Pattern,MungedGuards,MungedBody}| + MClauses]); + + 2 -> % receive-, case-, if-, or try-clause + Lines0 = Vars#vars.lines, + {MungedBody, Vars2} = munge_body(Body, Vars), + NewBumps = new_bumps(Vars2, Vars), + NewLines = NewBumps ++ Lines, + munge_clauses(Clauses, Vars2#vars{lines=Lines0}, + NewLines, + [{clause,Line,Pattern,MungedGuards,MungedBody}| + MClauses]) + end; +munge_clauses([], Vars, Lines, MungedClauses) -> + {reverse(MungedClauses), Vars#vars{lines = Lines}}. + +munge_body(Expr, Vars) -> + munge_body(Expr, Vars, [], []). + +munge_body([Expr|Body], Vars, MungedBody, LastExprBumpLines) -> + %% Here is the place to add a call to cover:bump/6! + Line = element(2, Expr), + Lines = Vars#vars.lines, + case lists:member(Line,Lines) of + true -> % already a bump at this line + {MungedExpr, Vars2} = munge_expr(Expr, Vars), + NewBumps = new_bumps(Vars2, Vars), + NoBumpLines = [Line|Vars#vars.no_bump_lines], + Vars3 = Vars2#vars{no_bump_lines = NoBumpLines}, + MungedBody1 = + maybe_fix_last_expr(MungedBody, Vars3, LastExprBumpLines), + MungedExprs1 = [MungedExpr|MungedBody1], + munge_body(Body, Vars3, MungedExprs1, NewBumps); + false -> + ets:insert(?COVER_TABLE, {#bump{module = Vars#vars.module, + function = Vars#vars.function, + arity = Vars#vars.arity, + clause = Vars#vars.clause, + line = Line}, + 0}), + Bump = bump_call(Vars, Line), +% Bump = {call, 0, {remote, 0, {atom,0,cover}, {atom,0,bump}}, +% [{atom, 0, Vars#vars.module}, +% {atom, 0, Vars#vars.function}, +% {integer, 0, Vars#vars.arity}, +% {integer, 0, Vars#vars.clause}, +% {integer, 0, Line}]}, + Lines2 = [Line|Lines], + {MungedExpr, Vars2} = munge_expr(Expr, Vars#vars{lines=Lines2}), + NewBumps = new_bumps(Vars2, Vars), + NoBumpLines = subtract(Vars2#vars.no_bump_lines, NewBumps), + Vars3 = Vars2#vars{no_bump_lines = NoBumpLines}, + MungedBody1 = + maybe_fix_last_expr(MungedBody, Vars3, LastExprBumpLines), + MungedExprs1 = [MungedExpr,Bump|MungedBody1], + munge_body(Body, Vars3, MungedExprs1, NewBumps) + end; +munge_body([], Vars, MungedBody, _LastExprBumpLines) -> + {reverse(MungedBody), Vars}. + +%%% Fix last expression (OTP-8188). A typical example: +%%% +%%% 3: case X of +%%% 4: 1 -> a; % Bump line 5 after "a" has been evaluated! +%%% 5: 2 -> b; 3 -> c end, F() +%%% +%%% Line 5 wasn't bumped just before "F()" since it was already bumped +%%% before "b" (and before "c") (one mustn't bump a line more than +%%% once in a single "evaluation"). The expression "case X ... end" is +%%% now traversed again ("fixed"), this time adding bumps of line 5 +%%% where appropriate, in this case when X matches 1. +%%% +%%% This doesn't solve all problems with expressions on the same line, +%%% though. 'case' and 'try' are tricky. An example: +%%% +%%% 7: case case X of 1 -> foo(); % ? +%%% 8: 2 -> bar() end of a -> 1; +%%% 9: b -> 2 end. +%%% +%%% If X matches 1 and foo() evaluates to a then line 8 should be +%%% bumped, but not if foo() evaluates to b. In other words, line 8 +%%% cannot be bumped after "foo()" on line 7, so one has to bump line +%%% 8 before "begin 1 end". But if X matches 2 and bar evaluates to a +%%% then line 8 would be bumped twice (there has to be a bump before +%%% "bar()". It is like one would have to have two copies of the inner +%%% clauses, one for each outer clause. Maybe the munging should be +%%% done on some of the compiler's "lower level" format. +%%% +%%% 'fun' is also problematic since a bump inside the body "shadows" +%%% the rest of the line. + +maybe_fix_last_expr(MungedExprs, Vars, LastExprBumpLines) -> + case last_expr_needs_fixing(Vars, LastExprBumpLines) of + {yes, Line} -> + fix_last_expr(MungedExprs, Line, Vars); + no -> + MungedExprs + end. + +last_expr_needs_fixing(Vars, LastExprBumpLines) -> + case common_elems(Vars#vars.no_bump_lines, LastExprBumpLines) of + [Line] -> {yes, Line}; + _ -> no + end. + +fix_last_expr([MungedExpr|MungedExprs], Line, Vars) -> + %% No need to update ?COVER_TABLE. + Bump = bump_call(Vars, Line), + [fix_expr(MungedExpr, Line, Bump)|MungedExprs]. + +fix_expr({'if',L,Clauses}, Line, Bump) -> + FixedClauses = fix_clauses(Clauses, Line, Bump), + {'if',L,FixedClauses}; +fix_expr({'case',L,Expr,Clauses}, Line, Bump) -> + FixedExpr = fix_expr(Expr, Line, Bump), + FixedClauses = fix_clauses(Clauses, Line, Bump), + {'case',L,FixedExpr,FixedClauses}; +fix_expr({'receive',L,Clauses}, Line, Bump) -> + FixedClauses = fix_clauses(Clauses, Line, Bump), + {'receive',L,FixedClauses}; +fix_expr({'receive',L,Clauses,Expr,Body}, Line, Bump) -> + FixedClauses = fix_clauses(Clauses, Line, Bump), + FixedExpr = fix_expr(Expr, Line, Bump), + FixedBody = fix_expr(Body, Line, Bump), + {'receive',L,FixedClauses,FixedExpr,FixedBody}; +fix_expr({'try',L,Exprs,Clauses,CatchClauses,After}, Line, Bump) -> + FixedExprs = fix_expr(Exprs, Line, Bump), + FixedClauses = fix_clauses(Clauses, Line, Bump), + FixedCatchClauses = fix_clauses(CatchClauses, Line, Bump), + FixedAfter = fix_expr(After, Line, Bump), + {'try',L,FixedExprs,FixedClauses,FixedCatchClauses,FixedAfter}; +fix_expr([E | Es], Line, Bump) -> + [fix_expr(E, Line, Bump) | fix_expr(Es, Line, Bump)]; +fix_expr(T, Line, Bump) when is_tuple(T) -> + list_to_tuple(fix_expr(tuple_to_list(T), Line, Bump)); +fix_expr(E, _Line, _Bump) -> + E. + +fix_clauses(Cs, Line, Bump) -> + case bumps_line(lists:last(Cs), Line) of + true -> + fix_cls(Cs, Line, Bump); + false -> + Cs + end. + +fix_cls([], _Line, _Bump) -> + []; +fix_cls([Cl | Cls], Line, Bump) -> + case bumps_line(Cl, Line) of + true -> + [fix_expr(C, Line, Bump) || C <- [Cl | Cls]]; + false -> + {clause,CL,P,G,Body} = Cl, + UniqueVarName = list_to_atom(lists:concat(["$cover$ ",Line])), + V = {var,0,UniqueVarName}, + [Last|Rest] = lists:reverse(Body), + Body1 = lists:reverse(Rest, [{match,0,V,Last},Bump,V]), + [{clause,CL,P,G,Body1} | fix_cls(Cls, Line, Bump)] + end. + +bumps_line(E, L) -> + try bumps_line1(E, L) catch true -> true end. + +bumps_line1({call,0,{remote,0,{atom,0,ets},{atom,0,update_counter}}, + [{atom,0,?COVER_TABLE},{tuple,0,[_,_,_,_,_,{integer,0,Line}]},_]}, + Line) -> + throw(true); +bumps_line1([E | Es], Line) -> + bumps_line1(E, Line), + bumps_line1(Es, Line); +bumps_line1(T, Line) when is_tuple(T) -> + bumps_line1(tuple_to_list(T), Line); +bumps_line1(_, _) -> + false. + +%%% End of fix of last expression. + +bump_call(Vars, Line) -> + {call,0,{remote,0,{atom,0,ets},{atom,0,update_counter}}, + [{atom,0,?COVER_TABLE}, + {tuple,0,[{atom,0,?BUMP_REC_NAME}, + {atom,0,Vars#vars.module}, + {atom,0,Vars#vars.function}, + {integer,0,Vars#vars.arity}, + {integer,0,Vars#vars.clause}, + {integer,0,Line}]}, + {integer,0,1}]}. + +munge_expr({match,Line,ExprL,ExprR}, Vars) -> + {MungedExprL, Vars2} = munge_expr(ExprL, Vars), + {MungedExprR, Vars3} = munge_expr(ExprR, Vars2), + {{match,Line,MungedExprL,MungedExprR}, Vars3}; +munge_expr({tuple,Line,Exprs}, Vars) -> + {MungedExprs, Vars2} = munge_exprs(Exprs, Vars, []), + {{tuple,Line,MungedExprs}, Vars2}; +munge_expr({record,Line,Expr,Exprs}, Vars) -> + %% Only for Vsn=raw_abstract_v1 + {MungedExprName, Vars2} = munge_expr(Expr, Vars), + {MungedExprFields, Vars3} = munge_exprs(Exprs, Vars2, []), + {{record,Line,MungedExprName,MungedExprFields}, Vars3}; +munge_expr({record_field,Line,ExprL,ExprR}, Vars) -> + %% Only for Vsn=raw_abstract_v1 + {MungedExprL, Vars2} = munge_expr(ExprL, Vars), + {MungedExprR, Vars3} = munge_expr(ExprR, Vars2), + {{record_field,Line,MungedExprL,MungedExprR}, Vars3}; +munge_expr({cons,Line,ExprH,ExprT}, Vars) -> + {MungedExprH, Vars2} = munge_expr(ExprH, Vars), + {MungedExprT, Vars3} = munge_expr(ExprT, Vars2), + {{cons,Line,MungedExprH,MungedExprT}, Vars3}; +munge_expr({op,Line,Op,ExprL,ExprR}, Vars) -> + {MungedExprL, Vars2} = munge_expr(ExprL, Vars), + {MungedExprR, Vars3} = munge_expr(ExprR, Vars2), + {{op,Line,Op,MungedExprL,MungedExprR}, Vars3}; +munge_expr({op,Line,Op,Expr}, Vars) -> + {MungedExpr, Vars2} = munge_expr(Expr, Vars), + {{op,Line,Op,MungedExpr}, Vars2}; +munge_expr({'catch',Line,Expr}, Vars) -> + {MungedExpr, Vars2} = munge_expr(Expr, Vars), + {{'catch',Line,MungedExpr}, Vars2}; +munge_expr({call,Line1,{remote,Line2,ExprM,ExprF},Exprs}, + Vars) when Vars#vars.is_guard=:=false-> + {MungedExprM, Vars2} = munge_expr(ExprM, Vars), + {MungedExprF, Vars3} = munge_expr(ExprF, Vars2), + {MungedExprs, Vars4} = munge_exprs(Exprs, Vars3, []), + {{call,Line1,{remote,Line2,MungedExprM,MungedExprF},MungedExprs}, Vars4}; +munge_expr({call,Line1,{remote,_Line2,_ExprM,ExprF},Exprs}, + Vars) when Vars#vars.is_guard=:=true -> + %% Difference in abstract format after preprocessing: BIF calls in guards + %% are translated to {remote,...} (which is not allowed as source form) + %% NOT NECESSARY FOR Vsn=raw_abstract_v1 + munge_expr({call,Line1,ExprF,Exprs}, Vars); +munge_expr({call,Line,Expr,Exprs}, Vars) -> + {MungedExpr, Vars2} = munge_expr(Expr, Vars), + {MungedExprs, Vars3} = munge_exprs(Exprs, Vars2, []), + {{call,Line,MungedExpr,MungedExprs}, Vars3}; +munge_expr({lc,Line,Expr,Qs}, Vars) -> + {MungedExpr, Vars2} = munge_expr(?BLOCK1(Expr), Vars), + {MungedQs, Vars3} = munge_qualifiers(Qs, Vars2), + {{lc,Line,MungedExpr,MungedQs}, Vars3}; +munge_expr({bc,Line,Expr,Qs}, Vars) -> + {bin,BLine,[{bin_element,EL,Val,Sz,TSL}]} = Expr, + Expr2 = {bin,BLine,[{bin_element,EL,?BLOCK1(Val),Sz,TSL}]}, + {MungedExpr,Vars2} = munge_expr(Expr2, Vars), + {MungedQs, Vars3} = munge_qualifiers(Qs, Vars2), + {{bc,Line,MungedExpr,MungedQs}, Vars3}; +munge_expr({block,Line,Body}, Vars) -> + {MungedBody, Vars2} = munge_body(Body, Vars), + {{block,Line,MungedBody}, Vars2}; +munge_expr({'if',Line,Clauses}, Vars) -> + {MungedClauses,Vars2} = munge_clauses(Clauses, Vars), + {{'if',Line,MungedClauses}, Vars2}; +munge_expr({'case',Line,Expr,Clauses}, Vars) -> + {MungedExpr,Vars2} = munge_expr(Expr, Vars), + {MungedClauses,Vars3} = munge_clauses(Clauses, Vars2), + {{'case',Line,MungedExpr,MungedClauses}, Vars3}; +munge_expr({'receive',Line,Clauses}, Vars) -> + {MungedClauses,Vars2} = munge_clauses(Clauses, Vars), + {{'receive',Line,MungedClauses}, Vars2}; +munge_expr({'receive',Line,Clauses,Expr,Body}, Vars) -> + {MungedExpr, Vars1} = munge_expr(Expr, Vars), + {MungedClauses,Vars2} = munge_clauses(Clauses, Vars1), + {MungedBody,Vars3} = + munge_body(Body, Vars2#vars{lines = Vars1#vars.lines}), + Vars4 = Vars3#vars{lines = Vars2#vars.lines ++ new_bumps(Vars3, Vars2)}, + {{'receive',Line,MungedClauses,MungedExpr,MungedBody}, Vars4}; +munge_expr({'try',Line,Body,Clauses,CatchClauses,After}, Vars) -> + {MungedBody, Vars1} = munge_body(Body, Vars), + {MungedClauses, Vars2} = munge_clauses(Clauses, Vars1), + {MungedCatchClauses, Vars3} = munge_clauses(CatchClauses, Vars2), + {MungedAfter, Vars4} = munge_body(After, Vars3), + {{'try',Line,MungedBody,MungedClauses,MungedCatchClauses,MungedAfter}, + Vars4}; +%% Difference in abstract format after preprocessing: Funs get an extra +%% element Extra. +%% NOT NECESSARY FOR Vsn=raw_abstract_v1 +munge_expr({'fun',Line,{function,Name,Arity},_Extra}, Vars) -> + {{'fun',Line,{function,Name,Arity}}, Vars}; +munge_expr({'fun',Line,{clauses,Clauses},_Extra}, Vars) -> + {MungedClauses,Vars2}=munge_clauses(Clauses, Vars), + {{'fun',Line,{clauses,MungedClauses}}, Vars2}; +munge_expr({'fun',Line,{clauses,Clauses}}, Vars) -> + %% Only for Vsn=raw_abstract_v1 + {MungedClauses,Vars2}=munge_clauses(Clauses, Vars), + {{'fun',Line,{clauses,MungedClauses}}, Vars2}; +munge_expr({bin,Line,BinElements}, Vars) -> + {MungedBinElements,Vars2} = munge_exprs(BinElements, Vars, []), + {{bin,Line,MungedBinElements}, Vars2}; +munge_expr({bin_element,Line,Value,Size,TypeSpecifierList}, Vars) -> + {MungedValue,Vars2} = munge_expr(Value, Vars), + {MungedSize,Vars3} = munge_expr(Size, Vars2), + {{bin_element,Line,MungedValue,MungedSize,TypeSpecifierList},Vars3}; +munge_expr(Form, Vars) -> % var|char|integer|float|string|atom|nil|eof|default + {Form, Vars}. + +munge_exprs([Expr|Exprs], Vars, MungedExprs) when Vars#vars.is_guard=:=true, + is_list(Expr) -> + {MungedExpr, _Vars} = munge_exprs(Expr, Vars, []), + munge_exprs(Exprs, Vars, [MungedExpr|MungedExprs]); +munge_exprs([Expr|Exprs], Vars, MungedExprs) -> + {MungedExpr, Vars2} = munge_expr(Expr, Vars), + munge_exprs(Exprs, Vars2, [MungedExpr|MungedExprs]); +munge_exprs([], Vars, MungedExprs) -> + {reverse(MungedExprs), Vars}. + +%% Every qualifier is decorated with a counter. +munge_qualifiers(Qualifiers, Vars) -> + munge_qs(Qualifiers, Vars, []). + +munge_qs([{generate,Line,Pattern,Expr}|Qs], Vars, MQs) -> + L = element(2, Expr), + {MungedExpr, Vars2} = munge_expr(Expr, Vars), + munge_qs1(Qs, L, {generate,Line,Pattern,MungedExpr}, Vars, Vars2, MQs); +munge_qs([{b_generate,Line,Pattern,Expr}|Qs], Vars, MQs) -> + L = element(2, Expr), + {MExpr, Vars2} = munge_expr(Expr, Vars), + munge_qs1(Qs, L, {b_generate,Line,Pattern,MExpr}, Vars, Vars2, MQs); +munge_qs([Expr|Qs], Vars, MQs) -> + L = element(2, Expr), + {MungedExpr, Vars2} = munge_expr(Expr, Vars), + munge_qs1(Qs, L, MungedExpr, Vars, Vars2, MQs); +munge_qs([], Vars, MQs) -> + {reverse(MQs), Vars}. + +munge_qs1(Qs, Line, NQ, Vars, Vars2, MQs) -> + case new_bumps(Vars2, Vars) of + [_] -> + munge_qs(Qs, Vars2, [NQ | MQs]); + _ -> + {MungedTrue, Vars3} = munge_expr(?BLOCK({atom,Line,true}), Vars2), + munge_qs(Qs, Vars3, [NQ, MungedTrue | MQs]) + end. + +new_bumps(#vars{lines = New}, #vars{lines = Old}) -> + subtract(New, Old). + +subtract(L1, L2) -> + [E || E <- L1, not lists:member(E, L2)]. + +common_elems(L1, L2) -> + [E || E <- L1, lists:member(E, L2)]. + +%%%--Analysis------------------------------------------------------------ + +%% Collect data for all modules +collect(Nodes) -> + %% local node + MS = ets:fun2ms(fun({M,C}) when is_atom(M) -> {M,C} end), + AllClauses = ets:select(?COVER_TABLE,MS), + move_modules(AllClauses), + + %% remote nodes + remote_collect('_',Nodes,false). + +%% Collect data for one module +collect(Module,Clauses,Nodes) -> + %% local node + move_modules([{Module,Clauses}]), + + %% remote nodes + remote_collect(Module,Nodes,false). + + +%% When analysing, the data from the local ?COVER_TABLE is moved to the +%% ?COLLECTION_TABLE. Resetting data in ?COVER_TABLE +move_modules([{Module,Clauses}|AllClauses]) -> + ets:insert(?COLLECTION_TABLE,{Module,Clauses}), + move_clauses(Clauses), + move_modules(AllClauses); +move_modules([]) -> + ok. + +move_clauses([{M,F,A,C,_L}|Clauses]) -> + Pattern = {#bump{module=M, function=F, arity=A, clause=C}, '_'}, + Bumps = ets:match_object(?COVER_TABLE,Pattern), + lists:foreach(fun({Key,Val}) -> + ets:insert(?COVER_TABLE, {Key,0}), + insert_in_collection_table(Key,Val) + end, + Bumps), + move_clauses(Clauses); +move_clauses([]) -> + ok. + + +%% Given a .beam file, find the .erl file. Look first in same directory as +%% the .beam file, then in /../src +find_source(File0) -> + case filename:rootname(File0,".beam") of + File0 -> + File0; + File -> + InSameDir = File++".erl", + case filelib:is_file(InSameDir) of + true -> + InSameDir; + false -> + Dir = filename:dirname(File), + Mod = filename:basename(File), + InDotDotSrc = filename:join([Dir,"..","src",Mod++".erl"]), + case filelib:is_file(InDotDotSrc) of + true -> + InDotDotSrc; + false -> + {beam,File0} + end + end + end. + +%% do_analyse(Module, Analysis, Level, Clauses)-> {ok,Answer} | {error,Error} +%% Clauses = [{Module,Function,Arity,Clause,Lines}] +do_analyse(Module, Analysis, line, _Clauses) -> + Pattern = {#bump{module=Module},'_'}, + Bumps = ets:match_object(?COLLECTION_TABLE, Pattern), + Fun = case Analysis of + coverage -> + fun({#bump{line=L}, 0}) -> + {{Module,L}, {0,1}}; + ({#bump{line=L}, _N}) -> + {{Module,L}, {1,0}} + end; + calls -> + fun({#bump{line=L}, N}) -> + {{Module,L}, N} + end + end, + Answer = lists:keysort(1, lists:map(Fun, Bumps)), + {ok, Answer}; +do_analyse(_Module, Analysis, clause, Clauses) -> + Fun = case Analysis of + coverage -> + fun({M,F,A,C,Ls}) -> + Pattern = {#bump{module=M,function=F,arity=A, + clause=C},0}, + Bumps = ets:match_object(?COLLECTION_TABLE, Pattern), + NotCov = length(Bumps), + {{M,F,A,C}, {Ls-NotCov, NotCov}} + end; + calls -> + fun({M,F,A,C,_Ls}) -> + Pattern = {#bump{module=M,function=F,arity=A, + clause=C},'_'}, + Bumps = ets:match_object(?COLLECTION_TABLE, Pattern), + {_Bump, Calls} = hd(lists:keysort(1, Bumps)), + {{M,F,A,C}, Calls} + end + end, + Answer = lists:map(Fun, Clauses), + {ok, Answer}; +do_analyse(Module, Analysis, function, Clauses) -> + {ok, ClauseResult} = do_analyse(Module, Analysis, clause, Clauses), + Result = merge_clauses(ClauseResult, merge_fun(Analysis)), + {ok, Result}; +do_analyse(Module, Analysis, module, Clauses) -> + {ok, FunctionResult} = do_analyse(Module, Analysis, function, Clauses), + Result = merge_functions(FunctionResult, merge_fun(Analysis)), + {ok, {Module,Result}}. + +merge_fun(coverage) -> + fun({Cov1,NotCov1}, {Cov2,NotCov2}) -> + {Cov1+Cov2, NotCov1+NotCov2} + end; +merge_fun(calls) -> + fun(Calls1, Calls2) -> + Calls1+Calls2 + end. + +merge_clauses(Clauses, MFun) -> merge_clauses(Clauses, MFun, []). +merge_clauses([{{M,F,A,_C1},R1},{{M,F,A,C2},R2}|Clauses], MFun, Result) -> + merge_clauses([{{M,F,A,C2},MFun(R1,R2)}|Clauses], MFun, Result); +merge_clauses([{{M,F,A,_C},R}|Clauses], MFun, Result) -> + merge_clauses(Clauses, MFun, [{{M,F,A},R}|Result]); +merge_clauses([], _Fun, Result) -> + reverse(Result). + +merge_functions([{_MFA,R}|Functions], MFun) -> + merge_functions(Functions, MFun, R); +merge_functions([],_MFun) -> % There are no clauses. + {0,0}. % No function can be covered or notcov. + +merge_functions([{_MFA,R}|Functions], MFun, Result) -> + merge_functions(Functions, MFun, MFun(Result, R)); +merge_functions([], _MFun, Result) -> + Result. + +%% do_analyse_to_file(Module,OutFile,ErlFile) -> {ok,OutFile} | {error,Error} +%% Module = atom() +%% OutFile = ErlFile = string() +do_analyse_to_file(Module, OutFile, ErlFile, HTML) -> + case file:open(ErlFile, [read]) of + {ok, InFd} -> + case file:open(OutFile, [write]) of + {ok, OutFd} -> + if HTML -> + io:format(OutFd, + "\n" + "~s" + "\n" + "
\n",
+				      [OutFile]);
+		       true -> ok
+		    end,
+		    
+		    %% Write some initial information to the output file
+		    {{Y,Mo,D},{H,Mi,S}} = calendar:local_time(),
+		    io:format(OutFd, "File generated from ~s by COVER "
+			             "~p-~s-~s at ~s:~s:~s~n",
+			      [ErlFile,
+			       Y,
+			       string:right(integer_to_list(Mo), 2, $0),
+			       string:right(integer_to_list(D),  2, $0),
+			       string:right(integer_to_list(H),  2, $0),
+			       string:right(integer_to_list(Mi), 2, $0),
+			       string:right(integer_to_list(S),  2, $0)]),
+		    io:format(OutFd, "~n"
+			             "**************************************"
+			             "**************************************"
+			             "~n~n", []),
+
+		    print_lines(Module, InFd, OutFd, 1, HTML),
+		    
+		    if HTML -> io:format(OutFd,"
\n\n\n",[]); + true -> ok + end, + + file:close(OutFd), + file:close(InFd), + + {ok, OutFile}; + + {error, Reason} -> + {error, {file, OutFile, Reason}} + end; + + {error, Reason} -> + {error, {file, ErlFile, Reason}} + end. + +print_lines(Module, InFd, OutFd, L, HTML) -> + case io:get_line(InFd, '') of + eof -> + ignore; + "%"++_=Line -> %Comment line - not executed. + io:put_chars(OutFd, [tab(),escape_lt_and_gt(Line, HTML)]), + print_lines(Module, InFd, OutFd, L+1, HTML); + RawLine -> + Line = escape_lt_and_gt(RawLine,HTML), + Pattern = {#bump{module=Module,line=L},'$1'}, + case ets:match(?COLLECTION_TABLE, Pattern) of + [] -> + io:put_chars(OutFd, [tab(),Line]); + Ns -> + N = lists:foldl(fun([Ni], Nacc) -> Nacc+Ni end, 0, Ns), + if + N=:=0, HTML=:=true -> + LineNoNL = Line -- "\n", + Str = " 0", + %%Str = string:right("0", 6, 32), + RedLine = ["",Str,fill1(), + LineNoNL,"\n"], + io:put_chars(OutFd, RedLine); + N<1000000 -> + Str = string:right(integer_to_list(N), 6, 32), + io:put_chars(OutFd, [Str,fill1(),Line]); + N<10000000 -> + Str = integer_to_list(N), + io:put_chars(OutFd, [Str,fill2(),Line]); + true -> + Str = integer_to_list(N), + io:put_chars(OutFd, [Str,fill3(),Line]) + end + end, + print_lines(Module, InFd, OutFd, L+1, HTML) + end. + +tab() -> " | ". +fill1() -> "..| ". +fill2() -> ".| ". +fill3() -> "| ". + +%%%--Export-------------------------------------------------------------- +do_export_table(Compiled, Imported, Fd) -> + ModList = merge(Imported,Compiled), + write_module_data(ModList,Fd). + +merge([{Module,File,_ImportFiles}|Imported],ModuleList) -> + case lists:keymember(Module,1,ModuleList) of + true -> + merge(Imported,ModuleList); + false -> + merge(Imported,[{Module,File}|ModuleList]) + end; +merge([],ModuleList) -> + ModuleList. + +write_module_data([{Module,File}|ModList],Fd) -> + write({file,Module,File},Fd), + [Clauses] = ets:lookup(?COLLECTION_TABLE,Module), + write(Clauses,Fd), + ModuleData = ets:match_object(?COLLECTION_TABLE,{#bump{module=Module},'_'}), + do_write_module_data(ModuleData,Fd), + write_module_data(ModList,Fd); +write_module_data([],_Fd) -> + ok. + +do_write_module_data([H|T],Fd) -> + write(H,Fd), + do_write_module_data(T,Fd); +do_write_module_data([],_Fd) -> + ok. + +write(Element,Fd) -> + Bin = term_to_binary(Element,[compressed]), + case byte_size(Bin) of + Size when Size > 255 -> + SizeBin = term_to_binary({'$size',Size}), + file:write(Fd, + <<(byte_size(SizeBin)):8,SizeBin/binary,Bin/binary>>); + Size -> + file:write(Fd,<>) + end, + ok. + +%%%--Import-------------------------------------------------------------- +do_import_to_table(Fd,ImportFile,Imported) -> + do_import_to_table(Fd,ImportFile,Imported,[]). +do_import_to_table(Fd,ImportFile,Imported,DontImport) -> + case get_term(Fd) of + {file,Module,File} -> + case add_imported(Module, File, ImportFile, Imported) of + {ok,NewImported} -> + do_import_to_table(Fd,ImportFile,NewImported,DontImport); + dont_import -> + do_import_to_table(Fd,ImportFile,Imported, + [Module|DontImport]) + end; + {Key=#bump{module=Module},Val} -> + case lists:member(Module,DontImport) of + false -> + insert_in_collection_table(Key,Val); + true -> + ok + end, + do_import_to_table(Fd,ImportFile,Imported,DontImport); + {Module,Clauses} -> + case lists:member(Module,DontImport) of + false -> + ets:insert(?COLLECTION_TABLE,{Module,Clauses}); + true -> + ok + end, + do_import_to_table(Fd,ImportFile,Imported,DontImport); + eof -> + Imported + end. + + +get_term(Fd) -> + case file:read(Fd,1) of + {ok,<>} -> + {ok,Bin1} = file:read(Fd,Size1), + case binary_to_term(Bin1) of + {'$size',Size2} -> + {ok,Bin2} = file:read(Fd,Size2), + binary_to_term(Bin2); + Term -> + Term + end; + eof -> + eof + end. + +%%%--Reset--------------------------------------------------------------- + +%% Reset main node and all remote nodes +do_reset_main_node(Module,Nodes) -> + do_reset(Module), + do_reset_collection_table(Module), + remote_reset(Module,Nodes). + +do_reset_collection_table(Module) -> + ets:delete(?COLLECTION_TABLE,Module), + ets:match_delete(?COLLECTION_TABLE, {#bump{module=Module},'_'}). + +%% do_reset(Module) -> ok +%% The reset is done on a per-clause basis to avoid building +%% long lists in the case of very large modules +do_reset(Module) -> + [{Module,Clauses}] = ets:lookup(?COVER_TABLE, Module), + do_reset2(Clauses). + +do_reset2([{M,F,A,C,_L}|Clauses]) -> + Pattern = {#bump{module=M, function=F, arity=A, clause=C}, '_'}, + Bumps = ets:match_object(?COVER_TABLE, Pattern), + lists:foreach(fun({Bump,_N}) -> + ets:insert(?COVER_TABLE, {Bump,0}) + end, + Bumps), + do_reset2(Clauses); +do_reset2([]) -> + ok. + +do_clear(Module) -> + ets:match_delete(?COVER_TABLE, {Module,'_'}), + ets:match_delete(?COVER_TABLE, {#bump{module=Module},'_'}), + ets:match_delete(?COLLECTION_TABLE, {#bump{module=Module},'_'}). + + + +%%%--Div----------------------------------------------------------------- + +reverse(List) -> + reverse(List,[]). +reverse([H|T],Acc) -> + reverse(T,[H|Acc]); +reverse([],Acc) -> + Acc. + + +escape_lt_and_gt(Rawline,HTML) when HTML =/= true -> + Rawline; +escape_lt_and_gt(Rawline,_HTML) -> + escape_lt_and_gt1(Rawline,[]). + +escape_lt_and_gt1([$<|T],Acc) -> + escape_lt_and_gt1(T,[$;,$t,$l,$&|Acc]); +escape_lt_and_gt1([$>|T],Acc) -> + escape_lt_and_gt1(T,[$;,$t,$g,$&|Acc]); +escape_lt_and_gt1([],Acc) -> + lists:reverse(Acc); +escape_lt_and_gt1([H|T],Acc) -> + escape_lt_and_gt1(T,[H|Acc]). diff --git a/lib/tools/src/cover_web.erl b/lib/tools/src/cover_web.erl new file mode 100644 index 0000000000..69f2f3b1aa --- /dev/null +++ b/lib/tools/src/cover_web.erl @@ -0,0 +1,1184 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2001-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(cover_web). +-author('marting@erix.ericsson.se'). +-behaviour(gen_server). + +%%Export of configuration function +-export([configData/0]). +%% External exports +-export([init/1, handle_call/3, handle_cast/2, handle_info/2, + terminate/2, code_change/3]). + +-export([start_link/0,start/0,stop/0]). +-export([menu_frame/2,nodes_frame/2,import_frame/2, + compile_frame/2,result_frame/2]). +-export([list_dir/2,compile/2,add_node/2,remove_node/2,result/2, + calls/2,coverage/2,import/2]). + +-record(state,{dir}). + +-include_lib("kernel/include/file.hrl"). + +%% Timeouts +-define(DEFAULT_TIME,10000). +-define(MAX_COMPILE_TIME,60000). +-define(MAX_ANALYSE_TIME,30000). + +%% Colors +-define(INFO_BG_COLOR,"#C0C0EA"). + +%%%---------------------------------------------------------------------- +%%% API - called from erlang shell +%%%---------------------------------------------------------------------- +%% Start webtool and webcover from erlang shell +start() -> + webtool:start(), + webtool:start_tools([],"app=webcover"), + ok. + +%% Stop webtool and webcover from erlang shell +stop() -> + webtool:stop_tools([],"app=webcover"), + webtool:stop(). + + + +%%%---------------------------------------------------------------------- +%%% API - called from webtool +%%%---------------------------------------------------------------------- +start_link() -> + gen_server:start_link({local, webcover_server},cover_web, [], []). + + +nodes_frame(Env,Input)-> + call({nodes_frame,Env,Input}). + +add_node(Env,Input)-> + call({add_node,Env,Input}). + +remove_node(Env,Input)-> + call({remove_node,Env,Input}). + +compile_frame(Env,Input)-> + call({compile_frame,Env,Input}). + +list_dir(Env,Input) -> + call({list_dir,Env,Input}). + +compile(Env,Input)-> + call({compile,Env,Input},?MAX_COMPILE_TIME). + +result_frame(Env,Input)-> + call({result_frame,Env,Input}). + +result(Env,Input) -> + call({result,Env,Input},?MAX_ANALYSE_TIME). + +calls(Env,Input) -> + call({calls,Env,Input}). + +coverage(Env,Input) -> + call({coverage,Env,Input}). + +import_frame(Env,Input)-> + call({import_frame,Env,Input}). + +import(Env,Input)-> + call({import,Env,Input}). + +menu_frame(Env,Input)-> + call({menu_frame,Env,Input}). + +call(Msg) -> + call(Msg,?DEFAULT_TIME). +call(Msg,Time) -> + gen_server:call(webcover_server,Msg,Time). + + + +configData()-> + {webcover,[{web_data,{"WebCover","/webcover"}}, + {alias,{"/webcover",code:priv_dir(tools)}}, + {alias,{erl_alias,"/webcover/erl",[cover_web]}}, + {start,{child,{{local,webcover_server}, + {cover_web,start_link,[]}, + permanent,100,worker,[cover_web]}}} + ]}. + + +%%%---------------------------------------------------------------------- +%%% Callback functions from gen_server +%%%---------------------------------------------------------------------- + +%%---------------------------------------------------------------------- +%% Func: init/1 +%% Returns: {ok, State} | +%% {ok, State, Timeout} | +%% ignore | +%% {stop, Reason} +%%---------------------------------------------------------------------- +init([]) -> + cover:start(), + CS = whereis(cover_server), + link(CS), + GL = spawn_link(fun group_leader_proc/0), + group_leader(GL,CS), + + %% Must trap exists in order to have terminate/2 executed when + %% crashing because of a linked process crash. + process_flag(trap_exit,true), + {ok,Cwd} = file:get_cwd(), + {ok, #state{dir=Cwd}}. + +group_leader_proc() -> + register(cover_group_leader_proc,self()), + group_leader_loop([]). +group_leader_loop(Warnings) -> + receive + {io_request,From,ReplyAs,{put_chars,io_lib,Func,[Format,Args]}} -> + Msg = (catch io_lib:Func(Format,Args)), + From ! {io_reply,ReplyAs,ok}, + case lists:member(Msg,Warnings) of + true -> group_leader_loop(Warnings); + false -> group_leader_loop([Msg|Warnings]) + end; + {io_request,From,ReplyAs,{put_chars,_Encoding,io_lib,Func,[Format,Args]}} -> + Msg = (catch io_lib:Func(Format,Args)), + From ! {io_reply,ReplyAs,ok}, + case lists:member(Msg,Warnings) of + true -> group_leader_loop(Warnings); + false -> group_leader_loop([Msg|Warnings]) + end; + IoReq when element(1,IoReq)=:= io_request -> + group_leader() ! IoReq, + group_leader_loop(Warnings); + {From,get_warnings} -> + Warnings1 = + receive + {io_request,From,ReplyAs, + {put_chars,io_lib,Func,[Format,Args]}} -> + Msg = (catch io_lib:Func(Format,Args)), + From ! {io_reply,ReplyAs,ok}, + case lists:member(Msg,Warnings) of + true -> Warnings; + false -> [Msg|Warnings] + end + after 0 -> + Warnings + end, + From ! {warnings,Warnings1}, + group_leader_loop([]) + end. + +%%---------------------------------------------------------------------- +%% Func: handle_call/3 +%% Returns: {reply, Reply, State} | +%% {reply, Reply, State, Timeout} | +%% {noreply, State} | +%% {noreply, State, Timeout} | +%% {stop, Reason, Reply, State} | (terminate/2 is called) +%% {stop, Reason, State} (terminate/2 is called) +%%---------------------------------------------------------------------- +handle_call({nodes_frame,_Env,_Input},_From,State)-> + {reply,nodes_frame1(),State}; + +handle_call({add_node,_Env,Input},_From,State)-> + {reply,do_add_node(Input),State}; + +handle_call({remove_node,_Env,Input},_From,State)-> + {reply,do_remove_node(Input),State}; + +handle_call({compile_frame,_Env,_Input},_From,State)-> + {reply,compile_frame1(State#state.dir),State}; + +handle_call({list_dir,_Env,Input},_From,State)-> + Dir = get_input_data(Input,"path"), + case filelib:is_dir(Dir) of + true -> + {reply,compile_frame1(Dir),State#state{dir=Dir}}; + false -> + Err = Dir ++ " is not a directory", + {reply,compile_frame1(State#state.dir,Err),State} + end; +handle_call({compile,_Env,Input},_From,State)-> + {reply,do_compile(Input,State#state.dir),State}; + +handle_call({result_frame,_Env,_Input},_From,State)-> + {reply,result_frame1(),State}; + +handle_call({result,_Env,Input},_From,State)-> + {reply,handle_result(Input),State}; + +handle_call({calls,_Env,Input},_From,State)-> + {reply,call_page(Input),State}; + +handle_call({coverage,_Env,Input},_From,State)-> + {reply,coverage_page(Input),State}; + +handle_call({import_frame,_Env,_Input},_From,State)-> + {ok,Cwd} = file:get_cwd(), + {reply,import_frame1(Cwd),State}; + +handle_call({import,_Env,Input},_From,State)-> + {reply,do_import(Input),State}; + +handle_call({menu_frame,_Env,_Input},_From,State)-> + {reply,menu_frame1(),State}; + +handle_call(_Request, _From, State) -> + Reply = bad_request, + {reply, Reply, State}. + + +%%---------------------------------------------------------------------- +%% Func: handle_cast/2 +%% Returns: {noreply, State} | +%% {noreply, State, Timeout} | +%% {stop, Reason, State} (terminate/2 is called) +%%---------------------------------------------------------------------- +handle_cast(_Msg, State) -> + {noreply, State}. + +%%---------------------------------------------------------------------- +%% Func: handle_info/2 +%% Returns: {noreply, State} | +%% {noreply, State, Timeout} | +%% {stop, Reason, State} (terminate/2 is called) +%%---------------------------------------------------------------------- +handle_info({'EXIT',_Pid,Reason}, State) -> + {stop, Reason, State}. + +%%---------------------------------------------------------------------- +%% Func: terminate/2 +%% Purpose: Shutdown the server +%% Returns: any (ignored by gen_server) +%%---------------------------------------------------------------------- +terminate(_Reason, _State) -> + cover:stop(), + ok. + +%%-------------------------------------------------------------------- +%% Func: code_change/3 +%% Purpose: Convert process state when code is changed +%% Returns: {ok, NewState} +%%-------------------------------------------------------------------- +code_change(_OldVsn, State, _Extra) -> + {ok, State}. + +%%%---------------------------------------------------------------------- +%%% Internal functions +%%%---------------------------------------------------------------------- + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% %% +%% The functions that creates the whole pages by collecting all the %% +%% neccessary data for each page. These functions are the public %% +%% interface. %% +%% %% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%---------------------------------------------------------------------- +%% Returns the page to the left frame +%%---------------------------------------------------------------------- +menu_frame1()-> + [header(),html_header(""),menu_body(),html_end()]. + +%%---------------------------------------------------------------------- +%% Creates the page where the user can add and remove nodes +%%---------------------------------------------------------------------- + +nodes_frame1()-> + nodes_frame1([]). +nodes_frame1(Err)-> + [header(),html_header("Add/remove nodes"),nodes_body(Err),html_end()]. + +%%---------------------------------------------------------------------- +%% Creates the page where the user can cover compile modules +%%---------------------------------------------------------------------- + +compile_frame1(Dir)-> + compile_frame1(Dir,[]). +compile_frame1(Dir,Err) -> + [header(),html_header("Cover compile"),compile_body(Dir,Err),html_end()]. + +%%---------------------------------------------------------------------- +%% Creates the page where the user can handle results +%%---------------------------------------------------------------------- + +result_frame1()-> + result_frame1([]). +result_frame1(Err) -> + [header(),html_header("Show cover results"),result_body(Err),html_end()]. + +%%---------------------------------------------------------------------- +%%The beginning of the page that clear the cover information on a cover +%%compiled module +%%---------------------------------------------------------------------- +call_page(Input)-> + [header(),html_header("Code coverage"),call_result(Input),html_end()]. + +coverage_page(Input)-> + [header(),html_header("Code coverage"),coverage_result(Input),html_end()]. + +%%---------------------------------------------------------------------- +%% Creates the page where the user an import files +%%---------------------------------------------------------------------- +import_frame1(Dir) -> + import_frame1(Dir,""). +import_frame1(Dir,Err) -> + [header(),html_header("Import coverdata"),import_body(Dir,Err),html_end()]. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% %% +%% The functions that build the body of the menu frame %% +%% %% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +menu_body() -> + Nodes = cover:which_nodes(), + Modules = cover:modules(), + Imported = cover:imported(), + ["Nodes
\n", + "Compile
\n", + "Import
\n", + "Result\n", + "

Nodes:\n", + "

    \n", + lists:map(fun(N) -> "
  • "++atom_to_list(N)++"
    • \n" end,[node()|Nodes]), + "
\n", + "

Compiled modules:\n", + "

    \n", + lists:map(fun(M) -> "
  • "++atom_to_list(M)++"
    • \n" end,Modules), + "
\n", + "

Imported files:\n", + "

    \n", + "\n", + lists:map(fun(F) -> + Short = filename:basename(F), + "
  • "++Short++"
    • \n" end,Imported), + "    \n", + "
\n"]. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% %% +%% The functions that build the body of the nodes frame %% +%% %% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +nodes_body(Err) -> + CN = cover:which_nodes(), + Fun = fun(N) -> + NStr = atom_to_list(N), + ["\n"] + end, + AllNodes = lists:append(lists:map(Fun,nodes()--CN)), + CoverNodes = lists:append(lists:map(Fun,CN)), + + [reload_menu_script(Err), + "

Nodes

\n", + "\n", + "\n", + "\n", + "\n", + "\n", + "\n" + "\n", + "\n", + "\n", + "\n", + "\n", + "", + "
\n", + "

You can run cover over several nodes simultaneously. Coverage data\n", + "from all involved nodes will be merged during analysis.\n", + "

Select or enter node names to add or remove here.\n", + "



Add node:", + "" + "
\n", + "


Remove node:\n", + "" + "
"]. + + +do_add_node(Input) -> + NodeStr = get_input_data(Input, "node"), + Node = list_to_atom(NodeStr), + case net_adm:ping(Node) of + pong -> + cover:start(Node), + nodes_frame1(); + pang -> + nodes_frame1("Node \\\'" ++ NodeStr ++ "\\\' is not alive") + end. + +do_remove_node(Input) -> + Node = list_to_atom(get_input_data(Input, "node")), + cover:stop(Node), + nodes_frame1(). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% % +% The functions that is used when the user wants to compile something % +% % +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +compile_body(Dir,Err) -> + Erls = filelib:wildcard(filename:join(Dir,"*.erl")), + Beams = filelib:wildcard(filename:join(Dir,"*.beam")), + + [reload_menu_script(Err), + "

Compile

\n", + "\n", + "\n", + "\n", + "\n", + "\n", + "\n", + "\n", + "\n", + "\n", + "\n", + "\n", + "\n", + "\n" + "\n", + "\n", + "\n", + "\n", + "\n", + "\n", + "
\n", + "Each module which shall be part of the cover analysis must be prepared\n", + "or 'cover compiled'. On this page you can select .erl files and/or\n", + ".beam files to include in the analysis. If you select a .erl file it\n", + "will first be compiled with the Erlang compiler and then prepared for\n", + "coverage analysis. If you select a .beam file it will be prepared for\n", + "coverage analysis directly.\n", + "
\n", + "To list a different directory, enter the directory name here.\n", + "
List directory:
\n", + "", + "", + "

\n", + "

Select one or more .erl or .beam files to prepare for coverage\n" + "analysis, and click the \"Compile\" button.\n", + "

To reload the original file after coverage analysis is complete,\n" + "select one or more files and click the \"Uncompile\" button, or\n", + "simply click the \"Uncompile all\" button to reload all originals.\n" + "

.erl files.beam files
\n", + "\n", + "
\n", + "Compile options are only needed for .erl files. The options must be\n" + "given e.g. like this: \n" + "[{i,\"/my/path/include\"},{i,\"/other/path/\"}]\n" + "
Compile options:
\n", + "\n", + "
\n", + "", + "", + "", + "
\n"]. + +list_modules([File|Files]) -> + Mod = filename:basename(File), + ["\n" | list_modules(Files)]; +list_modules([]) -> + []. + +do_compile(Input,Dir) -> + {Erls,Beams,Opts,Action} = get_compile_input(parse(Input),[],[]), + Errs = + case Action of + "compile" -> + do_compile(Erls,Beams,Opts,[]); + "uncompile" -> + do_uncompile(Erls++Beams); + "uncompile_all" -> + do_uncompile(cover:modules()) + end, + compile_frame1(Dir,Errs). + +get_compile_input([{"erl",File}|Input],Erl,Beam) -> + get_compile_input(Input,[File|Erl],Beam); +get_compile_input([{"beam",File}|Input],Erl,Beam) -> + get_compile_input(Input,Erl,[File|Beam]); +get_compile_input([{"options",Opts0},{"action",Action}],Erl,Beam) -> + Opts = parse_options(Opts0), + {Erl,Beam,Opts,Action}. + +do_compile([Erl|Erls],Beams,Opts,Errs) -> + case cover:compile_module(Erl,Opts) of + {ok,_} -> + do_compile(Erls,Beams,Opts,Errs); + {error,File} -> + do_compile(Erls,Beams,Opts,["\\n"++File|Errs]) + end; +do_compile([],[Beam|Beams],Opts,Errs) -> + case cover:compile_beam(Beam) of + {ok,_} -> + do_compile([],Beams,Opts,Errs); + {error,{no_abstract_code,File}} -> + do_compile([],Beams,Opts,["\\n"++File++" (no_abstract_code)"|Errs]) + end; +do_compile([],[],_,[]) -> + []; +do_compile([],[],_,Errs) -> + "Compilation failed for the following files:" ++ Errs. + +parse_options(Options)-> + case erl_scan:string(Options ++".") of + {ok,Tokens,_Line} -> + case erl_parse:parse_exprs(Tokens) of + {ok,X}-> + case lists:map(fun erl_parse:normalise/1, X) of + [List] when is_list(List) -> List; + List -> List + end; + _ -> + [] + end; + _ -> + [] + end. + + +do_uncompile(Files) -> + lists:foreach( + fun(File) -> + Module = + if is_atom(File) -> + File; + true -> + ModStr = filename:basename(filename:rootname(File)), + list_to_atom(ModStr) + end, + case code:which(Module) of + cover_compiled -> + code:purge(Module), + case code:load_file(Module) of + {module, Module} -> + ok; + {error, _Reason2} -> + code:delete(Module) + end; + _ -> + ok + end + end, + Files), + []. + + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% % +% The functions that builds the body of the page for coverage analysis% +% % +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +result_body(Err) -> + [reload_menu_script(Err), + "

Result

\n", + "\n", + "\n", + "
\n", + "

After executing all your tests you can view the result of the\n", + "coverage analysis here. For each module you can\n", + "

\n", + "
Analyse to file
\n", + "
The source code of the module is shown with the number of calls\n", + "to each line stated in the left margin. Lines which are never called\n", + "are colored red.
\n", + "
Analyse coverage
\n", + "
Show the number of covered and uncovered lines in the module.
\n", + "
Analyse calls
\n", + "
Show the number of calls in the module.
\n", + "
Reset module
\n", + "
Delete all coverage data for the module.
\n", + "
Export module
\n", + "
Write all coverage data for the module to a file. The data can\n", + "later be imported from the \"Import\" page.
\n", + "
\n", + "

You can also reset or export data for all modules with the\n", + "Reset all and Export all actions respectively. For these\n", + "two actions there is no need to select a module.\n", + "

Select module and action from the drop down menus below, and click\n", + "the \"Execute\" button.\n", + "



\n", + result_selections(), + "
"]. + +result_selections() -> + ModList = filter_modlist(cover:modules()++cover:imported_modules(),[]), + + ["
\n", + "\n", + "\n", + "\n", + "\n" + "
\n", + "Module:\n", + "
\n", + "		\n", + "Action:\n", + "
\n", + "		\n" + "
\n", + "
\n"]. + +filter_modlist([M|Ms],Already) -> + case lists:member(M,Already) of + true -> + filter_modlist(Ms,Already); + false -> + MStr = atom_to_list(M), + ["\n" | + filter_modlist(Ms,[M|Already])] + end; +filter_modlist([],_Already) -> + []. + + + +handle_result(Input) -> + case parse(Input) of + [{"module",M},{"action",A}] -> + case A of + "analyse_to_file" -> + case cover:analyse_to_file(list_to_atom(M),[html]) of + {ok,File} -> + case file:read_file(File) of + {ok,HTML}-> + file:delete(File), + [header(), + reload_menu_script(""), + binary_to_list(HTML)]; + _ -> + result_frame1("Can not read file" ++ File) + end; + {error,no_source_code_found} -> + result_frame1("No source code found for \\\'" ++ + M ++ "\\\'") + end; + "calls" -> + call_page(Input); + "coverage" -> + coverage_page(Input); + "reset" -> + cover:reset(list_to_atom(M)), + result_frame1("Coverage data for \\\'" ++ M ++ + "\\\' is now reset"); + "reset_all" -> + cover:reset(), + result_frame1("All coverage data is now reset"); + "export" -> + ExportFile = generate_filename(M), + cover:export(ExportFile,list_to_atom(M)), + result_frame1("Coverage data for \\\'" ++ M ++ + "\\\' is now exported to file \\\"" ++ + ExportFile ++ "\\\""); + "export_all" -> + ExportFile = generate_filename("COVER"), + cover:export(ExportFile), + result_frame1( + "All coverage data is now exported to file \\\"" ++ + ExportFile ++ "\\\"") + end; + [{"action",_A}] -> + result_frame1("No module is selected") + end. + +generate_filename(Prefix) -> + {ok,Cwd} = file:get_cwd(), + filename:join(Cwd,Prefix ++ "_" ++ ts() ++ ".coverdata"). + +ts() -> + {{Y,M,D},{H,Min,S}} = calendar:now_to_local_time(now()), + io_lib:format("~4.4.0w~2.2.0w~2.2.0w-~2.2.0w~2.2.0w~2.2.0w", + [Y,M,D,H,Min,S]). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% % +% The functions that builds the body of the page that shows the calls % +% % +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +call_result(Input)-> + Mod = list_to_atom(get_input_data(Input, "module")), + case cover:analyse(Mod,calls) of + {error,_}-> + error_body(); + {ok,_} -> + call_result2(Mod,Input) + end. + +call_result2(Mod,Input)-> + Result = + case get_input_data(Input,"what") of + "mod" -> + call_result(mod,Mod); + "func" -> + call_result(func,Mod); + "clause" -> + call_result(clause,Mod); + _-> + call_result(all,Mod) + end, + result_choice("calls",Mod) ++ Result. + +result_choice(Level,Mod)-> + ModStr=atom_to_list(Mod), + [reload_menu_script(""), + "\n", + "\n", + "\n", + "\n", + "\n", + "
All DataModuleFunctionClause

\n"]. + +call_result(Mode,Module)-> + Content = + case Mode of + mod-> + format_cover_call(cover:analyse(Module,calls,module),mod); + func-> + format_cover_call(cover:analyse(Module,calls,function),func); + clause-> + format_cover_call(cover:analyse(Module,calls,clause),clause); + _-> + format_cover_call(cover:analyse(Module,calls,module),mod) ++ + format_cover_call(cover:analyse(Module,calls,function),func)++ + format_cover_call(cover:analyse(Module,calls,clause),clause) + end, + getModDate(Module,date())++"
"++ + "" + ++ Content ++"
". + + +format_cover_call({error,_},_)-> + ["\n", + "



\n", + "The selected module is not Cover Compiled\n", + "
\n", + "\n"]; + +format_cover_call({ok,{Mod,Calls}},mod)-> + ["Module calls\n", + "Module", + "Number of calls\n", + "" ++ atom_to_list(Mod) ++"" + "" ++ integer_to_list(Calls)++"\n"]; + +format_cover_call({ok,Calls},func)-> + ["Function calls\n", + "ModuleFunction", + "Arity", + "Number of calls \n", + lists:append( + lists:map( + fun({{Mod,Func,Arity},Nr_of_calls})-> + [""++ atom_to_list(Mod)++"\n", + "" ++ atom_to_list(Func) ++" \n", + "", + integer_to_list(Arity), + "\n", + "", + integer_to_list(Nr_of_calls), + "\n"] + end, + Calls))]; + +format_cover_call({ok,Calls},clause)-> + ["Clause calls\n", + "ModuleFunction", + "Arity", + "Ordinal", + "Number of calls\n", + lists:append( + lists:map( + fun({{Mod,Func,Arity,Ord},Nr_of_calls})-> + ["", atom_to_list(Mod), "\n", + "", atom_to_list(Func), "\n", + "", + integer_to_list(Arity), + "\n", + "", + integer_to_list(Ord), + "\n", + "", + integer_to_list(Nr_of_calls), + "\n"] + end, + Calls))]. + + +error_body()-> + ["\n", + "\n", + "\n", + "\n", + "
\n", + "





\n", + "The selected module is not Cover Compiled\n", + "
\n", + "
\n"]. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% % +% The functions that builds the body of the page that shows coverage % +% % +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +coverage_result(Input)-> + Mod = list_to_atom(get_input_data(Input, "module")), + case cover:analyse(Mod,coverage) of + {error,_}-> + error_body(); + {ok,_} -> + coverage_result2(Mod,Input) + end. + +coverage_result2(Mod,Input)-> + Result = + case get_input_data(Input,"what") of + "mod" -> + coverage_result(mod,Mod); + "func" -> + coverage_result(func,Mod); + "clause" -> + coverage_result(clause,Mod); + _-> + coverage_result(all,Mod) + end, + result_choice("coverage",Mod) ++ Result. + +coverage_result(Mode,Module)-> + Content = + case Mode of + mod-> + format_cover_coverage(cover:analyse(Module,coverage,module), + mod); + func-> + format_cover_coverage(cover:analyse(Module,coverage,function), + func); + clause-> + format_cover_coverage(cover:analyse(Module,coverage,clause), + clause); + _-> + format_cover_coverage(cover:analyse(Module,coverage,module), + mod) ++ + format_cover_coverage(cover:analyse(Module,coverage,function), + func)++ + format_cover_coverage(cover:analyse(Module,coverage,clause), + clause) + end, + getModDate(Module,date())++"
"++ + "" + ++ Content ++"
". + +getModDate(Module,{Year,Mon,Day})-> + " + + + + + + + + +
Module:" ++ atom_to_list(Module) ++ "
Date:" ++ integer_to_list(Day) ++ "/" ++ + integer_to_list(Mon) ++" - "++ + integer_to_list(Year) ++ + "
". + + +format_cover_coverage({error,_},_)-> + " +



+ The selected module is not Cover Compiled +
+ "; + + +format_cover_coverage({ok,{Mod,{Cov,Not_cov}}},mod)-> + ["Module coverage\n", + "Module\n", + "Covered\n" + "Not Covered\n", + "\n", + "", atom_to_list(Mod), "\n" + "", integer_to_list(Cov), "\n" + "", integer_to_list(Not_cov), "\n"]; + +format_cover_coverage({ok,Cov_res},func)-> + ["Function coverage\n", + "\n", + "ModuleFunction", + "Arity", + "Covered", + "Not Covered", + "\n", + lists:append( + lists:map( + fun({{Mod,Func,Arity},{Cov,Not_cov}})-> + [""++ atom_to_list(Mod) ++" \n", + "" ++ atom_to_list(Func) ++"\n", + "", + integer_to_list(Arity), + "\n", + "", + integer_to_list(Cov), + "\n" + "", + integer_to_list(Not_cov), + "\n"] + end, + Cov_res))]; + +format_cover_coverage({ok,Cov_res},clause)-> + ["Clause coverage\n", + "ModuleFunction\n", + "Arity\n", + "Ordinal\n", + "Covered\n", + "Not Covered\n", + lists:append( + lists:map( + fun({{Mod,Func,Arity,Ord},{Cov,Not_cov}})-> + [""++ atom_to_list(Mod) ++"\n", + "" ++ atom_to_list(Func) ++" \n", + "", + integer_to_list(Arity), + "\n" + "", + integer_to_list(Ord), + "\n" + "", + integer_to_list(Cov), + "\n" + "", + integer_to_list(Not_cov), + "\n"] + end, + Cov_res))]. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% % +% The functions that builds the body of the import page % +% % +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +import_body(Dir,Err) -> + [reload_menu_script(Err), + "

Import

\n", + "\n", + "\n", + "
\n", + "

You can import coverage data from a previous analysis. If you do so\n", + "the imported data will be merged with the current coverage data.\n", + "

You can export data from the current analysis from the \"Result\"\n", + "page.\n", + "

Select the file to import here.\n", + "



\n", + "
\n", + "Change directory:
\n", + "", + "\n", + "
\n", + "
\n", + browse_import(Dir), + "
"]. + +browse_import(Dir) -> + {ok,List} = file:list_dir(Dir), + Sorted = lists:reverse(lists:sort(List)), + {Dirs,Files} = filter_files(Dir,Sorted,[],[]), + ["
\n" + "\n", + "\n", + "
\n" + "
\n"]. + +filter_files(Dir,[File|Files],Ds,Fs) -> + case filename:extension(File) of + ".coverdata" -> + Fs1 = ["\n" | Fs], + filter_files(Dir,Files,Ds,Fs1); + _ -> + FullName = filename:join(Dir,File), + case filelib:is_dir(FullName) of + true -> + Ds1 = ["\n" | Ds], + filter_files(Dir,Files,Ds1,Fs); + false -> + filter_files(Dir,Files,Ds,Fs) + end + end; +filter_files(_Dir,[],Ds,Fs) -> + {Ds,Fs}. + + + + +do_import(Input) -> + case parse(Input) of + [{"file",File0},{"dir",Dir}] -> + File = filename:join(Dir,File0), + case filelib:is_dir(File) of + true -> + import_frame1(File); + false -> + case filelib:is_file(File) of + true -> + case cover:import(File) of + ok -> + import_frame1(Dir); + {error,{cant_open_file,ExportFile,_Reason}} -> + import_frame1(Dir, + "Error importing file\\n\\\"" + ++ ExportFile ++ "\\\"") + end; + false -> + import_frame1(Dir, + "Error importing file\\n\\\"" ++ + File ++ "\\\"") + end + end; + [{"dir",Dir}] -> + import_frame1(Dir,"No file is selected") + end. + + + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% % +% Different private helper functions % +% % +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%Create the Header for the page If we now the mimetype use that type %% +%%otherwise use text %% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +header() -> + header("text/html"). +header(MimeType) -> + "Pragma:no-cache\r\n" ++ + "Content-type: " ++ MimeType ++ "\r\n\r\n". + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%Create the Htmlheader set the title of the page %% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +html_header(Title) -> + "\n" ++ + "\n" ++ + "" ++ Title ++ "\n" ++ + "\n" + "\n". + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Close the body- and Html tags %% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +html_end()-> + "". + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% A script which reloads the menu frame and possibly pops up an alert%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +reload_menu_script(Err) -> + ["\n", + ""]. + +fix_newline([$\n|Rest]) -> + [$\\,$n|fix_newline(Rest)]; +fix_newline([$"|Rest]) -> + [$\\,$"|fix_newline(Rest)]; +fix_newline([Char|Rest]) -> + [Char|fix_newline(Rest)]; +fix_newline([]) -> + []. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% Control the input data and return the intresting values or error % +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +get_input_data(Input,Key)-> + case lists:keysearch(Key,1,parse(Input)) of + {value,{Key,Value}} -> + Value; + false -> + undefined + end. + +parse(Input) -> + httpd:parse_query(Input). + + +get_warnings() -> + cover_group_leader_proc ! {self(), get_warnings}, + receive {warnings,Warnings} -> + Warnings + end. diff --git a/lib/tools/src/cprof.erl b/lib/tools/src/cprof.erl new file mode 100644 index 0000000000..b0c3341efa --- /dev/null +++ b/lib/tools/src/cprof.erl @@ -0,0 +1,142 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2002-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(cprof). + +%% Call count profiling tool. + +-export ([start/0, start/1, start/2, start/3, + stop/0, stop/1, stop/2, stop/3, + restart/0, restart/1, restart/2, restart/3, + pause/0, pause/1, pause/2, pause/3, + analyse/0, analyse/1, analyse/2, + analyze/0, analyze/1, analyze/2]). + + + +start() -> + tr({'_','_','_'}, true) + tr(on_load, true). + +start({_,_,_} = MFA) -> + tr(MFA, true); +start({FuncSpec}) -> + tr(FuncSpec, true); +start(M) -> + tr({M,'_','_'}, true). + +start(M,F) -> + tr({M,F,'_'}, true). + +start(M,F,A) -> + tr({M,F,A}, true). + + + +stop() -> + tr({'_','_','_'}, false) + tr(on_load, false). + +stop({_,_,_} = MFA) -> + tr(MFA, false); +stop({FuncSpec}) -> + tr(FuncSpec, false); +stop(M) -> + tr({M,'_','_'}, false). + +stop(M,F) -> + tr({M,F,'_'}, false). + +stop(M,F,A) -> + tr({M,F,A}, false). + + + +restart() -> + tr({'_','_','_'}, restart). + +restart({_,_,_} = MFA) -> + tr(MFA, restart); +restart({FuncSpec}) -> + tr(FuncSpec, restart); +restart(M) -> + tr({M,'_','_'}, restart). + +restart(M,F) -> + tr({M,F,'_'}, restart). + +restart(M,F,A) -> + tr({M,F,A}, restart). + + + +pause() -> + tr({'_','_','_'}, pause) + tr(on_load, false). + +pause({_,_,_} = MFA) -> + tr(MFA, pause); +pause({FuncSpec}) -> + tr(FuncSpec, pause); +pause(M) -> + tr({M,'_','_'}, pause). + +pause(M,F) -> + tr({M,F,'_'}, pause). + +pause(M,F,A) -> + tr({M,F,A}, pause). + + + +analyse() -> + analyse(1). + +analyse(Limit) when is_integer(Limit) -> + L0 = [analyse(element(1, Mod), Limit) || Mod <- code:all_loaded()], + L1 = [{C,M,Lm} || {M,C,Lm} <- L0, C > 0, M =/= ?MODULE], + N = lists:foldl(fun ({C,_,_}, Q) -> Q+C end, 0, L1), + L = [{M,C,Lm} || {C,M,Lm} <- lists:reverse(lists:sort(L1))], + {N,L}; +analyse(M) when is_atom(M) -> + analyse(M, 1). + +analyse(M, Limit) when is_atom(M), is_integer(Limit) -> + L0 = [begin + MFA = {M,F,A}, + {_,C} = erlang:trace_info(MFA, call_count), + [C|MFA] + end || {F,A} <- M:module_info(functions)], + L1 = [X || [C|_]=X <- L0, is_integer(C)], + N = lists:foldl(fun ([C|_], Q) -> Q+C end, 0, L1), + L2 = [X || [C|_]=X <- L1, C >= Limit], + L = [{MFA,C} || [C|MFA] <- lists:reverse(lists:sort(L2))], + {M,N,L}. + + + +analyze() -> + analyse(). + +analyze(X) -> + analyse(X). + +analyze(X, Y) -> + analyse(X, Y). + + + +tr(FuncSpec, State) -> + erlang:trace_pattern(FuncSpec, State, [call_count]). diff --git a/lib/tools/src/eprof.erl b/lib/tools/src/eprof.erl new file mode 100644 index 0000000000..b4313d6888 --- /dev/null +++ b/lib/tools/src/eprof.erl @@ -0,0 +1,478 @@ +%% +%% %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% +%% +%% Purpose: Profile a system in order to figure out where the +%% time goes. +%% + +-module(eprof). +-behaviour(gen_server). + +-export([start/0, stop/0, dump/0, total_analyse/0, + start_profiling/1, profile/2, profile/4, profile/1, + stop_profiling/0, analyse/0, log/1]). + +%% Internal exports +-export([init/1, + call/4, + handle_call/3, + handle_cast/2, + handle_info/2, + terminate/2, + code_change/3]). + +-include_lib("stdlib/include/qlc.hrl"). + +-import(lists, [flatten/1,reverse/1,keysort/2]). + + +-record(state, {table = notable, + proc = noproc, + profiling = false, + pfunc = undefined, + pop = running, + ptime = 0, + overhead = 0, + rootset = []}). + +%%%%%%%%%%%%%% + +start() -> gen_server:start({local, eprof}, eprof, [], []). +stop() -> gen_server:call(eprof, stop, infinity). + + +profile(Pids, Fun) -> + start(), + gen_server:call(eprof, {profile,Pids,erlang,apply,[Fun,[]]},infinity). + +profile(Pids, M, F, A) -> + start(), + gen_server:call(eprof, {profile,Pids,M,F,A},infinity). + +dump() -> + gen_server:call(eprof, dump, infinity). + +analyse() -> + gen_server:call(eprof, analyse, infinity). + +log(File) -> + gen_server:call(eprof, {logfile, File}, infinity). + +total_analyse() -> + gen_server:call(eprof, total_analyse, infinity). + +start_profiling(Rootset) -> + start(), + gen_server:call(eprof, {profile, Rootset}, infinity). + +stop_profiling() -> + gen_server:call(eprof, stop_profiling, infinity). + +profile(Rs) -> + start_profiling(Rs). + +%%%%%%%%%%%%%%%% + +init(_) -> + process_flag(trap_exit, true), + process_flag(priority, max), + put(three_one, {3,1}), %To avoid building garbage. + {ok, #state{}}. + +subtr({X1,Y1,Z1}, {X1,Y1,Z2}) -> + Z1 - Z2; +subtr({X1,Y1,Z1}, {X2,Y2,Z2}) -> + (((X1-X2) * 1000000) + Y1 - Y2) * 1000000 + Z1 - Z2. + +update_call_statistics(Tab, Key, Time) -> + try ets:update_counter(Tab, Key, Time) of + NewTime when is_integer(NewTime) -> + ets:update_counter(Tab, Key, get(three_one)) + catch + error:badarg -> + ets:insert(Tab, {Key,Time,1}) + end. + +update_other_statistics(Tab, Key, Time) -> + try + ets:update_counter(Tab, Key, Time) + catch + error:badarg -> + ets:insert(Tab, {Key,Time,0}) + end. + +do_messages({trace_ts,From,Op,Mfa,Time}, Tab, undefined,_PrevOp0,_PrevTime0) -> + PrevFunc = [From|Mfa], + receive + {trace_ts,_,_,_,_}=Ts -> do_messages(Ts, Tab, PrevFunc, Op, Time) + after 0 -> + {PrevFunc,Op,Time} + end; +do_messages({trace_ts,From,Op,Mfa,Time}, Tab, PrevFunc0, call, PrevTime0) -> + update_call_statistics(Tab, PrevFunc0, subtr(Time, PrevTime0)), + PrevFunc = case Op of + exit -> undefined; + out -> undefined; + _ -> [From|Mfa] + end, + receive + {trace_ts,_,_,_,_}=Ts -> do_messages(Ts, Tab, PrevFunc, Op, Time) + after 0 -> + {PrevFunc,Op,Time} + end; +do_messages({trace_ts,From,Op,Mfa,Time}, Tab, PrevFunc0, _PrevOp0, PrevTime0) -> + update_other_statistics(Tab, PrevFunc0, subtr(Time, PrevTime0)), + PrevFunc = case Op of + exit -> undefined; + out -> undefined; + _ -> [From|Mfa] + end, + receive + {trace_ts,_,_,_,_}=Ts -> do_messages(Ts, Tab, PrevFunc, Op, Time) + after 0 -> + {PrevFunc,Op,Time} + end. + +%%%%%%%%%%%%%%%%%% + +handle_cast(_Req, S) -> {noreply, S}. + +terminate(_Reason,_S) -> + call_trace_for_all(false), + normal. + +%%%%%%%%%%%%%%%%%% + +handle_call({logfile, F}, _FromTag, Status) -> + case file:open(F, [write]) of + {ok, Fd} -> + case get(fd) of + undefined -> ok; + FdOld -> file:close(FdOld) + end, + put(fd, Fd), + {reply, ok, Status}; + {error, _} -> + {reply, error, Status} + end; + +handle_call({profile, Rootset}, {From, _Tag}, S) -> + link(From), + maybe_delete(S#state.table), + io:format("eprof: Starting profiling ..... ~n",[]), + ptrac(S#state.rootset, false, all()), + flush_receive(), + Tab = ets:new(eprof, [set, public]), + case ptrac(Rootset, true, all()) of + false -> + {reply, error, #state{}}; + true -> + uni_schedule(), + call_trace_for_all(true), + erase(replyto), + {reply, profiling, #state{table = Tab, + proc = From, + profiling = true, + rootset = Rootset}} + end; + +handle_call(stop_profiling, _FromTag, S) when S#state.profiling -> + ptrac(S#state.rootset, false, all()), + call_trace_for_all(false), + multi_schedule(), + io:format("eprof: Stop profiling~n",[]), + ets:delete(S#state.table, nofunc), + {reply, profiling_stopped, S#state{profiling = false}}; + +handle_call(stop_profiling, _FromTag, S) -> + {reply, profiling_already_stopped, S}; + +handle_call({profile, Rootset, M, F, A}, FromTag, S) -> + io:format("eprof: Starting profiling..... ~n", []), + maybe_delete(S#state.table), + ptrac(S#state.rootset, false, all()), + flush_receive(), + put(replyto, FromTag), + Tab = ets:new(eprof, [set, public]), + P = spawn_link(eprof, call, [self(), M, F, A]), + case ptrac([P|Rootset], true, all()) of + true -> + uni_schedule(), + call_trace_for_all(true), + P ! {self(),go}, + {noreply, #state{table = Tab, + profiling = true, + rootset = [P|Rootset]}}; + false -> + exit(P, kill), + erase(replyto), + {reply, error, #state{}} + end; + +handle_call(dump, _FromTag, S) -> + {reply, dump(S#state.table), S}; + +handle_call(analyse, _FromTag, S) -> + {reply, analyse(S), S}; + +handle_call(total_analyse, _FromTag, S) -> + {reply, total_analyse(S), S}; + +handle_call(stop, _FromTag, S) -> + multi_schedule(), + {stop, normal, stopped, S}. + +%%%%%%%%%%%%%%%%%%% + +handle_info({trace_ts,_From,_Op,_Func,_Time}=M, S0) when S0#state.profiling -> + Start = erlang:now(), + #state{table=Tab,pop=PrevOp0,ptime=PrevTime0,pfunc=PrevFunc0, + overhead=Overhead0} = S0, + {PrevFunc,PrevOp,PrevTime} = do_messages(M, Tab, PrevFunc0, PrevOp0, PrevTime0), + Overhead = Overhead0 + subtr(erlang:now(), Start), + S = S0#state{overhead=Overhead,pfunc=PrevFunc,pop=PrevOp,ptime=PrevTime}, + {noreply,S}; + +handle_info({trace_ts, From, _, _, _}, S) when not S#state.profiling -> + ptrac([From], false, all()), + {noreply, S}; + +handle_info({_P, {answer, A}}, S) -> + ptrac(S#state.rootset, false, all()), + io:format("eprof: Stop profiling~n",[]), + {From,_Tag} = get(replyto), + catch unlink(From), + ets:delete(S#state.table, nofunc), + gen_server:reply(erase(replyto), {ok, A}), + multi_schedule(), + {noreply, S#state{profiling = false, + rootset = []}}; + +handle_info({'EXIT', P, Reason}, + #state{profiling=true,proc=P,table=T,rootset=RootSet}) -> + maybe_delete(T), + ptrac(RootSet, false, all()), + multi_schedule(), + io:format("eprof: Profiling failed\n",[]), + case erase(replyto) of + undefined -> + {noreply, #state{}}; + FromTag -> + gen_server:reply(FromTag, {error, Reason}), + {noreply, #state{}} + end; + +handle_info({'EXIT',_P,_Reason}, S) -> + {noreply, S}. + +uni_schedule() -> + erlang:system_flag(multi_scheduling, block). + +multi_schedule() -> + erlang:system_flag(multi_scheduling, unblock). + +%%%%%%%%%%%%%%%%%% + +call(Top, M, F, A) -> + receive + {Top,go} -> + Top ! {self(), {answer, apply(M,F,A)}} + end. + +call_trace_for_all(Flag) -> + erlang:trace_pattern(on_load, Flag, [local]), + erlang:trace_pattern({'_','_','_'}, Flag, [local]). + +ptrac([P|T], How, Flags) when is_pid(P) -> + case dotrace(P, How, Flags) of + true -> + ptrac(T, How, Flags); + false when How -> + false; + false -> + ptrac(T, How, Flags) + end; + +ptrac([P|T], How, Flags) when is_atom(P) -> + case whereis(P) of + undefined when How -> + false; + undefined when not How -> + ptrac(T, How, Flags); + Pid -> + ptrac([Pid|T], How, Flags) + end; + +ptrac([H|_],_How,_Flags) -> + io:format("** eprof bad process ~w~n",[H]), + false; + +ptrac([],_,_) -> true. + +dotrace(P, How, What) -> + case (catch erlang:trace(P, How, What)) of + 1 -> + true; + _Other when not How -> + true; + _Other -> + io:format("** eprof: bad process: ~p,~p,~p~n", [P,How,What]), + false + end. + +all() -> [call,arity,return_to,running,timestamp,set_on_spawn]. + +total_analyse(#state{table=notable}) -> + nothing_to_analyse; +total_analyse(S) -> + #state{table = T, overhead = Overhead} = S, + QH = qlc:q([{{From,Mfa},Time,Count} || + {[From|Mfa],Time,Count} <- ets:table(T)]), + Pcalls = reverse(keysort(2, replicas(qlc:eval(QH)))), + Time = collect_times(Pcalls), + format("FUNCTION~44s TIME ~n", ["CALLS"]), + printit(Pcalls, Time), + format("\nTotal time: ~.2f\n", [Time / 1000000]), + format("Measurement overhead: ~.2f\n", [Overhead / 1000000]). + +analyse(#state{table=notable}) -> + nothing_to_analyse; +analyse(S) -> + #state{table = T, overhead = Overhead} = S, + Pids = ordsets:from_list(flatten(ets:match(T, {['$1'|'_'],'_', '_'}))), + Times = sum(ets:match(T, {'_','$1', '_'})), + format("FUNCTION~44s TIME ~n", ["CALLS"]), + do_pids(Pids, T, 0, Times), + format("\nTotal time: ~.2f\n", [Times / 1000000]), + format("Measurement overhead: ~.2f\n", [Overhead / 1000000]). + +do_pids([Pid|Tail], T, AckTime, Total) -> + Pcalls = + reverse(keysort(2, to_tups(ets:match(T, {[Pid|'$1'], '$2','$3'})))), + Time = collect_times(Pcalls), + PercentTotal = 100 * (divide(Time, Total)), + format("~n****** Process ~w -- ~s % of profiled time *** ~n", + [Pid, fpf(PercentTotal)]), + printit(Pcalls, Time), + do_pids(Tail, T, AckTime + Time, Total); +do_pids([], _, _, _) -> + ok. + +printit([],_) -> ok; +printit([{{Mod,Fun,Arity}, Time, Calls} |Tail], ProcTime) -> + format("~s ~s ~s % ~n", [ff(Mod,Fun,Arity), fint(Calls), + fpf(100*(divide(Time,ProcTime)))]), + printit(Tail, ProcTime); +printit([{{_,{Mod,Fun,Arity}}, Time, Calls} |Tail], ProcTime) -> + format("~s ~s ~s % ~n", [ff(Mod,Fun,Arity), fint(Calls), + fpf(100*(divide(Time,ProcTime)))]), + printit(Tail, ProcTime); +printit([_|T], Time) -> + printit(T, Time). + +ff(Mod,Fun,Arity) -> + pad(flatten(io_lib:format("~w:~w/~w", [Mod,Fun, Arity])),45). + +pad(Str, Len) -> + Strlen = length(Str), + if + Strlen > Len -> strip_tail(Str, 45); + true -> lists:append(Str, mklist(Len-Strlen)) + end. + +strip_tail([_|_], 0) ->[]; +strip_tail([H|T], I) -> [H|strip_tail(T, I-1)]; +strip_tail([],_I) -> []. + +fpf(F) -> strip_tail(flatten(io_lib:format("~w", [round(F)])), 5). +fint(Int) -> pad(flatten(io_lib:format("~w",[Int])), 10). + +mklist(0) -> []; +mklist(I) -> [$ |mklist(I-1)]. + +to_tups(L) -> lists:map(fun(List) -> erlang:list_to_tuple(List) end, L). + +divide(X,Y) -> X / Y. + +collect_times([]) -> 0; +collect_times([Tup|Tail]) -> element(2, Tup) + collect_times(Tail). + +dump(T) -> + L = ets:tab2list(T), + format(L). + +format([H|T]) -> + format("~p~n", [H]), format(T); +format([]) -> ok. + +format(F, A) -> + io:format(F,A), + case get(fd) of + undefined -> ok; + Fd -> io:format(Fd, F,A) + end. + +maybe_delete(T) -> + catch ets:delete(T). + +sum([[H]|T]) -> H + sum(T); +sum([]) -> 0. + +replicas(L) -> + replicas(L, []). + +replicas([{{Pid, {Mod,Fun,Arity}}, Ack,Calls} |Tail], Result) -> + case search({Mod,Fun,Arity},Result) of + false -> + replicas(Tail, [{{Pid, {Mod,Fun,Arity}}, Ack,Calls} |Result]); + {Ack2, Calls2} -> + Result2 = del({Mod,Fun,Arity}, Result), + replicas(Tail, [{{Pid, {Mod,Fun,Arity}}, + Ack+Ack2,Calls+Calls2} |Result2]) + end; + +replicas([_|T], Ack) -> %% Whimpy + replicas(T, Ack); + +replicas([], Res) -> Res. + +search(Key, [{{_,Key}, Ack, Calls}|_]) -> + {Ack, Calls}; +search(Key, [_|T]) -> + search(Key, T); +search(_Key,[]) -> false. + +del(Key, [{{_,Key},_Ack,_Calls}|T]) -> + T; +del(Key, [H | Tail]) -> + [H|del(Key, Tail)]; +del(_Key,[]) -> []. + +flush_receive() -> + receive + {trace_ts, From, _, _, _} when is_pid(From) -> + ptrac([From], false, all()), + flush_receive(); + _ -> + flush_receive() + after 0 -> + ok + end. + +code_change(_OldVsn, State, _Extra) -> + {ok,State}. diff --git a/lib/tools/src/fprof.erl b/lib/tools/src/fprof.erl new file mode 100644 index 0000000000..155965a65a --- /dev/null +++ b/lib/tools/src/fprof.erl @@ -0,0 +1,2762 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2001-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% +%% + +%%%---------------------------------------------------------------------- +%%% File : fprof.erl +%%% Author : Raimo Niskanen +%%% Purpose : File tracing profiling tool wich accumulated times. +%%% Created : 18 Jun 2001 by Raimo Niskanen +%%%---------------------------------------------------------------------- + +-module(fprof). +-author('raimo@erix.ericsson.se'). + +%% External exports +-export([ + apply/2, apply/3, apply/4, + start/0, stop/0, stop/1, + trace/1, trace/2, + profile/0, profile/1, profile/2, + analyse/0, analyse/1, analyse/2]). +%% Debug functions +-export([get_state/0, + save_profile/0, save_profile/1, save_profile/2, + load_profile/0, load_profile/1, load_profile/2, + code_change/0]). + +%% Debug exports +-export([call/1, just_call/1, reply/2]). +-export([trace_off/0, trace_on/3]). +-export([getopts/2, setopts/1]). +-export([println/5, print_callers/2, print_func/2, print_called/2]). +-export([trace_call_collapse/1]). +-export([parsify/1]). + +%% Internal exports +-export(['$code_change'/1]). + + + +-define(FNAME_WIDTH, 72). +-define(NR_WIDTH, 15). + +-define(TRACE_FILE, "fprof.trace"). +-define(DUMP_FILE, "fprof.dump"). +-define(PROFILE_FILE, "fprof.profile"). +-define(ANALYSIS_FILE, "fprof.analysis"). + +-define(FPROF_SERVER, fprof_server). +-define(FPROF_SERVER_TIMEOUT, infinity). + + + +-define(debug, 9). +%-define(debug, 0). +-ifdef(debug). +dbg(Level, F, A) when Level >= ?debug -> + io:format(F, A), + ok; +dbg(_, _, _) -> + ok. +-define(dbg(Level, F, A), dbg((Level), (F), (A))). +-else. +-define(dbg(Level, F, A), ok). +-endif. + + + +%%%---------------------------------------------------------------------- +%%% Higher order API functions +%%%---------------------------------------------------------------------- + + + +apply({M, F} = Function, Args) + when is_atom(M), is_atom(F), is_list(Args) -> + apply_1(Function, Args, []); +apply(Fun, Args) + when is_function(Fun), is_list(Args) -> + apply_1(Fun, Args, []); +apply(A, B) -> + erlang:error(badarg, [A, B]). + +apply(M, F, Args) when is_atom(M), is_atom(F), is_list(Args) -> + apply_1({M, F}, Args, []); +apply({M, F} = Function, Args, Options) + when is_atom(M), is_atom(F), is_list(Args), is_list(Options) -> + apply_1(Function, Args, Options); +apply(Fun, Args, Options) + when is_function(Fun), is_list(Args), is_list(Options) -> + apply_1(Fun, Args, Options); +apply(A, B, C) -> + erlang:error(badarg, [A, B, C]). + +apply(Module, Function, Args, Options) + when is_atom(Module), is_atom(Function), is_list(Args), is_list(Options) -> + apply_1({Module, Function}, Args, Options); +apply(A, B, C, D) -> + erlang:error(badarg, [A, B, C, D]). + + +apply_1(Function, Args, Options) -> + {[_, Procs, Continue], Options_1} = + getopts(Options, [start, procs, continue]), + Procs_1 = case Procs of + [{procs, P}] when is_list(P) -> + P; + _ -> + [] + end, + case Continue of + [] -> + apply_start_stop(Function, Args, Procs_1, Options_1); + [continue] -> + apply_continue(Function, Args, Procs_1, Options_1); + _ -> + erlang:error(badarg, [Function, Args, Options]) + end. + + + +apply_start_stop(Function, Args, Procs, Options) -> + Ref = make_ref(), + Parent = self(), + Child = + spawn( + fun() -> + MRef = erlang:monitor(process, Parent), + receive + {Parent, Ref, start_trace} -> + case trace([start, + {procs, [Parent | Procs]} + | Options]) of + ok -> + catch Parent ! {self(), Ref, trace_started}, + receive + {Parent, Ref, stop_trace} -> + trace([stop]), + catch Parent + ! {self(), Ref, trace_stopped}, + done; + {'DOWN', MRef, _, _, _} -> + trace([stop]) + end; + {error, Reason} -> + exit(Reason) + end; + {'DOWN', MRef, _, _, _} -> + done + end + end), + MRef = erlang:monitor(process, Child), + catch Child ! {self(), Ref, start_trace}, + receive + {Child, Ref, trace_started} -> + try erlang:apply(Function, Args) + after + catch Child ! {self(), Ref, stop_trace}, + receive + {Child, Ref, trace_stopped} -> + receive + {'DOWN', MRef, _, _, _} -> + ok + end; + {'DOWN', MRef, _, _, _} -> + trace([stop]) + end + end; + {'DOWN', MRef, _, _, Reason} -> + exit(Reason) + end. + +apply_continue(Function, Args, Procs, Options) -> + Ref = make_ref(), + Parent = self(), + Child = + spawn( + fun() -> + MRef = erlang:monitor(process, Parent), + receive + {Parent, Ref, start_trace} -> + case trace([start, + {procs, [Parent | Procs]} + | Options]) of + ok -> + exit({Ref, trace_started}); + {error, Reason} -> + exit(Reason) + end; + {'DOWN', MRef, _, _, _} -> + done + end + end), + MRef = erlang:monitor(process, Child), + catch Child ! {self(), Ref, start_trace}, + receive + {'DOWN', MRef, _, _, {Ref, trace_started}} -> + erlang:apply(Function, Args); + {'DOWN', MRef, _, _, Reason} -> + exit(Reason) + end. + + + +%%%---------------------------------------------------------------------- +%%% Requests to ?FPROF_SERVER +%%%---------------------------------------------------------------------- + +-record(trace_start, {procs, % List of processes + mode, % normal | verbose + type, % file | tracer + dest}). % Filename | Pid/Port + +-record(trace_stop, {}). + +% -record(open_out, {file}). + +% -record(close_out, {}). + +-record(profile, {src, % Filename + group_leader, % IoPid + dump, % Filename | IoPid + flags}). % List + +-record(profile_start, {group_leader, % IoPid + dump, % Filename | IoPid + flags}). % List + +-record(profile_stop, {}). + +-record(analyse, {group_leader, % IoPid + dest, % Filename | IoPid + flags, % List + cols, % Integer + callers, % Boolean + sort, % acc_r | own_r + totals, % Boolean + details}). % Boolean + +-record(stop, { + reason}). + + + +%%--------------- +%% Debug requests +%%--------------- + +-record(get_state, {}). + +-record(save_profile, {file}). + +-record(load_profile, {file}). + + + +%%%---------------------------------------------------------------------- +%%% Basic API functions +%%%---------------------------------------------------------------------- + + + +trace(start, Filename) -> + trace([start, {file, Filename}]); +trace(verbose, Filename) -> + trace([start, verbose, {file, Filename}]); +trace(Option, Value) when is_atom(Option) -> + trace([{Option, Value}]); +trace(Option, Value) -> + erlang:error(badarg, [Option, Value]). + +trace(stop) -> + %% This shortcut is present to minimize the number of undesired + %% function calls at the end of the trace. + call(#trace_stop{}); +trace(verbose) -> + trace([start, verbose]); +trace([stop]) -> + %% This shortcut is present to minimize the number of undesired + %% function calls at the end of the trace. + call(#trace_stop{}); +trace({Opt, _Val} = Option) when is_atom(Opt) -> + trace([Option]); +trace(Option) when is_atom(Option) -> + trace([Option]); +trace(Options) when is_list(Options) -> + case getopts(Options, + [start, stop, procs, verbose, file, tracer, cpu_time]) of + {[[], [stop], [], [], [], [], []], []} -> + call(#trace_stop{}); + {[[start], [], Procs, Verbose, File, Tracer, CpuTime], []} -> + {Type, Dest} = case {File, Tracer} of + {[], [{tracer, Pid} = T]} + when is_pid(Pid); is_port(Pid) -> + T; + {[file], []} -> + {file, ?TRACE_FILE}; + {[{file, []}], []} -> + {file, ?TRACE_FILE}; + {[{file, _} = F], []} -> + F; + {[], []} -> + {file, ?TRACE_FILE}; + _ -> + erlang:error(badarg, [Options]) + end, + V = case Verbose of + [] -> normal; + [verbose] -> verbose; + [{verbose, true}] -> verbose; + [{verbose, false}] -> normal; + _ -> erlang:error(badarg, [Options]) + end, + CT = case CpuTime of + [] -> wallclock; + [cpu_time] -> cpu_time; + [{cpu_time, true}] -> cpu_time; + [{cpu_time, false}] -> wallclock; + _ -> erlang:error(badarg, [Options]) + end, + call(#trace_start{procs = case Procs of + [] -> + [self()]; + [{procs, P}] when is_list(P) -> + P; + [{procs, P}] -> + [P]; + _ -> + erlang:error(badarg, [Options]) + end, + mode = {V, CT}, + type = Type, + dest = Dest}); + _ -> + erlang:error(badarg, [Options]) + end; +trace(Options) -> + erlang:error(badarg, [Options]). + + + +profile() -> + profile([]). + +profile(Option, Value) when is_atom(Option) -> + profile([{Option, Value}]); +profile(Option, Value) -> + erlang:error(badarg, [Option, Value]). + +profile(Option) when is_atom(Option) -> + profile([Option]); +profile({Opt, _Val} = Option) when is_atom(Opt) -> + profile([Option]); +profile(Options) when is_list(Options) -> + case getopts(Options, [start, stop, file, dump, append]) of + {[Start, [], File, Dump, Append], []} -> + {Target, Flags} = + case {Dump, Append} of + {[], []} -> + {[], []}; + {[dump], []} -> + {group_leader(), []}; + {[{dump, []}], []} -> + {?DUMP_FILE, []}; + {[{dump, []}], [append]} -> + {?DUMP_FILE, [append]}; + {[{dump, D}], [append]} when is_pid(D) -> + erlang:error(badarg, [Options]); + {[{dump, D}], [append]} -> + {D, [append]}; + {[{dump, D}], []} -> + {D, []}; + _ -> + erlang:error(badarg, [Options]) + end, + case {Start, File} of + {[start], []} -> + call(#profile_start{group_leader = group_leader(), + dump = Target, + flags = Flags}); + {[], _} -> + Src = + case File of + [] -> + ?TRACE_FILE; + [file] -> + ?TRACE_FILE; + [{file, []}] -> + ?TRACE_FILE; + [{file, F}] -> + F; + _ -> + erlang:error(badarg, [Options]) + end, + call(#profile{src = Src, + group_leader = group_leader(), + dump = Target, + flags = Flags}); + _ -> + erlang:error(badarg, [Options]) + end; + {[[], [stop], [], [], []], []} -> + call(#profile_stop{}); + _ -> + erlang:error(badarg, [Options]) + end; +profile(Options) -> + erlang:error(badarg, [Options]). + + + +analyse() -> + analyse([]). + +analyse(Option, Value) when is_atom(Option) -> + analyse([{Option, Value}]); +analyse(Option, Value) -> + erlang:error(badarg, [Option, Value]). + +analyse(Option) when is_atom(Option) -> + analyse([Option]); +analyse({Opt, _Val} = Option) when is_atom(Opt) -> + analyse([Option]); +analyse(Options) when is_list(Options) -> + case getopts(Options, + [dest, append, cols, callers, no_callers, + sort, totals, details, no_details]) of + {[Dest, Append, Cols, Callers, NoCallers, + Sort, Totals, Details, NoDetails], []} -> + {Target, Flags} = + case {Dest, Append} of + {[], []} -> + {group_leader(), []}; + {[dest], []} -> + {group_leader(), []}; + {[{dest, []}], []} -> + {?ANALYSIS_FILE, []}; + {[{dest, []}], [append]} -> + {?ANALYSIS_FILE, [append]}; + {[{dest, F}], [append]} when is_pid(F) -> + erlang:error(badarg, [Options]); + {[{dest, F}], [append]} -> + {F, [append]}; + {[{dest, F}], []} -> + {F, []}; + _ -> + erlang:error(badarg, [Options]) + end, + call(#analyse{group_leader = group_leader(), + dest = Target, + flags = Flags, + cols = case Cols of + [] -> + 80; + [{cols, C}] when is_integer(C), C > 0 -> + C; + _ -> + erlang:error(badarg, [Options]) + end, + callers = case {Callers, NoCallers} of + {[], []} -> + true; + {[callers], []} -> + true; + {[{callers, true}], []} -> + true; + {[{callers, false}], []} -> + false; + {[], [no_callers]} -> + false; + _ -> + erlang:error(badarg, [Options]) + end, + sort = case Sort of + [] -> + acc; + [{sort, acc}] -> + acc; + [{sort, own}] -> + own; + _ -> + erlang:error(badarg, [Options]) + end, + totals = case Totals of + [] -> + false; + [totals] -> + true; + [{totals, true}] -> + true; + [{totals, false}] -> + false; + _ -> + erlang:error(badarg, [Options]) + end, + details = case {Details, NoDetails} of + {[], []} -> + true; + {[details], []} -> + true; + {[{details, true}], []} -> + true; + {[{details, false}], []} -> + false; + {[], [no_details]} -> + false; + _ -> + erlang:error(badarg, [Options]) + end}); + _ -> + erlang:error(badarg, [Options]) + end; +analyse(Options) -> + erlang:error(badarg, [Options]). + + + +%%---------------- +%% Debug functions +%%---------------- + + + +get_state() -> + just_call(#get_state{}). + + + +save_profile() -> + save_profile([]). + +save_profile(Option, Value) when is_atom(Option) -> + save_profile([{Option, Value}]); +save_profile(Option, Value) -> + erlang:error(badarg, [Option, Value]). + +save_profile(Option) when is_atom(Option) -> + save_profile([Option]); +save_profile(Options) when is_list(Options) -> + case getopts(Options, [file]) of + {[File], []} -> + call(#save_profile{file = case File of + [] -> + ?PROFILE_FILE; + [{file, F}] -> + F; + _ -> + erlang:error(badarg, [Options]) + end}); + _ -> + erlang:error(badarg, [Options]) + end; +save_profile(Options) -> + erlang:error(badarg, [Options]). + + + +load_profile() -> + load_profile([]). + +load_profile(Option, Value) when is_atom(Option) -> + load_profile([{Option, Value}]); +load_profile(Option, Value) -> + erlang:error(badarg, [Option, Value]). + +load_profile(Option) when is_atom(Option) -> + load_profile([Option]); +load_profile(Options) when is_list(Options) -> + case getopts(Options, [file]) of + {[File], []} -> + call(#load_profile{file = case File of + [] -> + ?PROFILE_FILE; + [{file, F}] -> + F; + _ -> + erlang:error(badarg, [Options]) + end}); + _ -> + erlang:error(badarg, [Options]) + end; +load_profile(Options) -> + erlang:error(badarg, [Options]). + + + +code_change() -> + just_call('$code_change'). + + + +%%%---------------------------------------------------------------------- +%%% ETS table record definitions +%%% The field 'id' must be first in these records; +%%% it is the common ets table index field. +%%%---------------------------------------------------------------------- + +-record(clocks, { + id, + cnt = 0, % Number of calls + own = 0, % Own time (wall clock) + acc = 0}). % Accumulated time : own + subfunctions (wall clock) + +-record(proc, { + id, + parent, + spawned_as, % Spawned MFArgs + init_log = [], % List of first calls, head is newest + init_cnt = 2}). % First calls counter, counts down to 0 + +-record(misc, {id, + data}). + + + +%% Analysis summary record +-record(funcstat, { + callers_sum, % #clocks{id = {Pid, Caller, Func}} + called_sum, % #clocks{id = {Pid, Caller, Func}} + callers = [], % [#clocks{}, ...] + called = []}). % [#clocks{}, ...] + + + +%%%---------------------------------------------------------------------- +%%% ?FPROF_SERVER +%%%---------------------------------------------------------------------- + +%%%------------------- +%%% Exported functions +%%%------------------- + +%% Start server process +start() -> + spawn_3step( + fun () -> + try register(?FPROF_SERVER, self()) of + true -> + process_flag(trap_exit, true), + {{ok, self()}, loop} + catch + error:badarg -> + {{error, {already_started, whereis(?FPROF_SERVER)}}, + already_started} + end + end, + fun (X) -> + X + end, + fun (loop) -> + put(trace_state, idle), + put(profile_state, {idle, undefined}), + put(pending_stop, []), + server_loop([]); + (already_started) -> + ok + end). + + + +%% Stop server process + +stop() -> + stop(normal). + +stop(kill) -> + case whereis(?FPROF_SERVER) of + undefined -> + ok; + Pid -> + exit(Pid, kill), + ok + end; +stop(Reason) -> + just_call(#stop{reason = Reason}), + ok. + + + +%%%------------------------ +%%% Client helper functions +%%%------------------------ + +%% Send request to server process and return the server's reply. +%% First start server if it ain't started. +call(Request) -> + case whereis(?FPROF_SERVER) of + undefined -> + start(), + just_call(Request); + Server -> + just_call(Server, Request) + end. + +%% Send request to server process, and return the server's reply. +%% Returns {'EXIT', Pid, Reason} if the server dies during the +%% call, or if it wasn't started. +just_call(Request) -> + just_call(whereis(?FPROF_SERVER), Request). + +just_call(undefined, _) -> + {'EXIT', ?FPROF_SERVER, noproc}; +just_call(Pid, Request) -> + Mref = erlang:monitor(process, Pid), + receive + {'DOWN', Mref, _, _, Reason} -> + {'EXIT', Pid, Reason} + after 0 -> + Tag = {Mref, self()}, + {T, Demonitor} = case Request of + #stop{} -> + {?FPROF_SERVER_TIMEOUT, false}; + _ -> + {0, true} + end, + %% io:format("~p request: ~p~n", [?MODULE, Request]), + catch Pid ! {?FPROF_SERVER, Tag, Request}, + receive + {?FPROF_SERVER, Mref, Reply} -> + case Demonitor of + true -> erlang:demonitor(Mref); + false -> ok + end, + receive {'DOWN', Mref, _, _, _} -> ok after T -> ok end, + Reply; + {'DOWN', Mref, _, _, Reason} -> + receive {?FPROF_SERVER, Mref, _} -> ok after T -> ok end, + {'EXIT', Pid, Reason} + after ?FPROF_SERVER_TIMEOUT -> + timeout + end + end. + + + +%%%------------------------ +%%% Server helper functions +%%%------------------------ + +%% Return the reply to the client's request. +reply({Mref, Pid}, Reply) when is_reference(Mref), is_pid(Pid) -> + catch Pid ! {?FPROF_SERVER, Mref, Reply}, + ok. + + + +server_loop(State) -> + receive + {?FPROF_SERVER, {Mref, Pid} = Tag, '$code_change'} + when is_reference(Mref), is_pid(Pid) -> + reply(Tag, ok), + ?MODULE:'$code_change'(State); + {?FPROF_SERVER, {Mref, Pid} = Tag, Request} + when is_reference(Mref), is_pid(Pid) -> + server_loop(handle_req(Request, Tag, State)); + Other -> + server_loop(handle_other(Other, State)) + end. + +%-export. +'$code_change'(State) -> + case lists:keysearch(time, 1, module_info(compile)) of + {value, {time, {Y, M, D, HH, MM, SS}}} -> + io:format("~n~w: code change to compile time " + ++"~4..0w-~2..0w-~2..0w ~2..0w:~2..0w:~2..0w~n", + [?MODULE, Y, M, D, HH, MM, SS]); + false -> + ok + end, + server_loop(State). + + + +%% Server help function that stops the server iff the +%% sub state machines are in proper states. Sends the reply +%% to all waiting clients. +try_pending_stop(State) -> + case {get(trace_state), get(profile_state), get(pending_stop)} of + {idle, {idle, _}, [_|_] = PendingStop} -> + Reason = get(stop_reason), + Reply = result(Reason), + lists:foreach( + fun (Tag) -> + reply(Tag, Reply) + end, + PendingStop), + exit(Reason); + _ -> + State + end. + +%%------------------ +%% Server handle_req +%%------------------ + +handle_req(#trace_start{procs = Procs, + mode = Mode, + type = file, + dest = Filename}, Tag, State) -> + case {get(trace_state), get(pending_stop)} of + {idle, []} -> + trace_off(), + Port = open_dbg_trace_port(file, Filename), + case trace_on(Procs, Port, Mode) of + ok -> + put(trace_state, running), + put(trace_type, file), + put(trace_pid, Port), + reply(Tag, ok), + State; + Error -> + reply(Tag, Error), + State + end; + _ -> + reply(Tag, {error, already_tracing}), + State + end; +handle_req(#trace_start{procs = Procs, + mode = Mode, + type = tracer, + dest = Tracer}, Tag, State) -> + case {get(trace_state), get(pending_stop)} of + {idle, []} -> + trace_off(), + case trace_on(Procs, Tracer, Mode) of + ok -> + put(trace_state, running), + put(trace_type, tracer), + put(trace_pid, Tracer), + reply(Tag, ok), + State; + Error -> + reply(Tag, Error), + State + end; + _ -> + reply(Tag, {error, already_tracing}), + State + end; + +handle_req(#trace_stop{}, Tag, State) -> + case get(trace_state) of + running -> + TracePid = get(trace_pid), + trace_off(), + case erase(trace_type) of + file -> + catch erlang:port_close(TracePid), + put(trace_state, stopping), + put(trace_tag, Tag), + State; + tracer -> + erase(trace_pid), + put(trace_state, idle), + case {get(profile_state), get(profile_type), + get(profile_pid)} of + {running, tracer, TracePid} -> + exit(TracePid, normal), + put(profile_tag, Tag), + State; + _ -> + reply(Tag, ok), + try_pending_stop(State) + end + end; + _ -> + reply(Tag, {error, not_tracing}), + State + end; + +handle_req(#profile{src = Filename, + group_leader = GroupLeader, + dump = Dump, + flags = Flags}, Tag, State) -> + case {get(profile_state), get(pending_stop)} of + {{idle, _}, []} -> + case ensure_open(Dump, [write | Flags]) of + {already_open, DumpPid} -> + put(profile_dump, DumpPid), + put(profile_close_dump, false); + {ok, DumpPid} -> + put(profile_dump, DumpPid), + put(profile_close_dump, true); + {error, _} = Error -> + reply(Tag, Error), + State + end, + Table = ets:new(?MODULE, [set, public, {keypos, #clocks.id}]), + Pid = spawn_link_dbg_trace_client(Filename, Table, + GroupLeader, + get(profile_dump)), + put(profile_state, running), + put(profile_type, file), + put(profile_pid, Pid), + put(profile_tag, Tag), + put(profile_table, Table), + State; + _ -> + reply(Tag, {error, already_profiling}), + State + end; + +handle_req(#profile_start{group_leader = GroupLeader, + dump = Dump, + flags = Flags}, Tag, State) -> + case {get(profile_state), get(pending_stop)} of + {{idle, _}, []} -> + case ensure_open(Dump, [write | Flags]) of + {already_open, DumpPid} -> + put(profile_dump, DumpPid), + put(profile_close_dump, false); + {ok, DumpPid} -> + put(profile_dump, DumpPid), + put(profile_close_dump, true); + {error, _} = Error -> + reply(Tag, Error), + State + end, + Table = ets:new(?MODULE, [set, public, {keypos, #clocks.id}]), + Pid = spawn_link_trace_client(Table, GroupLeader, + get(profile_dump)), + put(profile_state, running), + put(profile_type, tracer), + put(profile_pid, Pid), + put(profile_table, Table), + reply(Tag, {ok, Pid}), + State; + _ -> + reply(Tag, {error, already_profiling}), + State + end; + +handle_req(#profile_stop{}, Tag, State) -> + case {get(profile_state), get(profile_type)} of + {running, tracer} -> + ProfilePid = get(profile_pid), + case {get(trace_state), get(trace_type), get(trace_pid)} of + {running, tracer, ProfilePid} -> + trace_off(), + erase(trace_type), + erase(trace_pid), + put(trace_state, idle); + _ -> + ok + end, + exit(ProfilePid, normal), + put(profile_tag, Tag), + State; + {running, file} -> + reply(Tag, {error, profiling_file}), + State; + {_, _} -> + reply(Tag, {error, not_profiling}), + State + end; + +handle_req(#analyse{dest = Dest, + flags = Flags} = Request, Tag, State) -> + case get(profile_state) of + {idle, undefined} -> + reply(Tag, {error, no_profile}), + State; + {idle, _} -> + case ensure_open(Dest, [write | Flags]) of + {error, _} = Error -> + reply(Tag, Error), + State; + {DestState, DestPid} -> + ProfileTable = get(profile_table), + reply(Tag, + spawn_3step( + fun() -> + do_analyse(ProfileTable, + Request#analyse{dest = DestPid}) + end, + fun(Result) -> + {Result,finish} + end, + fun(finish) -> + ok + end)), + case DestState of + already_open -> + ok; + ok -> + file:close(DestPid) + end, + State + end; + _ -> + reply(Tag, {error, profiling}), + State + end; + +handle_req(#stop{reason = Reason}, Tag, State) -> + PendingStop = get(pending_stop), + case PendingStop of + [] -> + put(stop_reason, Reason); + _ -> + ok + end, + put(pending_stop, [Tag | PendingStop]), + try_pending_stop(State); + +%%---------------------- +%% Server debug requests +%%---------------------- + +handle_req(#get_state{}, Tag, State) -> + reply(Tag, {ok, get()}), + State; + +handle_req(#save_profile{file = File}, Tag, State) -> + case get(profile_state) of + {idle, undefined} -> + reply(Tag, {error, no_profile}); + {idle, _} -> + reply(Tag, ets:tab2file(get(profile_table), File)), + State; + _ -> + reply(Tag, {error, profiling}), + State + end; + +handle_req(#load_profile{file = File}, Tag, State) -> + case get(profile_state) of + {idle, Result} -> + case ets:file2tab(File) of + {ok, Table} -> + put(profile_state, {idle, ok}), + case Result of + {error, no_profile} -> + ets:delete(put(profile_table, Table)); + _ -> + put(profile_table, Table) + end, + reply(Tag, ok), + State; + Error -> + reply(Tag, Error), + State + end; + _ -> + reply(Tag, {error, profiling}), + State + end; + + + +handle_req(Request, Tag, State) -> + io:format("~n~p:handle_req, unknown request - ~p~n", + [?MODULE, Request]), + reply(Tag, {error, unknown_request}), + State. + +%%-------------------- +%% Server handle_other +%%-------------------- + +handle_other({'EXIT', Pid, Reason} = Other, State) when is_pid(Pid); is_port(Pid) -> + case {get(trace_state), get(trace_pid)} of + {running, Pid} -> + trace_off(), + io:format("~n~p:handle_other, unexpected ~p (trace_pid)~n", + [?MODULE, Other]), + put(trace_state, idle), + erase(trace_type), + erase(trace_pid), + try_pending_stop(State); + {stopping, Pid} -> + put(trace_state, idle), + erase(trace_pid), + reply(erase(trace_tag), result(Reason)), + try_pending_stop(State); + _ -> + case {get(profile_state), get(profile_pid)} of + {running, Pid} -> + Result = result(Reason), + put(profile_state, {idle, Result}), + erase(profile_type), + erase(profile_pid), + case erase(profile_close_dump) of + true -> + file:close(erase(profile_dump)); + false -> + erase(profile_dump) + end, + reply(erase(profile_tag), Result), + try_pending_stop(State); + _ -> + io:format("~n~p:handle_other, unexpected ~p~n", + [?MODULE, Other]), + State + end + end; + +handle_other(Other, State) -> + io:format("~p:handle_other, unknown - ~p", + [?MODULE, Other]), + State. + + + +%%%---------------------------------------------------------------------- +%%% Internal functions +%%%---------------------------------------------------------------------- + +result(normal) -> + ok; +result(Reason) -> + {error, Reason}. + +ensure_open(Pid, _Options) when is_pid(Pid) -> + {already_open, Pid}; +ensure_open([], _Options) -> + {already_open, undefined}; +ensure_open(Filename, Options) when is_atom(Filename); is_list(Filename) -> + file:open(Filename, Options). + +%%%--------------------------------- +%%% Fairly generic utility functions +%%%--------------------------------- + + + +%% getopts(List, Options)) -> {DecodedOptions, RestOptions} +%% +%% List = [Option] +%% Options = [OptionTag] +%% Option = OptionTag | OptionTuple +%% OptionTuple = tuple(), element(1, OptionTuple) == OptionTag +%% OptionTag = term() +%% OptionValue = term() +%% DecodedOptions = [OptionList] +%% OptionList = [Option] +%% RestOptions = [Option] +%% +%% Searches List for options with tags defined in Options. +%% Returns DecodedOptions containing one OptionList per +%% OptionTag in Options, and RestOptions which contains +%% all terms from List not matching any OptionTag. +%% +%% All returned lists preserve the order from Options and List. +%% +%% An example: +%% getopts([{f, 1}, e, {d, 2}, {c, 3, 4}, {b, 5}, a, b], +%% [a, b, c, d]) -> +%% {[[a], [{b, 5}, b],[{c, 3, 4}], [{d, 2}]], +%% [{f, 1}, e]} +%% +getopts(List, Options) when is_list(List), is_list(Options) -> + getopts_1(Options, List, []). + +getopts_1([], List, Result) -> + {lists:reverse(Result), List}; +getopts_1([Option | Options], List, Result) -> + {Optvals, Remaining} = getopts_2(List, Option, [], []), + getopts_1(Options, Remaining, [Optvals | Result]). + +getopts_2([], _Option, Result, Remaining) -> + {lists:reverse(Result), lists:reverse(Remaining)}; +getopts_2([Option | Tail], Option, Result, Remaining) -> + getopts_2(Tail, Option, [Option | Result], Remaining); +getopts_2([Optval | Tail], Option, Result, Remaining) + when element(1, Optval) =:= Option -> + getopts_2(Tail, Option, [Optval | Result], Remaining); +getopts_2([Other | Tail], Option, Result, Remaining) -> + getopts_2(Tail, Option, Result, [Other | Remaining]). + +%% setopts(Options) -> List +%% +%% The reverse of getopts, almost. +%% Re-creates (approximately) List from DecodedOptions in +%% getopts/2 above. The original order is not preserved, +%% but rather the order from Options. +%% +%% An example: +%% setopts([[a], [{b,5}, b], [{c, 3, 4}], [{d,2}]]) -> +%% [a, {b, 5}, b, {c, 3, 4}, {d, 2}] +%% +%% And a more generic example: +%% {D, R} = getopts(L, O), +%% L2 = setopts(D) ++ R +%% L2 will contain exactly the same terms as L, but not in the same order. +%% +setopts(Options) when is_list(Options) -> + lists:append(Options). + + + +spawn_3step(FunPrelude, FunAck, FunBody) -> + spawn_3step(spawn, FunPrelude, FunAck, FunBody). + +spawn_link_3step(FunPrelude, FunAck, FunBody) -> + spawn_3step(spawn_link, FunPrelude, FunAck, FunBody). + +spawn_3step(Spawn, FunPrelude, FunAck, FunBody) + when Spawn =:= spawn; Spawn =:= spawn_link -> + Parent = self(), + Ref = make_ref(), + Child = + erlang:Spawn( + fun() -> + Ack = FunPrelude(), + catch Parent ! {self(), Ref, Ack}, + MRef = erlang:monitor(process, Parent), + receive + {Parent, Ref, Go} -> + erlang:demonitor(MRef), + receive {'DOWN', MRef, _, _, _} -> ok + after 0 -> ok + end, + FunBody(Go); + {'DOWN', MRef, _, _, _} -> + ok + end + end), + MRef = erlang:monitor(process, Child), + receive + {Child, Ref, Ack} -> + erlang:demonitor(MRef), + receive {'DOWN', MRef, _, _, _} -> ok after 0 -> ok end, + try FunAck(Ack) of + {Result, Go} -> + catch Child ! {Parent, Ref, Go}, + Result + catch + Class:Reason -> + Stacktrace = erlang:get_stacktrace(), + catch exit(Child, kill), + erlang:raise(Class, Reason, Stacktrace) + end; + {'DOWN', MRef, _, _, Reason} -> + receive {Child, Ref, _Ack} -> ok after 0 -> ok end, + case Spawn of + spawn_link -> + receive {'EXIT', Reason} -> ok after 0 -> ok end; + spawn -> + ok + end, + exit(Reason) + end. + + + +%%%--------------------------------- +%%% Trace message handling functions +%%%--------------------------------- + +trace_off() -> + try erlang:trace_delivered(all) of + Ref -> receive {trace_delivered, all, Ref} -> ok end + catch + error:undef -> ok + end, + try erlang:trace(all, false, [all, cpu_timestamp]) + catch + error:badarg -> erlang:trace(all, false, [all]) + end, + erlang:trace_pattern(on_load, false, [local]), + erlang:trace_pattern({'_', '_', '_'}, false, [local]), + ok. + + + +trace_on(Procs, Tracer, {V, CT}) -> + case case CT of + cpu_time -> + try erlang:trace(all, true, [cpu_timestamp]) of _ -> ok + catch + error:badarg -> {error, not_supported} + end; + wallclock -> ok + end + of ok -> + MatchSpec = [{'_', [], [{message, {{cp, {caller}}}}]}], + erlang:trace_pattern(on_load, MatchSpec, [local]), + erlang:trace_pattern({'_', '_', '_'}, MatchSpec, [local]), + lists:foreach( + fun (P) -> + erlang:trace(P, true, [{tracer, Tracer} | trace_flags(V)]) + end, + Procs), + ok; + Error -> + Error + end. + + + +trace_flags(normal) -> + [call, return_to, + running, procs, garbage_collection, + arity, timestamp, set_on_spawn]; +trace_flags(verbose) -> + [call, return_to, + send, 'receive', + running, procs, garbage_collection, + timestamp, set_on_spawn]. + + + +%%%------------------------------------- +%%% Tracer process functions, for +%%% the 'dbg' tracer and for a lookalike +%%%------------------------------------- + +open_dbg_trace_port(Type, Spec) -> + Fun = dbg:trace_port(Type, Spec), + Fun(). + + + +spawn_link_dbg_trace_client(File, Table, GroupLeader, Dump) -> + case dbg:trace_client(file, File, + {fun handler/2, + {init, GroupLeader, Table, Dump}}) of + Pid when is_pid(Pid) -> + link(Pid), + Pid; + Other -> + exit(Other) + end. + + + + +spawn_link_trace_client(Table, GroupLeader, Dump) -> + Parent = self(), + spawn_link_3step( + fun() -> + process_flag(trap_exit, true), + {self(),go} + end, + fun(Ack) -> + Ack + end, + fun(go) -> + Init = {init, GroupLeader, Table, Dump}, + tracer_loop(Parent, fun handler/2, Init) + end). + +tracer_loop(Parent, Handler, State) -> + receive + Trace when element(1, Trace) =:= trace -> + tracer_loop(Parent, Handler, Handler(Trace, State)); + Trace when element(1, Trace) =:= trace_ts -> + tracer_loop(Parent, Handler, Handler(Trace, State)); + {'EXIT', Parent, Reason} -> + handler(end_of_trace, State), + exit(Reason); + _ -> + tracer_loop(Parent, Handler, State) + end. + + + +%%%--------------------------------- +%%% Trace message handling functions +%%%--------------------------------- + +handler(end_of_trace, {init, GroupLeader, Table, Dump}) -> + dump(Dump, start_of_trace), + dump(Dump, end_of_trace), + info(GroupLeader, Dump, "Empty trace!~n", []), + end_of_trace(Table, undefined), + done; +handler(end_of_trace, {error, Reason, _, GroupLeader, Dump}) -> + info(GroupLeader, Dump, "~nEnd of erroneous trace!~n", []), + exit(Reason); +handler(end_of_trace, {_, TS, GroupLeader, Table, Dump}) -> + dump(Dump, end_of_trace), + info(GroupLeader, Dump, "~nEnd of trace!~n", []), + end_of_trace(Table, TS), + done; +handler(Trace, {init, GroupLeader, Table, Dump}) -> + dump(Dump, start_of_trace), + info(GroupLeader, Dump, "Reading trace data...~n", []), + try trace_handler(Trace, Table, GroupLeader, Dump) of + TS -> + ets:insert(Table, #misc{id = first_ts, data = TS}), + ets:insert(Table, #misc{id = last_ts_n, data = {TS, 1}}), + {1, TS, GroupLeader, Table, Dump} + catch + Error -> + dump(Dump, {error, Error}), + end_of_trace(Table, undefined), + {error, Error, 1, GroupLeader, Dump} + end; +%% case catch trace_handler(Trace, Table, GroupLeader, Dump) of +%% {'EXIT', Reason} -> +%% dump(Dump, {error, Reason}), +%% end_of_trace(Table, undefined), +%% {error, Reason, 1, GroupLeader, Dump}; +%% TS -> +%% ets:insert(Table, #misc{id = first_ts, data = TS}), +%% ets:insert(Table, #misc{id = last_ts_n, data = {TS, 1}}), +%% {1, TS, GroupLeader, Table, Dump} +%% end; +handler(_, {error, Reason, M, GroupLeader, Dump}) -> + N = M+1, + info_dots(GroupLeader, Dump, N), + {error, Reason, N, GroupLeader, Dump}; +handler(Trace, {M, TS0, GroupLeader, Table, Dump}) -> + N = M+1, + info_dots(GroupLeader, Dump, N), + try trace_handler(Trace, Table, GroupLeader, Dump) of + TS -> + ets:insert(Table, #misc{id = last_ts_n, data = {TS, N}}), + {N, TS, GroupLeader, Table, Dump} + catch + Error -> + dump(Dump, {error, Error}), + end_of_trace(Table, TS0), + {error, Error, N, GroupLeader, Dump} + end. +%% case catch trace_handler(Trace, Table, GroupLeader, Dump) of +%% {'EXIT', Reason} -> +%% dump(Dump, {error, Reason}), +%% end_of_trace(Table, TS0), +%% {error, Reason, N, GroupLeader, Dump}; +%% TS -> +%% ets:insert(Table, #misc{id = last_ts_n, data = {TS, N}}), +%% {N, TS, GroupLeader, Table, Dump} +%% end. + + + +end_of_trace(Table, TS) -> + %% + %% Close all process stacks, as if the processes exited. + %% + Procs = get(), + put(table, Table), + ?dbg(2, "get() -> ~p~n", [Procs]), + lists:map( + fun ({Pid, _}) when is_pid(Pid) -> + trace_exit(Table, Pid, TS) + end, + Procs), + erase(), + ok. + + + +info_dots(GroupLeader, GroupLeader, _) -> + ok; +info_dots(GroupLeader, _, N) -> + if (N rem 100000) =:= 0 -> + io:format(GroupLeader, ",~n", []); + (N rem 50000) =:= 0 -> + io:format(GroupLeader, ".~n", []); + (N rem 1000) =:= 0 -> + io:put_chars(GroupLeader, "."); + true -> + ok + end. + +info_suspect_call(GroupLeader, GroupLeader, _, _) -> + ok; +info_suspect_call(GroupLeader, _, Func, Pid) -> + io:format(GroupLeader, + "~nWarning: ~p called in ~p - trace may become corrupt!~n", + parsify([Func, Pid])). + +info(GroupLeader, GroupLeader, _, _) -> + ok; +info(GroupLeader, _, Format, List) -> + io:format(GroupLeader, Format, List). + +dump_stack(undefined, _, _) -> + false; +dump_stack(Dump, Stack, Term) -> + {Depth, _D} = + case Stack of + undefined -> + {0, 0}; + _ -> + case length(Stack) of + 0 -> + {0, 0}; + N -> + {N, length(hd(Stack))} + end + end, + io:format(Dump, "~s~p.~n", [lists:duplicate(Depth, " "), parsify(Term)]), + true. + +dump(undefined, _) -> + false; +dump(Dump, Term) -> + io:format(Dump, "~p.~n", [parsify(Term)]), + true. + + + +%%%---------------------------------- +%%% Profiling state machine functions +%%%---------------------------------- + + + +trace_handler({trace_ts, Pid, call, _MFA, _TS} = Trace, + _Table, _, Dump) -> + Stack = get(Pid), + dump_stack(Dump, Stack, Trace), + throw({incorrect_trace_data, ?MODULE, ?LINE, + [Trace, Stack]}); +trace_handler({trace_ts, Pid, call, {_M, _F, Arity} = Func, + {cp, CP}, TS} = Trace, + Table, GroupLeader, Dump) + when is_integer(Arity) -> + dump_stack(Dump, get(Pid), Trace), + case Func of + {erlang, trace, 3} -> + info_suspect_call(GroupLeader, Dump, Func, Pid); + {erlang, trace_pattern, 3} -> + info_suspect_call(GroupLeader, Dump, Func, Pid); + _ -> + ok + end, + trace_call(Table, Pid, Func, TS, CP), + TS; +trace_handler({trace_ts, Pid, call, {_M, _F, Args} = MFArgs, + {cp, CP}, TS} = Trace, + Table, _, Dump) + when is_list(Args) -> + dump_stack(Dump, get(Pid), Trace), + Func = mfarity(MFArgs), + trace_call(Table, Pid, Func, TS, CP), + TS; +%% +%% return_to +trace_handler({trace_ts, Pid, return_to, undefined, TS} = Trace, + Table, _, Dump) -> + dump_stack(Dump, get(Pid), Trace), + trace_return_to(Table, Pid, undefined, TS), + TS; +trace_handler({trace_ts, Pid, return_to, {_M, _F, Arity} = Func, TS} = Trace, + Table, _, Dump) + when is_integer(Arity) -> + dump_stack(Dump, get(Pid), Trace), + trace_return_to(Table, Pid, Func, TS), + TS; +trace_handler({trace_ts, Pid, return_to, {_M, _F, Args} = MFArgs, TS} = Trace, + Table, _, Dump) + when is_list(Args) -> + dump_stack(Dump, get(Pid), Trace), + Func = mfarity(MFArgs), + trace_return_to(Table, Pid, Func, TS), + TS; +%% +%% spawn +trace_handler({trace_ts, Pid, spawn, Child, MFArgs, TS} = Trace, + Table, _, Dump) -> + dump_stack(Dump, get(Pid), Trace), + trace_spawn(Table, Child, MFArgs, TS, Pid), + TS; +%% +%% exit +trace_handler({trace_ts, Pid, exit, _Reason, TS} = Trace, + Table, _, Dump) -> + dump_stack(Dump, get(Pid), Trace), + trace_exit(Table, Pid, TS), + TS; +%% +%% out +trace_handler({trace_ts, Pid, out, 0, TS} = Trace, + Table, _, Dump) -> + dump_stack(Dump, get(Pid), Trace), + trace_out(Table, Pid, undefined, TS), + TS; +trace_handler({trace_ts, Pid, out, {_M, _F, Arity} = Func, TS} = Trace, + Table, _, Dump) + when is_integer(Arity) -> + dump_stack(Dump, get(Pid), Trace), + trace_out(Table, Pid, Func, TS), + TS; +trace_handler({trace_ts, Pid, out, {_M, _F, Args} = MFArgs, TS} = Trace, + Table, _, Dump) + when is_list(Args) -> + dump_stack(Dump, get(Pid), Trace), + Func = mfarity(MFArgs), + trace_out(Table, Pid, Func, TS), + TS; +%% +%% in +trace_handler({trace_ts, Pid, in, 0, TS} = Trace, + Table, _, Dump) -> + dump_stack(Dump, get(Pid), Trace), + trace_in(Table, Pid, undefined, TS), + TS; +trace_handler({trace_ts, Pid, in, {_M, _F, Arity} = Func, TS} = Trace, + Table, _, Dump) + when is_integer(Arity) -> + dump_stack(Dump, get(Pid), Trace), + trace_in(Table, Pid, Func, TS), + TS; +trace_handler({trace_ts, Pid, in, {_M, _F, Args} = MFArgs, TS} = Trace, + Table, _, Dump) + when is_list(Args) -> + dump_stack(Dump, get(Pid), Trace), + Func = mfarity(MFArgs), + trace_in(Table, Pid, Func, TS), + TS; +%% +%% gc_start +trace_handler({trace_ts, Pid, gc_start, _Func, TS} = Trace, + Table, _, Dump) -> + dump_stack(Dump, get(Pid), Trace), + trace_gc_start(Table, Pid, TS), + TS; +%% +%% gc_end +trace_handler({trace_ts, Pid, gc_end, _Func, TS} = Trace, + Table, _, Dump) -> + dump_stack(Dump, get(Pid), Trace), + trace_gc_end(Table, Pid, TS), + TS; +%% +%% link +trace_handler({trace_ts, Pid, link, _OtherPid, TS} = Trace, + _Table, _, Dump) -> + dump_stack(Dump, get(Pid), Trace), + TS; +%% +%% unlink +trace_handler({trace_ts, Pid, unlink, _OtherPid, TS} = Trace, + _Table, _, Dump) -> + dump_stack(Dump, get(Pid), Trace), + TS; +%% +%% getting_linked +trace_handler({trace_ts, Pid, getting_linked, _OtherPid, TS} = Trace, + _Table, _, Dump) -> + dump_stack(Dump, get(Pid), Trace), + TS; +%% +%% getting_unlinked +trace_handler({trace_ts, Pid, getting_unlinked, _OtherPid, TS} = Trace, + _Table, _, Dump) -> + dump_stack(Dump, get(Pid), Trace), + TS; +%% +%% register +trace_handler({trace_ts, Pid, register, _Name, TS} = Trace, + _Table, _, Dump) -> + dump_stack(Dump, get(Pid), Trace), + TS; +%% +%% unregister +trace_handler({trace_ts, Pid, unregister, _Name, TS} = Trace, + _Table, _, Dump) -> + dump_stack(Dump, get(Pid), Trace), + TS; +%% +%% send +trace_handler({trace_ts, Pid, send, _OtherPid, _Msg, TS} = Trace, + _Table, _, Dump) -> + dump_stack(Dump, get(Pid), Trace), + TS; +%% +%% 'receive' +trace_handler({trace_ts, Pid, 'receive', _Msg, TS} = Trace, + _Table, _, Dump) -> + dump_stack(Dump, get(Pid), Trace), + TS; +%% +%% Others +trace_handler(Trace, _Table, _, Dump) -> + dump(Dump, Trace), + throw({incorrect_trace_data, ?MODULE, ?LINE, [Trace]}). + + + +%% The call stack +%% -------------- +%% +%% The call stack can be modeled as a tree, with each level in the tree +%% corresponding to a real (non-tail recursive) stack entry, +%% and the nodes within a level corresponding to tail recursive +%% calls on that real stack depth. +%% +%% Example: +%% a() -> +%% b(). +%% b() -> +%% c(), +%% d(). +%% c() -> ok. +%% d() -> +%% e(), +%% c(). +%% e() -> +%% f(). +%% f() -> ok. +%% +%% During the execution the call tree would be, for each call and return_to: +%% +%% a() b() c() ->b d() e() f() ->d c() ->a +%% +%% a a a a a a a a a a +%% | | | |\ |\ |\ |\ /|\ +%% b b b b d b d b d b d b d c +%% | | /| +%% c e e f +%% +%% The call tree is in this code represented as a two level list, +%% which for the biggest tree (5 nodes) in the example above would be: +%% [[{f, _}, {e, _}], [{d, _}, {b, _}], [{a, _}]] +%% where the undefined fields are timestamps of the calls to the +%% functions, and the function name fields are really +%% {Module, Function, Arity} tuples. +%% +%% Since tail recursive calls can form an infinite loop, cycles +%% within a tail recursive level must be collapsed or else the +%% stack (tree) size may grow towards infinity. + + + +trace_call(Table, Pid, Func, TS, CP) -> + Stack = get_stack(Pid), + ?dbg(0, "trace_call(~p, ~p, ~p, ~p)~n~p~n", + [Pid, Func, TS, CP, Stack]), + {Proc,InitCnt} = + case ets:lookup(Table, Pid) of + [#proc{init_cnt = N} = P] -> + {P,N}; + [] -> + {undefined,0} + end, + case Stack of + [] -> + init_log(Table, Proc, Func), + OldStack = + if CP =:= undefined -> + Stack; + true -> + [[{CP, TS}]] + end, + put(Pid, trace_call_push(Table, Pid, Func, TS, OldStack)); + [[{Func, FirstInTS}]] when InitCnt=:=2 -> + %% First call on this process. Take the timestamp for first + %% time the process was scheduled in. + init_log(Table, Proc, Func), + OldStack = + if CP =:= undefined -> + []; + true -> + [[{CP, FirstInTS}]] + end, + put(Pid, trace_call_push(Table, Pid, Func, FirstInTS, OldStack)); + [[{suspend, _} | _] | _] -> + throw({inconsistent_trace_data, ?MODULE, ?LINE, + [Pid, Func, TS, CP, Stack]}); + [[{garbage_collect, _} | _] | _] -> + throw({inconsistent_trace_data, ?MODULE, ?LINE, + [Pid, Func, TS, CP, Stack]}); + [[{CP, _} | _], [{CP, _} | _] | _] -> + %% This is a difficult case - current function becomes + %% new stack top but is already pushed. It might be that + %% this call is actually tail recursive, or maybe not. + %% Assume tail recursive to not build the stack infinitely + %% and fix the problem at the next call after a return to + %% this level. + %% + %% This can be viewed as collapsing a very short stack + %% recursive stack cykle. + init_log(Table, Proc, Func), + put(Pid, trace_call_shove(Table, Pid, Func, TS, Stack)); + [[{CP, _} | _] | _] -> + %% Current function becomes new stack top -> stack push + init_log(Table, Proc, Func), + put(Pid, trace_call_push(Table, Pid, Func, TS, Stack)); + [_, [{CP, _} | _] | _] -> + %% Stack top unchanged -> no push == tail recursive call + init_log(Table, Proc, Func), + put(Pid, trace_call_shove(Table, Pid, Func, TS, Stack)); + [[{Func0, _} | _], [{Func0, _} | _], [{CP, _} | _] | _] -> + %% Artificial case that only should happen when + %% stack recursive short cycle collapsing has been done, + %% otherwise CP should not occur so far from the stack front. + %% + %% It is a tail recursive call but fix the stack first. + init_log(Table, Proc, Func), + put(Pid, + trace_call_shove(Table, Pid, Func, TS, + trace_return_to_int(Table, Pid, Func0, TS, + Stack))); + [[{_, TS0} | _] = Level0] -> + %% Current function known, but not stack top + %% -> assume tail recursive call + init_log(Table, Proc, Func), + OldStack = + if CP =:= undefined -> + Stack; + true -> + [Level0, [{CP, TS0}]] + end, + put(Pid, trace_call_shove(Table, Pid, Func, TS, OldStack)); + [_ | _] -> + %% Weird case when the stack is seriously f***ed up. + %% CP is not at stack top nor at previous stack top, + %% which is impossible, if we had a correct stack view. + OldStack = + if CP =:= undefined -> + %% Assume that CP is unknown because it is + %% the stack bottom for the process, and that + %% the whole call stack is invalid. Waste it. + trace_return_to_int(Table, Pid, CP, TS, Stack); + true -> + %% Assume that we have collapsed a tail recursive + %% call stack cykle too many. Introduce CP in + %% the current tail recursive level so it at least + %% gets charged for something. + init_log(Table, Proc, CP), + trace_call_shove(Table, Pid, CP, TS, Stack) + end, + %% Regard this call as a stack push. + init_log(Table, Pid, Func), % will lookup Pid in Table + put(Pid, trace_call_push(Table, Pid, Func, TS, OldStack)) + end, + ok. + +%% Normal stack push +trace_call_push(Table, Pid, Func, TS, Stack) -> + case Stack of + [] -> + ok; + [_ | _] -> + trace_clock(Table, Pid, TS, Stack, #clocks.own) + end, + NewStack = [[{Func, TS}] | Stack], + trace_clock(Table, Pid, 1, NewStack, #clocks.cnt), + NewStack. + +%% Tail recursive stack push +trace_call_shove(Table, Pid, Func, TS, Stack) -> + trace_clock(Table, Pid, TS, Stack, #clocks.own), + [[_ | NewLevel0] | NewStack1] = + case Stack of + [] -> + [[{Func, TS}]]; + [Level0 | Stack1] -> + [trace_call_collapse([{Func, TS} | Level0]) | Stack1] + end, + NewStack = [[{Func, TS} | NewLevel0] | NewStack1], + trace_clock(Table, Pid, 1, NewStack, #clocks.cnt), + NewStack. + +%% Collapse tail recursive call stack cycles to prevent them from +%% growing to infinite length. +trace_call_collapse([]) -> + []; +trace_call_collapse([_] = Stack) -> + Stack; +trace_call_collapse([_, _] = Stack) -> + Stack; +trace_call_collapse([_ | Stack1] = Stack) -> + trace_call_collapse_1(Stack, Stack1, 1). + +%% Find some other instance of the current function in the call stack +%% and try if that instance may be used as stack top instead. +trace_call_collapse_1(Stack, [], _) -> + Stack; +trace_call_collapse_1([{Func0, _} | _] = Stack, [{Func0, _} | S1] = S, N) -> + case trace_call_collapse_2(Stack, S, N) of + true -> + S; + false -> + trace_call_collapse_1(Stack, S1, N+1) + end; +trace_call_collapse_1(Stack, [_ | S1], N) -> + trace_call_collapse_1(Stack, S1, N+1). + +%% Check if all caller/called pairs in the perhaps to be collapsed +%% stack segment (at the front) are present in the rest of the stack, +%% and also in the same order. +trace_call_collapse_2(_, _, 0) -> + true; +trace_call_collapse_2([{Func1, _} | [{Func2, _} | _] = Stack2], + [{Func1, _} | [{Func2, _} | _] = S2], + N) -> + trace_call_collapse_2(Stack2, S2, N-1); +trace_call_collapse_2([{Func1, _} | _], [{Func1, _} | _], _N) -> + false; +trace_call_collapse_2(_Stack, [_], _N) -> + false; +trace_call_collapse_2(Stack, [_ | S], N) -> + trace_call_collapse_2(Stack, S, N); +trace_call_collapse_2(_Stack, [], _N) -> + false. + + + +trace_return_to(Table, Pid, Func, TS) -> + Stack = get_stack(Pid), + ?dbg(0, "trace_return_to(~p, ~p, ~p)~n~p~n", + [Pid, Func, TS, Stack]), + case Stack of + [[{suspend, _} | _] | _] -> + throw({inconsistent_trace_data, ?MODULE, ?LINE, + [Pid, Func, TS, Stack]}); + [[{garbage_collect, _} | _] | _] -> + throw({inconsistent_trace_data, ?MODULE, ?LINE, + [Pid, Func, TS, Stack]}); + [_ | _] -> + put(Pid, trace_return_to_int(Table, Pid, Func, TS, Stack)); + [] -> + put(Pid, trace_return_to_int(Table, Pid, Func, TS, Stack)) + end, + ok. + +trace_return_to_int(Table, Pid, Func, TS, Stack) -> + %% The old stack must be sent to trace_clock, so + %% the function we just returned from is charged with + %% own time. + trace_clock(Table, Pid, TS, Stack, #clocks.own), + case trace_return_to_2(Table, Pid, Func, TS, Stack) of + {undefined, _} -> + [[{Func, TS}] | Stack]; + {[[{Func, _} | Level0] | Stack1], _} -> + [[{Func, TS} | Level0] | Stack1]; + {NewStack, _} -> + NewStack + end. + +%% A list of charged functions is passed around to assure that +%% any function is charged with ACC time only once - the first time +%% it is encountered. The function trace_return_to_1 is called only +%% for the front of a tail recursive level, and if the front +%% does not match the returned-to function, trace_return_to_2 +%% is called for all functions within the tail recursive level. +%% +%% Charging is done in reverse order, i.e from stack rear to front. + +%% Search the call stack until the returned-to function is found at +%% a tail recursive level's front, and charge it with ACC time. +trace_return_to_1(_, _, undefined, _, []) -> + {[], []}; +trace_return_to_1(_, _, _, _, []) -> + {undefined, []}; +trace_return_to_1(Table, Pid, Func, TS, + [[{Func, _} | Level0] | Stack1] = Stack) -> + %% Match at front of tail recursive level + Charged = trace_return_to_3([Level0 | Stack1], []), + case lists:member(Func, Charged) of + false -> + trace_clock(Table, Pid, TS, Stack, #clocks.acc), + {Stack, [Func | Charged]}; + true -> + {Stack, Charged} + end; +trace_return_to_1(Table, Pid, Func, TS, Stack) -> + trace_return_to_2(Table, Pid, Func, TS, Stack). + +%% Charge all functions within one tail recursive level, +%% from rear to front, with ACC time. +trace_return_to_2(Table, Pid, Func, TS, [] = Stack) -> + trace_return_to_1(Table, Pid, Func, TS, Stack); +trace_return_to_2(Table, Pid, Func, TS, [[] | Stack1]) -> + trace_return_to_1(Table, Pid, Func, TS, Stack1); +trace_return_to_2(Table, Pid, Func, TS, + [[{Func0, _} | Level1] | Stack1] = Stack) -> + case trace_return_to_2(Table, Pid, Func, TS, [Level1 | Stack1]) of + {undefined, _} = R -> + R; + {NewStack, Charged} = R -> + case lists:member(Func0, Charged) of + false -> + trace_clock(Table, Pid, TS, Stack, #clocks.acc), + {NewStack, [Func0 | Charged]}; + true -> + R + end + end. + +%% Return a flat list of all function names in the given stack +trace_return_to_3([], R) -> + R; +trace_return_to_3([[] | Stack1], R) -> + trace_return_to_3(Stack1, R); +trace_return_to_3([[{Func0, _} | Level0] | Stack1], R) -> + trace_return_to_3([Level0 | Stack1], [Func0 | R]). + + + +trace_spawn(Table, Pid, MFArgs, TS, Parent) -> + Stack = get(Pid), + ?dbg(0, "trace_spawn(~p, ~p, ~p, ~p)~n~p~n", + [Pid, MFArgs, TS, Parent, Stack]), + case Stack of + undefined -> + {M,F,Args} = MFArgs, + OldStack = [[{{M,F,length(Args)},TS}]], + put(Pid, trace_call_push(Table, Pid, suspend, TS, OldStack)), + ets:insert(Table, #proc{id = Pid, parent = Parent, + spawned_as = MFArgs}); + _ -> + throw({inconsistent_trace_data, ?MODULE, ?LINE, + [Pid, MFArgs, TS, Parent, Stack]}) + end. + + + +trace_exit(Table, Pid, TS) -> + Stack = erase(Pid), + ?dbg(0, "trace_exit(~p, ~p)~n~p~n", [Pid, TS, Stack]), + case Stack of + undefined -> + ok; + [] -> + ok; + [_ | _] = Stack -> + trace_return_to_int(Table, Pid, undefined, TS, Stack), + ok + end, + ok. + + + +trace_out(Table, Pid, Func, TS) -> + Stack = get_stack(Pid), + ?dbg(0, "trace_out(~p, ~p, ~p)~n~p~n", [Pid, Func, TS, Stack]), + case Stack of + [] -> + put(Pid, trace_call_push(Table, Pid, suspend, TS, + case Func of + undefined -> []; + _ -> + [[{Func,TS}]] + end)); + [[{suspend,_}] | _] -> + %% No stats update for a suspend on suspend + put(Pid, [[{suspend,TS}] | Stack]); + [_ | _] -> + put(Pid, trace_call_push(Table, Pid, suspend, TS, Stack)) + end. + + + +trace_in(Table, Pid, Func, TS) -> + Stack = get(Pid), + ?dbg(0, "trace_in(~p, ~p, ~p)~n~p~n", [Pid, Func, TS, Stack]), + case Stack of + undefined -> + %% First activity on a process which existed at the time + %% the fprof trace was started. + put(Pid, [[{Func,TS}]]); + [] -> + put(Pid, [[{Func,TS}]]); + [[{suspend, _}]] -> + put(Pid, trace_return_to_int(Table, Pid, undefined, TS, Stack)); + [[{suspend,_}] | [[{suspend,_}] | _]=NewStack] -> + %% No stats update for a suspend on suspend + put(Pid, NewStack); + [[{suspend, _}] | [[{Func1, _} | _] | _]] -> + %% This is a new process (suspend and Func1 was inserted + %% by trace_spawn) or any process that has just been + %% scheduled out and now back in. + put(Pid, trace_return_to_int(Table, Pid, Func1, TS, Stack)); + _ -> + throw({inconsistent_trace_data, ?MODULE, ?LINE, + [Pid, Func, TS, Stack]}) + end. + + + +trace_gc_start(Table, Pid, TS) -> + Stack = get_stack(Pid), + ?dbg(0, "trace_gc_start(~p, ~p)~n~p~n", [Pid, TS, Stack]), + put(Pid, trace_call_push(Table, Pid, garbage_collect, TS, Stack)). + + + +trace_gc_end(Table, Pid, TS) -> + Stack = get(Pid), + ?dbg(0, "trace_gc_end(~p, ~p)~n~p~n", [Pid, TS, Stack]), + case Stack of + undefined -> + put(Pid, []); + [] -> + ok; + [[{garbage_collect, _}]] -> + put(Pid, trace_return_to_int(Table, Pid, undefined, TS, Stack)); + [[{garbage_collect, _}], [{Func1, _} | _] | _] -> + put(Pid, trace_return_to_int(Table, Pid, Func1, TS, Stack)); + _ -> + throw({inconsistent_trace_data, ?MODULE, ?LINE, + [Pid, TS, Stack]}) + end. + + + +%%%----------------------------------------- +%%% Statistics calculating support functions +%%%----------------------------------------- + + + +get_stack(Id) -> + case get(Id) of + undefined -> + []; + Stack -> + Stack + end. + + + +mfarity({M, F, Args}) when is_list(Args) -> + {M, F, length(Args)}; +mfarity(MFA) -> + MFA. + + + +init_log(_Table, _Proc, suspend) -> + ok; +init_log(_Table, _Proc, void) -> + ok; +init_log(_Table, undefined, _Entry) -> + ok; +init_log(_Table, #proc{init_cnt = 0}, _Entry) -> + ok; +init_log(Table, #proc{init_cnt = N, init_log = L} = Proc, Entry) -> + ets:insert(Table, Proc#proc{init_cnt = N-1, init_log = [Entry | L]}); +init_log(Table, Id, Entry) -> + Proc = + case ets:lookup(Table, Id) of + [P] -> P; + [] -> undefined + end, + init_log(Table,Proc,Entry). + + +trace_clock(_Table, _Pid, _T, + [[{suspend, _}], [{suspend, _}] | _]=_Stack, _Clock) -> + ?dbg(9, "trace_clock(Table, ~w, ~w, ~w, ~w)~n", + [_Pid, _T, _Stack, _Clock]), + void; +trace_clock(Table, Pid, T, + [[{garbage_collect, TS0}], [{suspend, _}]], Clock) -> + trace_clock_1(Table, Pid, T, TS0, undefined, garbage_collect, Clock); +trace_clock(Table, Pid, T, + [[{garbage_collect, TS0}], [{suspend, _}], [{Func2, _} | _] | _], + Clock) -> + trace_clock_1(Table, Pid, T, TS0, Func2, garbage_collect, Clock); +trace_clock(Table, Pid, T, [[{Func0, TS0}, {Func1, _} | _] | _], Clock) -> + trace_clock_1(Table, Pid, T, TS0, Func1, Func0, Clock); +trace_clock(Table, Pid, T, [[{Func0, TS0}], [{Func1, _} | _] | _], Clock) -> + trace_clock_1(Table, Pid, T, TS0, Func1, Func0, Clock); +trace_clock(Table, Pid, T, [[{Func0, TS0}]], Clock) -> + trace_clock_1(Table, Pid, T, TS0, undefined, Func0, Clock); +trace_clock(_, _, _, [], _) -> + void. + +trace_clock_1(Table, Pid, _, _, Caller, suspend, #clocks.own) -> + clock_add(Table, {Pid, Caller, suspend}, #clocks.own, 0); +trace_clock_1(Table, Pid, T, TS, Caller, Func, Clock) -> + clock_add(Table, {Pid, Caller, Func}, Clock, + if is_integer(T) -> + T; + true -> + ts_sub(T, TS) + end). + +clock_add(Table, Id, Clock, T) -> + ?dbg(1, "clock_add(Table, ~w, ~w, ~w)~n", [Id, Clock, T]), + try ets:update_counter(Table, Id, {Clock, T}) + catch + error:badarg -> + ets:insert(Table, #clocks{id = Id}), + X = ets:update_counter(Table, Id, {Clock, T}), + if X >= 0 -> ok; + true -> ?dbg(0, "Negative counter value ~p ~p ~p ~p~n", + [X, Id, Clock, T]) + end, + X + end. + +clocks_add(Table, #clocks{id = Id} = Clocks) -> + ?dbg(1, "clocks_add(Table, ~w)~n", [Clocks]), + case ets:lookup(Table, Id) of + [Clocks0] -> + ets:insert(Table, clocks_sum(Clocks, Clocks0, Id)); + [] -> + ets:insert(Table, Clocks) + end. + + + +clocks_sum(#clocks{id = _Id1, + cnt = Cnt1, + own = Own1, + acc = Acc1}, + #clocks{id = _Id2, + cnt = Cnt2, + own = Own2, + acc = Acc2}, + Id) -> + #clocks{id = Id, + cnt = Cnt1 + Cnt2, + own = Own1 + Own2, + acc = Acc1 + Acc2}. + + + +ts_sub({A, B, C} = _T, {A0, B0, C0} = _T0) -> + X = ((((A-A0)*1000000) + (B-B0))*1000000) + C - C0, + if X >= 0 -> ok; + true -> ?dbg(9, "Negative counter value ~p ~p ~p~n", + [X, _T, _T0]) + end, + X; +ts_sub(_, _) -> + undefined. + + + +%%%-------------------------------- +%%% Profile data analysis functions +%%%-------------------------------- + + + +do_analyse(Table, Analyse) -> + ?dbg(5, "do_analyse_1(~p, ~p)~n", [Table, Analyse]), + Result = + try do_analyse_1(Table, Analyse) + catch + Error -> Error + end, + ?dbg(5, "do_analyse_1(_, _) ->~p~n", [Result]), + Result. + +do_analyse_1(Table, + #analyse{group_leader = GroupLeader, + dest = Io, + cols = Cols0, + callers = PrintCallers, + sort = Sort, + totals = PrintTotals, + details = PrintDetails} = _Analyse) -> + Waste = 11, + MinCols = Waste + 12, %% We need Width >= 1 + Cols = if Cols0 < MinCols -> MinCols; true -> Cols0 end, + Width = (Cols-Waste) div 12, + FnameWidth = Cols - Waste - 5*Width, + Dest = {Io, [FnameWidth, Width, 2*Width, 2*Width]}, + SortElement = case Sort of + own -> + #clocks.own; + acc -> + #clocks.acc + end, + %% + %% Clean out the process dictionary before the next step + %% + _Erase = erase(), + ?dbg(2, "erase() -> ~p~n", [_Erase]), + %% + %% Process the collected data and spread it to 3 places: + %% * Per {process, caller, func}. Stored in the process dictionary. + %% * Sum per process. Stored in an ets table. + %% * Extra info per process. Stored in another ets table. + %% + io:format(GroupLeader, "Processing data...~n", []), + PidTable = ets:new(?MODULE, [set, private, {keypos, #clocks.id}]), + ProcTable = ets:new(?MODULE, [set, private, {keypos, #proc.id}]), + ets_select_foreach( + Table, [{'_', [], ['$_']}], 100, + fun (#clocks{id = {Pid, Caller, Func}} = Clocks) -> + case PrintDetails of + true -> + funcstat_pd(Pid, Caller, Func, Clocks), + clocks_add(PidTable, Clocks#clocks{id = Pid}); + false -> + ok + end, + clocks_add(PidTable, Clocks#clocks{id = totals}), + case PrintTotals of + true -> + funcstat_pd(totals, Caller, Func, Clocks); + false -> + ok + end; + (#proc{} = Proc) -> + ets:insert(ProcTable, Proc); + (#misc{} = Misc) -> + ets:insert(ProcTable, Misc) + end), + ?dbg(3, "get() -> ~p~n", [get()]), + {FirstTS, LastTS, _TraceCnt} = + case {ets:lookup(ProcTable, first_ts), + ets:lookup(ProcTable, last_ts_n)} of + {[#misc{data = FTS}], [#misc{data = {LTS, TC}}]} + when FTS =/= undefined, LTS =/= undefined -> + {FTS, LTS, TC}; + _ -> + throw({error,empty_trace}) + end, + Totals0 = + case ets:lookup(PidTable, totals) of + [T0] -> + ets:delete(PidTable, totals), + T0; + _ -> + throw({error,empty_trace}) + end, + Totals = Totals0#clocks{acc = ts_sub(LastTS, FirstTS)}, + ?dbg(3, "Totals0 = ~p~n", [Totals0]), + ?dbg(3, "PidTable = ~p~n", [ets:tab2list(PidTable)]), + ?dbg(3, "ProcTable = ~p~n", [ets:tab2list(ProcTable)]), + ?dbg(4, "Totals = ~p~n", [Totals]), + %% + %% Reorganize the process dictionary by Pid. + %% + lists:foreach( + fun ({{Pid, _Func}, Funcstat}) -> + put(Pid, [Funcstat | case get(Pid) of + undefined -> []; + Other -> Other + end]) + end, + erase()), + ?dbg(4, "get() -> ~p~n", [get()]), + %% + %% Sort the processes + %% + PidSorted = + postsort_r( + lists:sort( + ets:select(PidTable, + [{'_', [], [[{element, #clocks.own, '$_'} | '$_']]}]))), + ?dbg(4, "PidSorted = ~p~n", [PidSorted]), + %% + %% Print the functions per process + %% + io:format(GroupLeader, "Creating output...~n", []), + println(Dest, "%% ", [], "Analysis results:", ""), + println(Dest, "{ ", analysis_options, ",", ""), + println(Dest, " [{", {callers, PrintCallers}, "},", ""), + println(Dest, " {", {sort, Sort}, "},", ""), + println(Dest, " {", {totals, PrintTotals}, "},", ""), + println(Dest, " {", {details, PrintDetails}, "}]}.", ""), + println(Dest), + lists:foreach( + fun ({#clocks{} = Clocks, ProcOrPid, FuncstatList}) -> + println(Dest, "% ", head, "", ""), + case ProcOrPid of + #proc{} -> + println(Dest, "[{ ", Clocks, "},", "%%"), + print_proc(Dest, ProcOrPid); + totals -> + println(Dest, "[{ ", Clocks, "}].", "%%%"); + _ when is_pid(ProcOrPid) -> + println(Dest, "[{ ", Clocks, "}].", "%%") + end, + println(Dest), + lists:foreach( + fun (#funcstat{callers_sum = CallersSum, +% called_sum = CalledSum, + callers = Callers, + called = Called}) -> + case {PrintCallers, Callers} of +% {true, []} -> +% ok; + {true, _} -> + print_callers(Dest, Callers), + println(Dest, " { ", CallersSum, "},", "%"), + print_called(Dest, Called), + println(Dest); + {false, _} -> + println(Dest, "{ ", CallersSum, "}.", "") + end, + ok + end, + %% Sort the functions within the process, + %% and the callers and called within the function. + funcstat_sort_r(FuncstatList, SortElement)), + println(Dest) + end, + %% Look up the processes in sorted order + lists:map( + fun (#clocks{id = Pid} = Clocks) -> + Proc = case ets:lookup(ProcTable, Pid) of + [] -> Pid; + [ProcX] -> ProcX + end, + FuncstatList = + case get(Pid) of + undefined -> + []; + FL -> + FL + end, + {Clocks, Proc, FuncstatList} + end, + case PrintDetails of + true -> + [Totals | PidSorted]; + false -> + [Totals] + end)), + %% + %% Cleanup + %% + ets:delete(PidTable), + ets:delete(ProcTable), + io:format(GroupLeader, "Done!~n", []), + ok. + + + +%%---------------------------- +%% Analysis printout functions +%%---------------------------- + + + +print_proc({undefined, _}, _) -> + ok; +print_proc(Dest, + #proc{id = _Pid, + parent = Parent, + spawned_as = SpawnedAs, + init_log = InitLog}) -> + case {Parent, SpawnedAs, InitLog} of + {undefined, undefined, []} -> + println(Dest, " ", [], "].", ""); + {_, undefined, []} -> + println(Dest, " { ", {spawned_by, parsify(Parent)}, "}].", ""); + _ -> + println(Dest, " { ", {spawned_by, parsify(Parent)}, "},", ""), + case {SpawnedAs, InitLog} of + {_, []} -> + println(Dest, " { ", + {spawned_as, SpawnedAs}, + "}].", ""); + {undefined, _} -> + println(Dest, " { ", + {initial_calls, lists:reverse(InitLog)}, + "}].", ""); + _ -> + println(Dest, " { ", + {spawned_as, SpawnedAs}, + "},", ""), + println(Dest, " { ", + {initial_calls, lists:reverse(InitLog)}, + "}].", "") + end + end. + + + +print_callers(Dest, []) -> + println(Dest, "{[", [], "],", ""); +print_callers(Dest, [Clocks]) -> + println(Dest, "{[{", Clocks, "}],", ""); +print_callers(Dest, [Clocks | Tail]) -> + println(Dest, "{[{", Clocks, "},", ""), + print_callers_1(Dest, Tail). + +print_callers_1(Dest, [Clocks]) -> + println(Dest, " {", Clocks, "}],", ""); +print_callers_1(Dest, [Clocks | Tail]) -> + println(Dest, " {", Clocks, "},", ""), + print_callers_1(Dest, Tail). + + + +print_func(Dest, Clocks) -> + println(Dest, " { ", Clocks, "},", "%"). + + + +print_called(Dest, []) -> + println(Dest, " [", [], "]}.", ""); +print_called(Dest, [Clocks]) -> + println(Dest, " [{", Clocks, "}]}.", ""); +print_called(Dest, [Clocks | Tail]) -> + println(Dest, " [{", Clocks, "},", ""), + print_called_1(Dest, Tail). + +print_called_1(Dest, [Clocks]) -> + println(Dest, " {", Clocks, "}]}.", ""); +print_called_1(Dest, [Clocks | Tail]) -> + println(Dest, " {", Clocks, "},", ""), + print_called_1(Dest, Tail). + + + +println({undefined, _}) -> + ok; +println({Io, _}) -> + io:nl(Io). + +println({undefined, _}, _Head, + _, + _Tail, _Comment) -> + ok; +println({Io, [W1, W2, W3, W4]}, Head, + #clocks{id = Pid, cnt = Cnt, acc = _, own = Own}, + Tail, Comment) when is_pid(Pid) -> + io:put_chars(Io, + [pad(Head, $ , 3), + flat_format(parsify(Pid), $,, W1), + flat_format(Cnt, $,, W2, right), + flat_format(undefined, $,, W3, right), + flat_format(Own*0.001, [], W4-1, right), + pad(Tail, $ , 4), + pad($ , Comment, 4), + io_lib:nl()]); +println({Io, [W1, W2, W3, W4]}, Head, + #clocks{id = {_M, _F, _A} = Func, cnt = Cnt, acc = Acc, own = Own}, + Tail, Comment) -> + io:put_chars(Io, + [pad(Head, $ , 3), + flat_format(Func, $,, W1), + flat_format(Cnt, $,, W2, right), + flat_format(Acc*0.001, $,, W3, right), + flat_format(Own*0.001, [], W4-1, right), + pad(Tail, $ , 4), + pad($ , Comment, 4), + io_lib:nl()]); +println({Io, [W1, W2, W3, W4]}, Head, + #clocks{id = Id, cnt = Cnt, acc = Acc, own = Own}, + Tail, Comment) -> + io:put_chars(Io, + [pad(Head, $ , 3), + flat_format(parsify(Id), $,, W1), + flat_format(Cnt, $,, W2, right), + flat_format(Acc*0.001, $,, W3, right), + flat_format(Own*0.001, [], W4-1, right), + pad(Tail, $ , 4), + pad($ , Comment, 4), + io_lib:nl()]); +println({Io, [W1, W2, W3, W4]}, Head, + head, + Tail, Comment) -> + io:put_chars(Io, + [pad(Head, $ , 3), + pad(" ", $ , W1), + pad($ , " CNT ", W2), + pad($ , " ACC ", W3), + pad($ , " OWN", W4-1), + pad(Tail, $ , 4), + pad($ , Comment, 4), + io_lib:nl()]); +println({Io, _}, Head, + [], + Tail, Comment) -> + io:format(Io, "~s~s~s~n", + [pad(Head, $ , 3), Tail, Comment]); +println({Io, _}, Head, + {Tag, Term}, + Tail, Comment) -> + io:format(Io, "~s~p, ~p~s~s~n", + [pad(Head, $ , 3), parsify(Tag), parsify(Term), Tail, Comment]); +println({Io, _}, Head, + Term, + Tail, Comment) -> + io:format(Io, "~s~p~s~s~n", + [pad(Head, $ , 3), parsify(Term), Tail, Comment]). + + + +%%%-------------------------- +%%% Sorting support functions +%%%-------------------------- + + +%% Add a Clocks record to the callers and called funcstat records +%% in the process dictionary. +%% +funcstat_pd(Pid, Func1, Func0, Clocks) -> + put({Pid, Func0}, + case get({Pid, Func0}) of + undefined -> + #funcstat{callers_sum = Clocks#clocks{id = Func0}, + called_sum = #clocks{id = Func0}, + callers = [Clocks#clocks{id = Func1}]}; + #funcstat{callers_sum = CallersSum, + callers = Callers} = FuncstatCallers -> + FuncstatCallers#funcstat{ + callers_sum = clocks_sum(CallersSum, Clocks, Func0), + callers = [Clocks#clocks{id = Func1} | Callers]} + end), + put({Pid, Func1}, + case get({Pid, Func1}) of + undefined -> + #funcstat{callers_sum = #clocks{id = Func1}, + called_sum = Clocks#clocks{id = Func1}, + called = [Clocks#clocks{id = Func0}]}; + #funcstat{called_sum = CalledSum, + called = Called} = FuncstatCalled -> + FuncstatCalled#funcstat{ + called_sum = clocks_sum(CalledSum, Clocks, Func1), + called = [Clocks#clocks{id = Func0} | Called]} + end). + + + +%% Sort a list of funcstat records, +%% and sort the callers and called lists within the funcstat record. +funcstat_sort_r(FuncstatList, Element) -> + funcstat_sort_r_1(FuncstatList, Element, []). + +funcstat_sort_r_1([], _, R) -> + postsort_r(lists:sort(R)); +funcstat_sort_r_1([#funcstat{callers_sum = #clocks{} = Clocks, + callers = Callers, + called = Called} = Funcstat + | L], + Element, + R) -> + funcstat_sort_r_1(L, + Element, + [[element(Element, Clocks) + |Funcstat#funcstat{ + callers = clocks_sort_r(Callers, Element), + called = clocks_sort_r(Called, Element)}] + | R]). + + + +%% Sort a list of clocks records. +clocks_sort_r(L, E) -> + clocks_sort_r_1(L, E, []). + +clocks_sort_r_1([], _, R) -> + postsort_r(lists:sort(R)); +clocks_sort_r_1([#clocks{} = C | L], E, R) -> + clocks_sort_r_1(L, E, [[element(E, C)|C] | R]). + + +%% Take a list of terms with sort headers and strip the headers. +postsort_r(L) -> + postsort_r(L, []). + +postsort_r([], R) -> + R; +postsort_r([[_|C] | L], R) -> + postsort_r(L, [C | R]). + + + +%%%---------------------------------------------------------------------- +%%% Fairly generic support functions +%%% + +%% Standard format and flatten. +flat_format(F, Trailer) when is_float(F) -> + lists:flatten([io_lib:format("~.3f", [F]), Trailer]); +flat_format(W, Trailer) -> + lists:flatten([io_lib:format("~p", [W]), Trailer]). + +%% Format, flatten, and pad. +flat_format(Term, Trailer, Width) -> + flat_format(Term, Trailer, Width, left). + +flat_format(Term, Trailer, Width, left) -> + flat_format(Term, Trailer, Width, {left, $ }); +flat_format(Term, Trailer, Width, {left, Filler}) -> + pad(flat_format(Term, Trailer), Filler, Width); +flat_format(Term, Trailer, Width, right) -> + flat_format(Term, Trailer, Width, {right, $ }); +flat_format(Term, Trailer, Width, {right, Filler}) -> + pad(Filler, flat_format(Term, Trailer), Width). + + + +%% Left pad a string using a given char. +pad(Char, L, Size) when is_integer(Char), is_list(L), is_integer(Size) -> + List = lists:flatten(L), + Length = length(List), + if Length >= Size -> + List; + true -> + lists:append(lists:duplicate(Size - Length, Char), List) + end; +%% Right pad a string using a given char. +pad(L, Char, Size) when is_list(L), is_integer(Char), is_integer(Size) -> + List = lists:flatten(L), + Length = length(List), + if Length >= Size -> + List; + true -> + lists:append(List, lists:duplicate(Size - Length, Char)) + end. + + + +ets_select_foreach(Table, MatchSpec, Limit, Fun) -> + ets:safe_fixtable(Table, true), + ets_select_foreach_1(ets:select(Table, MatchSpec, Limit), Fun). + +ets_select_foreach_1('$end_of_table', _) -> + ok; +ets_select_foreach_1({Matches, Continuation}, Fun) -> + ?dbg(2, "Matches = ~p~n", [Matches]), + lists:foreach(Fun, Matches), + ets_select_foreach_1(ets:select(Continuation), Fun). + + + +%% Converts the parts of a deep term that are not parasable when printed +%% with io:format() into their string representation. +parsify([]) -> + []; +parsify([Hd | Tl]) -> + [parsify(Hd) | parsify(Tl)]; +parsify({A, B}) -> + {parsify(A), parsify(B)}; +parsify({A, B, C}) -> + {parsify(A), parsify(B), parsify(C)}; +parsify(Tuple) when is_tuple(Tuple) -> + list_to_tuple(parsify(tuple_to_list(Tuple))); +parsify(Pid) when is_pid(Pid) -> + erlang:pid_to_list(Pid); +parsify(Port) when is_port(Port) -> + erlang:port_to_list(Port); +parsify(Ref) when is_reference(Ref) -> + erlang:ref_to_list(Ref); +parsify(Fun) when is_function(Fun) -> + erlang:fun_to_list(Fun); +parsify(Term) -> + Term. + + + +%% A simple loop construct. +%% +%% Calls 'Fun' with argument 'Start' first and then repeatedly with +%% its returned value (state) until 'Fun' returns 'Stop'. Then +%% the last state value that was not 'Stop' is returned. + +% iterate(Start, Done, Fun) when is_function(Fun) -> +% iterate(Start, Done, Fun, Start). + +% iterate(Done, Done, Fun, I) -> +% I; +% iterate(I, Done, Fun, _) -> +% iterate(Fun(I), Done, Fun, I). diff --git a/lib/tools/src/instrument.erl b/lib/tools/src/instrument.erl new file mode 100644 index 0000000000..fa8a4a4867 --- /dev/null +++ b/lib/tools/src/instrument.erl @@ -0,0 +1,427 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1998-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(instrument). + +-export([holes/1, mem_limits/1, memory_data/0, read_memory_data/1, + sort/1, store_memory_data/1, sum_blocks/1, + descr/1, type_descr/2, allocator_descr/2, class_descr/2, + type_no_range/1, block_header_size/1, store_memory_status/1, + read_memory_status/1, memory_status/1]). + + +-define(OLD_INFO_SIZE, 32). %% (sizeof(mem_link) in pre R9C utils.c) + +-define(IHMARKER(H), element(1, H)). +-define(VSN(H), element(2, H)). +-define(INFO_SIZE(H), element(3, H)). +-define(TYPEMAP(H), element(4, H)). + +-define(IHDR(H), is_tuple(H), ?IHMARKER(H) =:= instr_hdr). +-define(IHDRVSN(H, V), ?IHDR(H), ?VSN(H) =:= V). + +memory_data() -> + case catch erlang:system_info(allocated) of + {'EXIT',{Error,_}} -> + erlang:error(Error, []); + {'EXIT',Error} -> + erlang:error(Error, []); + Res -> + Res + end. + +store_memory_data(File) -> + case catch erlang:system_info({allocated, File}) of + {'EXIT',{Error,_}} -> + erlang:error(Error, [File]); + {'EXIT',Error} -> + erlang:error(Error, [File]); + Res -> + Res + end. + +memory_status(Type) when is_atom(Type) -> + case catch erlang:system_info({allocated, status, Type}) of + {'EXIT',{Error,_}} -> + erlang:error(Error, [Type]); + {'EXIT',Error} -> + erlang:error(Error, [Type]); + Res -> + Res + end; +memory_status(Type) -> + erlang:error(badarg, [Type]). + +store_memory_status(File) when is_list(File) -> + case catch erlang:system_info({allocated, status, File}) of + {'EXIT',{Error,_}} -> + erlang:error(Error, [File]); + {'EXIT',Error} -> + erlang:error(Error, [File]); + Res -> + Res + end; +store_memory_status(File) -> + erlang:error(badarg, [File]). + +read_memory_data(File) when is_list(File) -> + case file:consult(File) of + {ok, [Hdr|MD]} when ?IHDR(Hdr) -> + {Hdr, MD}; + {ok, [{T,A,S,undefined}|_] = MD} when is_integer(T), + is_integer(A), + is_integer(S) -> + {{instr_hdr, 1, ?OLD_INFO_SIZE}, MD}; + {ok, [{T,A,S,{X,Y,Z}}|_] = MD} when is_integer(T), + is_integer(A), + is_integer(S), + is_integer(X), + is_integer(Y), + is_integer(Z) -> + {{instr_hdr, 1, ?OLD_INFO_SIZE}, MD}; + {ok, _} -> + {error, eio}; + Error -> + Error + end; +read_memory_data(File) -> + erlang:error(badarg, [File]). + +read_memory_status(File) when is_list(File) -> + case file:consult(File) of + {ok, [{instr_vsn, _}|Stat]} -> + Stat; + {ok, _} -> + {error, eio}; + Error -> + Error + end; +read_memory_status(File) -> + erlang:error(badarg, [File]). + +holes({Hdr, MD}) when ?IHDR(Hdr) -> + check_holes(?INFO_SIZE(Hdr), MD). + +check_holes(_ISz, []) -> + ok; +check_holes(ISz, [E | L]) -> + check_holes(ISz, E, L). + +check_holes(_ISz, _E1, []) -> + io:format("~n"); +check_holes(ISz, E1, [E2 | Rest]) -> + check_hole(ISz, E1, E2), + check_holes(ISz, E2, Rest). + +check_hole(ISz, {_,P1,S1,_}, {_,P2,_,_}) -> + End = P1+S1, + Hole = P2 - (End + ISz), + if + Hole =< 7 -> + ok; + true -> + io:format(" ~p", [Hole]) + end. + +sum_blocks({Hdr, L}) when ?IHDR(Hdr) -> + lists:foldl(fun({_,_,S,_}, Sum) -> S+Sum end, + 0, + L). + +mem_limits({Hdr, L}) when ?IHDR(Hdr) -> + {_, P1, _, _} = hd(L), + {_, P2, S2, _} = lists:last(L), + {P1, P2+S2}. + +sort({Hdr, MD}) when ?IHDR(Hdr) -> + {Hdr, lists:keysort(2, MD)}. + +descr({Hdr, MD} = ID) when ?IHDR(Hdr) -> + {Hdr, lists:map(fun ({TN, Addr, Sz, {0, N, S}}) -> + {type_descr(ID, TN), + Addr, + Sz, + list_to_pid("<0." + ++ integer_to_list(N) + ++ "." + ++ integer_to_list(S) + ++ ">")}; + ({TN, Addr, Sz, undefined}) -> + {type_descr(ID, TN), + Addr, + Sz, + undefined} + end, + MD)}. + +block_header_size({Hdr, _}) when ?IHDR(Hdr) -> + ?INFO_SIZE(Hdr). + +type_descr({Hdr, _}, TypeNo) when ?IHDRVSN(Hdr, 2), + is_integer(TypeNo) -> + case catch element(1, element(TypeNo, ?TYPEMAP(Hdr))) of + {'EXIT', _} -> invalid_type; + Type -> Type + end; +type_descr({Hdr, _}, TypeNo) when ?IHDRVSN(Hdr, 1), + is_integer(TypeNo) -> + type_string(TypeNo). + + +allocator_descr({Hdr, _}, TypeNo) when ?IHDRVSN(Hdr, 2), is_integer(TypeNo) -> + case catch element(2, element(TypeNo, ?TYPEMAP(Hdr))) of + {'EXIT', _} -> invalid_type; + Type -> Type + end; +allocator_descr({Hdr, _}, TypeNo) when ?IHDRVSN(Hdr, 1), is_integer(TypeNo) -> + "unknown". + +class_descr({Hdr, _}, TypeNo) when ?IHDRVSN(Hdr, 2), is_integer(TypeNo) -> + case catch element(3, element(TypeNo, ?TYPEMAP(Hdr))) of + {'EXIT', _} -> invalid_type; + Type -> Type + end; +class_descr({Hdr, _}, TypeNo) when ?IHDRVSN(Hdr, 1), is_integer(TypeNo) -> + "unknown". + +type_no_range({Hdr, _}) when ?IHDRVSN(Hdr, 2) -> + {1, tuple_size(?TYPEMAP(Hdr))}; +type_no_range({Hdr, _}) when ?IHDRVSN(Hdr, 1) -> + {-1, 1000}. + +type_string(-1) -> + "unknown"; +type_string(1) -> + "atom text"; +type_string(11) -> + "atom desc"; +type_string(2) -> + "bignum (big_to_list)"; +type_string(31) -> + "fixalloc"; +type_string(32) -> + "unknown fixalloc block"; +type_string(33) -> + "message buffer"; +type_string(34) -> + "message link"; +type_string(4) -> + "estack"; +type_string(40) -> + "db table vec"; +type_string(41) -> + "db tree select buffer"; +type_string(43) -> + "db hash select buffer"; +type_string(44) -> + "db hash select list"; +type_string(45) -> + "db match prog stack"; +type_string(46) -> + "db match prog heap data"; +type_string(47) -> + "db temp buffer"; +type_string(48) -> + "db error"; +type_string(49) -> + "db error info"; +type_string(50) -> + "db trans tab"; +type_string(51) -> + "db segment"; +type_string(52) -> + "db term"; +type_string(53) -> + "db add_counter"; +type_string(54) -> + "db segment table"; +type_string(55) -> + "db table (fix)"; +type_string(56) -> + "db bindings"; +type_string(57) -> + "db counter"; +type_string(58) -> + "db trace vec"; +type_string(59) -> + "db fixed deletion"; +type_string(60) -> + "binary (external.c)"; +type_string(61) -> + "binary"; +type_string(62) -> + "procbin (fix)"; +type_string(70) -> + "driver alloc (io.c)"; +type_string(71) -> + "binary (io.c)"; +type_string(72) -> + "binary vec (io.c)"; +type_string(73) -> + "binary vec 2 (io.c)"; +type_string(74) -> + "io vec (io.c)"; +type_string(75) -> + "io vec 2 (io.c)"; +type_string(76) -> + "temp io buffer (io.c)"; +type_string(77) -> + "temp io buffer 2 (io.c)"; +type_string(78) -> + "line buffer (io.c)"; +type_string(8) -> + "heap"; +type_string(801) -> + "heap (1)"; +type_string(802) -> + "heap (2)"; +type_string(803) -> + "heap (3)"; +type_string(804) -> + "heap (4)"; +type_string(805) -> + "heap (5)"; +type_string(821) -> + "heap fragment (1)"; +type_string(822) -> + "heap fragment (2)"; +type_string(830) -> + "sequential store buffer (for vectors)"; +type_string(91) -> + "process table"; +type_string(92) -> + "process desc"; +type_string(110) -> + "hash buckets"; +type_string(111) -> + "hash table"; +type_string(120) -> + "index init"; +type_string(121) -> + "index table"; +type_string(130) -> + "temp buffer"; +type_string(140) -> + "timer wheel"; +type_string(150) -> + "distribution cache"; +type_string(151) -> + "dmem"; +type_string(152) -> + "distribution table"; +type_string(153) -> + "distribution table buckets"; +type_string(154) -> + "distribution table entry"; +type_string(155) -> + "node table"; +type_string(156) -> + "node table buckets"; +type_string(157) -> + "node table entry"; +type_string(160) -> + "port table"; +type_string(161) -> + "driver entry"; +type_string(162) -> + "port setup"; +type_string(163) -> + "port wait"; +type_string(170) -> + "module"; +type_string(171) -> + "fundef"; +type_string(180) -> + "file table"; +type_string(181) -> + "driver table"; +type_string(182) -> + "poll struct"; +type_string(190) -> + "inet driver"; +type_string(200) -> + "efile driver"; +type_string(210) -> + "gc root set"; +type_string(220) -> + "breakpoint data"; +type_string(230) -> + "async queue"; +type_string(231) -> + "async (exit)"; +type_string(232) -> + "async (driver)"; +type_string(240) -> + "bits buffer"; +type_string(241) -> + "bits temp buffer"; +type_string(250) -> + "modules (loader)"; +type_string(251) -> + "code (loader)"; +type_string(252) -> + "atom tab (loader)"; +type_string(253) -> + "import tab (loader)"; +type_string(254) -> + "export tab (loader)"; +type_string(255) -> + "lable tab (loader)"; +type_string(256) -> + "gen op (loader)"; +type_string(257) -> + "gen op args (loader)"; +type_string(258) -> + "gen op args 2 (loader)"; +type_string(259) -> + "gen op args 3 (loader)"; +type_string(260) -> + "lambdas (loader)"; +type_string(261) -> + "temp int buffer (loader)"; +type_string(262) -> + "temp heap (loader)"; +type_string(280) -> + "dist ctrl msg buffer"; +type_string(281) -> + "dist_buf"; +type_string(290) -> + "call trace buffer"; +type_string(300) -> + "bif timer rec"; +type_string(310) -> + "argument registers"; +type_string(320) -> + "compressed binary temp buffer"; +type_string(330) -> + "term_to_binary temp buffer"; +type_string(340) -> + "proc dict"; +type_string(350) -> + "trace to port temp buffer"; +type_string(360) -> + "lists subtract temp buffer"; +type_string(370) -> + "link (lh)"; +type_string(380) -> + "port call buffer"; +type_string(400) -> + "definite_alloc block"; +type_string(_) -> + invalid_type. + diff --git a/lib/tools/src/make.erl b/lib/tools/src/make.erl new file mode 100644 index 0000000000..77c354651b --- /dev/null +++ b/lib/tools/src/make.erl @@ -0,0 +1,324 @@ +%% +%% %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% +%% +%% Purpose : Basic make facility + +%% Compares date stamps of .erl and Object files - recompiles when +%% necessary. +%% Files to be checked are contained in a file 'Emakefile' +%% If Emakefile is missing the current directory is used. +-module(make). + +-export([all/0,all/1,files/1,files/2]). + +-include_lib("kernel/include/file.hrl"). + +-define(MakeOpts,[noexec,load,netload,noload]). + +all() -> + all([]). + +all(Options) -> + {MakeOpts,CompileOpts} = sort_options(Options,[],[]), + case read_emakefile('Emakefile',CompileOpts) of + Files when is_list(Files) -> + do_make_files(Files,MakeOpts); + error -> + error + end. + +files(Fs) -> + files(Fs, []). + +files(Fs0, Options) -> + Fs = [filename:rootname(F,".erl") || F <- Fs0], + {MakeOpts,CompileOpts} = sort_options(Options,[],[]), + case get_opts_from_emakefile(Fs,'Emakefile',CompileOpts) of + Files when is_list(Files) -> + do_make_files(Files,MakeOpts); + error -> error + end. + +do_make_files(Fs, Opts) -> + process(Fs, lists:member(noexec, Opts), load_opt(Opts)). + + +sort_options([H|T],Make,Comp) -> + case lists:member(H,?MakeOpts) of + true -> + sort_options(T,[H|Make],Comp); + false -> + sort_options(T,Make,[H|Comp]) + end; +sort_options([],Make,Comp) -> + {Make,lists:reverse(Comp)}. + +%%% Reads the given Emakefile and returns a list of tuples: {Mods,Opts} +%%% Mods is a list of module names (strings) +%%% Opts is a list of options to be used when compiling Mods +%%% +%%% Emakefile can contain elements like this: +%%% Mod. +%%% {Mod,Opts}. +%%% Mod is a module name which might include '*' as wildcard +%%% or a list of such module names +%%% +%%% These elements are converted to [{ModList,OptList},...] +%%% ModList is a list of modulenames (strings) +read_emakefile(Emakefile,Opts) -> + case file:consult(Emakefile) of + {ok,Emake} -> + transform(Emake,Opts,[],[]); + {error,enoent} -> + %% No Emakefile found - return all modules in current + %% directory and the options given at command line + Mods = [filename:rootname(F) || F <- filelib:wildcard("*.erl")], + [{Mods, Opts}]; + {error,Other} -> + io:format("make: Trouble reading 'Emakefile':~n~p~n",[Other]), + error + end. + +transform([{Mod,ModOpts}|Emake],Opts,Files,Already) -> + case expand(Mod,Already) of + [] -> + transform(Emake,Opts,Files,Already); + Mods -> + transform(Emake,Opts,[{Mods,ModOpts++Opts}|Files],Mods++Already) + end; +transform([Mod|Emake],Opts,Files,Already) -> + case expand(Mod,Already) of + [] -> + transform(Emake,Opts,Files,Already); + Mods -> + transform(Emake,Opts,[{Mods,Opts}|Files],Mods++Already) + end; +transform([],_Opts,Files,_Already) -> + lists:reverse(Files). + +expand(Mod,Already) when is_atom(Mod) -> + expand(atom_to_list(Mod),Already); +expand(Mods,Already) when is_list(Mods), not is_integer(hd(Mods)) -> + lists:concat([expand(Mod,Already) || Mod <- Mods]); +expand(Mod,Already) -> + case lists:member($*,Mod) of + true -> + Fun = fun(F,Acc) -> + M = filename:rootname(F), + case lists:member(M,Already) of + true -> Acc; + false -> [M|Acc] + end + end, + lists:foldl(Fun, [], filelib:wildcard(Mod++".erl")); + false -> + Mod2 = filename:rootname(Mod, ".erl"), + case lists:member(Mod2,Already) of + true -> []; + false -> [Mod2] + end + end. + +%%% Reads the given Emakefile to see if there are any specific compile +%%% options given for the modules. +get_opts_from_emakefile(Mods,Emakefile,Opts) -> + case file:consult(Emakefile) of + {ok,Emake} -> + Modsandopts = transform(Emake,Opts,[],[]), + ModStrings = [coerce_2_list(M) || M <- Mods], + get_opts_from_emakefile2(Modsandopts,ModStrings,Opts,[]); + {error,enoent} -> + [{Mods, Opts}]; + {error,Other} -> + io:format("make: Trouble reading 'Emakefile':~n~p~n",[Other]), + error + end. + +get_opts_from_emakefile2([{MakefileMods,O}|Rest],Mods,Opts,Result) -> + case members(Mods,MakefileMods,[],Mods) of + {[],_} -> + get_opts_from_emakefile2(Rest,Mods,Opts,Result); + {I,RestOfMods} -> + get_opts_from_emakefile2(Rest,RestOfMods,Opts,[{I,O}|Result]) + end; +get_opts_from_emakefile2([],[],_Opts,Result) -> + Result; +get_opts_from_emakefile2([],RestOfMods,Opts,Result) -> + [{RestOfMods,Opts}|Result]. + +members([H|T],MakefileMods,I,Rest) -> + case lists:member(H,MakefileMods) of + true -> + members(T,MakefileMods,[H|I],lists:delete(H,Rest)); + false -> + members(T,MakefileMods,I,Rest) + end; +members([],_MakefileMods,I,Rest) -> + {I,Rest}. + + +%% Any flags that are not recognixed as make flags are passed directly +%% to the compiler. +%% So for example make:all([load,debug_info]) will make everything +%% with the debug_info flag and load it. + +load_opt(Opts) -> + case lists:member(netload,Opts) of + true -> + netload; + false -> + case lists:member(load,Opts) of + true -> + load; + _ -> + noload + end + end. + + +process([{[],_Opts}|Rest], NoExec, Load) -> + process(Rest, NoExec, Load); +process([{[H|T],Opts}|Rest], NoExec, Load) -> + case recompilep(coerce_2_list(H), NoExec, Load, Opts) of + error -> + error; + _ -> + process([{T,Opts}|Rest], NoExec, Load) + end; +process([], _NoExec, _Load) -> + up_to_date. + +recompilep(File, NoExec, Load, Opts) -> + ObjName = lists:append(filename:basename(File), + code:objfile_extension()), + ObjFile = case lists:keysearch(outdir,1,Opts) of + {value,{outdir,OutDir}} -> + filename:join(coerce_2_list(OutDir),ObjName); + false -> + ObjName + end, + case exists(ObjFile) of + true -> + recompilep1(File, NoExec, Load, Opts, ObjFile); + false -> + recompile(File, NoExec, Load, Opts) + end. + +recompilep1(File, NoExec, Load, Opts, ObjFile) -> + {ok, Erl} = file:read_file_info(lists:append(File, ".erl")), + {ok, Obj} = file:read_file_info(ObjFile), + case {readable(Erl), writable(Obj)} of + {true, true} -> + recompilep1(Erl, Obj, File, NoExec, Load, Opts); + _ -> + error + end. + +recompilep1(#file_info{mtime=Te}, + #file_info{mtime=To}, File, NoExec, Load, Opts) when Te>To -> + recompile(File, NoExec, Load, Opts); +recompilep1(_Erl, #file_info{mtime=To}, File, NoExec, Load, Opts) -> + recompile2(To, File, NoExec, Load, Opts). + +%% recompile2(ObjMTime, File, NoExec, Load, Opts) +%% Check if file is of a later date than include files. +recompile2(ObjMTime, File, NoExec, Load, Opts) -> + IncludePath = include_opt(Opts), + case check_includes(lists:append(File, ".erl"), IncludePath, ObjMTime) of + true -> + recompile(File, NoExec, Load, Opts); + false -> + false + end. + +include_opt([{i,Path}|Rest]) -> + [Path|include_opt(Rest)]; +include_opt([_First|Rest]) -> + include_opt(Rest); +include_opt([]) -> + []. + +%% recompile(File, NoExec, Load, Opts) +%% Actually recompile and load the file, depending on the flags. +%% Where load can be netload | load | noload + +recompile(File, true, _Load, _Opts) -> + io:format("Out of date: ~s\n",[File]); +recompile(File, false, noload, Opts) -> + io:format("Recompile: ~s\n",[File]), + compile:file(File, [report_errors, report_warnings, error_summary |Opts]); +recompile(File, false, load, Opts) -> + io:format("Recompile: ~s\n",[File]), + c:c(File, Opts); +recompile(File, false, netload, Opts) -> + io:format("Recompile: ~s\n",[File]), + c:nc(File, Opts). + +exists(File) -> + case file:read_file_info(File) of + {ok, _} -> + true; + _ -> + false + end. + +readable(#file_info{access=read_write}) -> true; +readable(#file_info{access=read}) -> true; +readable(_) -> false. + +writable(#file_info{access=read_write}) -> true; +writable(#file_info{access=write}) -> true; +writable(_) -> false. + +coerce_2_list(X) when is_atom(X) -> + atom_to_list(X); +coerce_2_list(X) -> + X. + +%%% If you an include file is found with a modification +%%% time larger than the modification time of the object +%%% file, return true. Otherwise return false. +check_includes(File, IncludePath, ObjMTime) -> + Path = [filename:dirname(File)|IncludePath], + case epp:open(File, Path, []) of + {ok, Epp} -> + check_includes2(Epp, File, ObjMTime); + _Error -> + false + end. + +check_includes2(Epp, File, ObjMTime) -> + case epp:parse_erl_form(Epp) of + {ok, {attribute, 1, file, {File, 1}}} -> + check_includes2(Epp, File, ObjMTime); + {ok, {attribute, 1, file, {IncFile, 1}}} -> + case file:read_file_info(IncFile) of + {ok, #file_info{mtime=MTime}} when MTime>ObjMTime -> + epp:close(Epp), + true; + _ -> + check_includes2(Epp, File, ObjMTime) + end; + {ok, _} -> + check_includes2(Epp, File, ObjMTime); + {eof, _} -> + epp:close(Epp), + false; + {error, _Error} -> + check_includes2(Epp, File, ObjMTime) + end. diff --git a/lib/tools/src/tags.erl b/lib/tools/src/tags.erl new file mode 100644 index 0000000000..e740d38c91 --- /dev/null +++ b/lib/tools/src/tags.erl @@ -0,0 +1,344 @@ +%% +%% %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% +%% +%%%---------------------------------------------------------------------- +%%% File : tags.erl +%%% Author : Anders Lindgren +%%% Purpose : Generate an Emacs TAGS file from programs written in Erlang. +%%% Date : 1998-03-16 +%%% Version : 1.1 +%%%---------------------------------------------------------------------- + +-module(tags). + +-export([file/1, file/2, files/1, files/2, dir/1, dir/2, + dirs/1, dirs/2, subdir/1, subdir/2, subdirs/1, subdirs/2, + root/0, root/1]). + + +%% `Tags' is a part of the editor Emacs. It is used for warp-speed +%% jumps between different source files in a project. When Using +%% `Tags', a function in any source file can be found by few a simple +%% keystrokes, just press M-. (in normal terms: Press Escape and dot). +%% +%% In order to work, the `Tags' system needs a list of all functions +%% in all source files in the project. This list is denoted the "TAGS +%% file". This purpose of this module is to create the TAGS file for +%% programs written in Erlang. +%% +%% In addition to functions, both records and macros (`define's) are +%% added to the TAGS file. + + +%% Usage: +%% root([Options]) -- Create a TAGS file covering all files in +%% the Erlang distribution. +%% +%% file(File [, Options]) -- Create a TAGS file for the file `File'. +%% files(FileList [, Options]) +%% -- Dito for all files in `FileList'. +%% +%% dir(Dir [, Options]) -- Create a TAGS file for all files in `Dir'. +%% dirs(DirList [, Options]) -- Dito for all files in all +%% directories in `DirList'. +%% +%% subdir(Dir [, Options]) -- Descend recursively down `Dir' and create +%% a TAGS file convering all files found. +%% subdirs(DirList [, Options]) +%% -- Dito, for all directories in `DirList'. +%% +%% The default is to create a file named "TAGS" in the current directory. +%% +%% Options is a list of tuples, where the following tuples are +%% recognised: +%% {outfile, NameOfTAGSFile} +%% {outdir, NameOfDirectory} +%% +%% Note, should both `outfile' and `outdir' options be given, `outfile' +%% take precedence. + + +%%% External interface + +root() -> root([]). +root(Options) -> subdir(code:root_dir(), Options). + +dir(Dir) -> dir(Dir, []). +dir(Dir, Options) -> dirs([Dir], Options). + +dirs(Dirs) -> dirs(Dirs, []). +dirs(Dirs, Options) -> + files(collect_dirs(Dirs, false), Options). + +subdir(Dir) -> subdir(Dir, []). +subdir(Dir, Options) -> subdirs([Dir], Options). + +subdirs(Dirs) -> subdirs(Dirs, []). +subdirs(Dirs, Options) -> + files(collect_dirs(Dirs, true), Options). + +file(Name) -> file(Name, []). +file(Name, Options) -> files([Name], Options). + +files(Files) -> files(Files, []). +files(Files, Options) -> + case open_out(Options) of + {ok, Os} -> + files_loop(Files, Os), + close_out(Os), + ok; + _ -> + error + end. + + + +%%% Internal functions. + +%% Find all files in a directory list. Should the second argument be +%% the atom `true' the functions will descend into subdirectories. +collect_dirs(Dirs, Recursive) -> + collect_dirs(Dirs, Recursive, []). + +collect_dirs([], _Recursive, Acc) -> Acc; +collect_dirs([Dir | Dirs], Recursive, Acc) -> + NewAcc = case file:list_dir(Dir) of + {ok, Entries} -> + collect_files(Dir, Entries, Recursive, Acc); + _ -> + Acc + end, + collect_dirs(Dirs, Recursive, NewAcc). + +collect_files(_Dir,[],_Recursive, Acc) -> Acc; +collect_files(Dir, [File | Files], Recursive, Acc) -> + FullFile = filename:join(Dir, File), + NewAcc = case filelib:is_dir(FullFile) of + true when Recursive -> + collect_dirs([FullFile], Recursive, Acc); + true -> + Acc; + false -> + case filelib:is_regular(FullFile) of + true -> + case filename:extension(File) of + ".erl" -> + [FullFile | Acc]; + ".hrl" -> + [FullFile | Acc]; + _ -> + Acc + end; + false -> + Acc + end + end, + collect_files(Dir, Files, Recursive, NewAcc). + + +files_loop([],_Os) -> true; +files_loop([F | Fs], Os) -> + case filename(F, Os) of + ok -> + ok; + error -> + %% io:format("Could not open ~s~n", [F]), + error + end, + files_loop(Fs, Os). + + +%% Generate tags for one file. +filename(Name, Os) -> + case file:open(Name, [read]) of + {ok, Desc} -> + Acc = module(Desc, [], [], {1, 0}), + file:close(Desc), + genout(Os, Name, Acc), + ok; + _ -> + error + end. + + +module(In, Last, Acc, {LineNo, CharNo}) -> + case io:get_line(In, []) of + eof -> + Acc; + Line -> + {NewLast, NewAcc} = line(Line, Last, Acc, {LineNo, CharNo}), + module(In, NewLast, NewAcc, {LineNo+1, CharNo+length(Line)}) + end. + + +%% Handle one line. Return the last added function name. +line([], Last, Acc, _) -> {Last, Acc}; +line(Line, _, Acc, Nos) when hd(Line) =:= $- -> + case attribute(Line, Nos) of + false -> {[], Acc}; + New -> {[], [New | Acc]} + end; +line(Line, Last, Acc, Nos) -> + %% to be OR not to be? + case case {hd(Line), word_char(hd(Line))} of + {$', _} -> true; + {_, true} -> true; + _ -> false + end of + true -> + case func(Line, Last, Nos) of + false -> + {Last, Acc}; + {NewLast, NewEntry} -> + {NewLast, [NewEntry | Acc]} + end; + false -> + {Last, Acc} + end. + +%% Handle one function. Will only add the first clause. (i.e. +%% if the function name doesn't match `Last'). +%% Return `false' or {NewLast, GeneratedLine}. +func(Line, Last, Nos) -> + {Name, Line1} = word(Line), + case Name of + [] -> false; + Last -> false; + _ -> + {Space, Line2} = white(Line1), + case Line2 of + [$( | _] -> + {Name, pfnote([$(, Space, Name], Nos)}; + _ -> + false + end + end. + + +%% Return `false' or generated line. +attribute([$- | Line], Nos) -> + {Attr, Line1} = word(Line), + case case Attr of + "drocer" -> true; + "enifed" -> true; + _ -> false + end of + false -> + false; + true -> + {Space2, Line2} = white(Line1), + case Line2 of + [$( | Line3] -> + {Space4, Line4} = white(Line3), + {Name,_Line5} = word(Line4), + case Name of + [] -> false; + _ -> + pfnote([Name, Space4, $(, Space2, Attr, $-], Nos) + end; + _ -> + false + end + end. + + +%% Removes whitespace from the head of the line. +%% Returns {ReveredSpace, Rest} +white(Line) -> white(Line, []). + +white([], Acc) -> {Acc, []}; +white([32 | Rest], Acc) -> white(Rest, [32 | Acc]); +white([9 | Rest], Acc) -> white(Rest, [9 | Acc]); +white(Line, Acc) -> {Acc, Line}. + + +%% Returns {ReversedWord, Rest} +word([$' | Rest]) -> + quoted(Rest, [$']); +word(Line) -> + unquoted(Line, []). + +quoted([$' | Rest], Acc) -> {[$' | Acc], Rest}; +quoted([$\\ , C | Rest], Acc) -> + quoted(Rest, [C, $\\ | Acc]); +quoted([C | Rest], Acc) -> + quoted(Rest, [C | Acc]). + +unquoted([], Word) -> {Word, []}; +unquoted([C | Cs], Acc) -> + case word_char(C) of + true -> unquoted(Cs, [C | Acc]); + false -> {Acc, [C | Cs]} + end. + +word_char(C) when C >= $a, C =< $z -> true; +word_char(C) when C >= $A, C =< $Z -> true; +word_char(C) when C >= $0, C =< $9 -> true; +word_char($_) -> true; +word_char(_) -> false. + + +%%% Output routines + +%% Check the options `outfile' and `outdir'. +open_out(Options) -> + case lists:keysearch(outfile, 1, Options) of + {value, {outfile, File}} -> + file:open(File, [write]); + _ -> + case lists:keysearch(outdir, 1, Options) of + {value, {outdir, Dir}} -> + file:open(filename:join(Dir, "TAGS"), [write]); + _ -> + file:open("TAGS", [write]) + end + end. + + +close_out(Os) -> + file:close(Os). + + +pfnote(Str, {LineNo, CharNo}) -> + io_lib:format("~s\177~w,~w~n", [flatrev(Str), LineNo, CharNo]). + + +genout(Os, Name, Entries) -> + io:format(Os, "\^l~n~s,~w~n", [Name, reclength(Entries)]), + io:put_chars(Os, lists:reverse(Entries)). + + + +%%% help routines + +%% Flatten and reverse a nested list. +flatrev(Ls) -> flatrev(Ls, []). + +flatrev([C | Ls], Acc) when is_integer(C) -> flatrev(Ls, [C | Acc]); +flatrev([L | Ls], Acc) -> flatrev(Ls, flatrev(L, Acc)); +flatrev([], Acc) -> Acc. + + +%% Count the number of elements in a nested list. +reclength([L | Ls]) when is_list(L) -> + reclength(L) + reclength(Ls); +reclength([_ | Ls]) -> + reclength(Ls) + 1; +reclength([]) -> 0. + +%%% tags.erl ends here. diff --git a/lib/tools/src/tools.app.src b/lib/tools/src/tools.app.src new file mode 100644 index 0000000000..cd9b622f15 --- /dev/null +++ b/lib/tools/src/tools.app.src @@ -0,0 +1,60 @@ +%% +%% %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% +%% +{application, tools, + [{description, "DEVTOOLS CXC 138 16"}, + {vsn, "%VSN%"}, + {modules, [cover, + cover_web, + eprof, + fprof, + instrument, + make, + xref, + xref_base, + xref_compiler, + xref_parser, + xref_reader, + xref_scanner, + xref_utils + ] + }, + {registered,[webcover_server]}, + {applications, [kernel, stdlib]}, + {env, [{file_util_search_methods,[{"", ""}, {"ebin", "esrc"}, {"ebin", "src"}]} + ] + } + ] +}. + + + + + + + + + + + + + + + + + diff --git a/lib/tools/src/tools.appup.src b/lib/tools/src/tools.appup.src new file mode 100644 index 0000000000..8de1ec76c9 --- /dev/null +++ b/lib/tools/src/tools.appup.src @@ -0,0 +1,19 @@ +# +# %CopyrightBegin% +# +# Copyright Ericsson AB 2001-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% +# +{"%VSN%",[],[]}. diff --git a/lib/tools/src/xref.erl b/lib/tools/src/xref.erl new file mode 100644 index 0000000000..0693bec019 --- /dev/null +++ b/lib/tools/src/xref.erl @@ -0,0 +1,607 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2000-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(xref). + +-behaviour(gen_server). + +%% External exports +-export([start/1, start/2, stop/1]). + +-export([m/1, d/1, + add_release/2, add_release/3, + add_application/2, add_application/3, + add_module/2, add_module/3, + add_directory/2, add_directory/3, + replace_module/3, replace_module/4, + replace_application/3, replace_application/4, + remove_module/2, remove_application/2, remove_release/2, + get_library_path/1, set_library_path/2, set_library_path/3, + q/2, q/3, info/1, info/2, info/3, + update/1, update/2, + forget/1, forget/2, variables/1, variables/2, + analyze/2, analyze/3, analyse/2, analyse/3, + get_default/1, get_default/2, + set_default/2, set_default/3]). + +-export([format_error/1]). + +%% gen_server callbacks +-export([init/1, handle_call/3, handle_cast/2, handle_info/2, + terminate/2, code_change/3]). + +-import(lists, [keydelete/3, keysearch/3]). + +-import(sofs, [to_external/1, is_sofs_set/1]). + +%%%---------------------------------------------------------------------- +%%% API +%%%---------------------------------------------------------------------- + +%% add_release(Servername, Directory) -> +%% {ok, ReleaseName} | Error +%% add_release(Servername, Directory, Options) -> +%% {ok, ReleaseName} | Error +%% add_application(Servername, Directory) -> +%% {ok, AppName} | Error +%% add_application(Servername, Directory, Options) -> +%% {ok, AppName} | Error +%% add_module(ServerName, Filename) -> +%% {ok, ModuleName} | Error +%% add_module(ServerName, Filename, Options) -> +%% {ok, ModuleName} | Error +%% add_directory(ServerName, Directory) -> +%% {ok, [ModuleName]} | Error +%% add_directory(ServerName, Directory, Options) -> +%% {ok, [ModuleName]} | Error +%% replace_module(ServerName, Module, Filename) -> +%% {ok, Module} | Error +%% replace_module(ServerName, Module, Filename, Options) -> +%% {ok, Module} | Error +%% replace_application(ServerName, Application, Directory) -> +%% {ok, AppName} | Error +%% replace_application(ServerName, Application, Directory, Options) -> +%% {ok, AppName} | Error +%% remove_module(ServerName, Module) -> ok | Error +%% remove_application(ServerName, Application) -> ok | Error +%% remove_release(ServerName, Release) -> ok | Error +%% get_library_path(Servername) -> {ok, Path} +%% set_library_path(Servername, Path) -> ok | Error +%% set_library_path(Servername, Path, Options) -> ok | Error +%% info(Servername) -> InfoList +%% info(Servername, What) -> [{what(), InfoList}] | Error +%% info(Servername, What, Qual) -> [{what(), InfoList}] | Error +%% update(Servername) -> {ok, [Module]} | Error +%% update(Servername, Options) -> {ok, [Module]} | Error +%% forget(Servername) -> ok +%% forget(Servername, VariableName) -> ok | Error +%% variables(Servername) -> {ok, [{VarType, [VariableName]}]} | Error +%% variables(Servername, [VarType]) -> {ok, [{VarType, [VariableName]}]} +%% analyze(ServerName, What) -> {ok, Answer} | Error +%% analyze(ServerName, What, Options) -> {ok, Answer} | Error +%% q(Servername, Query) -> {ok, Answer} | Error +%% q(Servername, Query, Options) -> {ok, Answer} | Error +%% get_default(ServerName, Option) -> {ok, Value} | Error +%% set_default(ServerName, Option, Value) -> {ok, OldValue} | Error +%% get_default(ServerName) -> [{Option, Value}] +%% set_default(ServerName, [{Option, Value}]) -> ok | Error +%% format_error(Error) -> io_string() +%% m(Module) -> [Result] | Error +%% m(File) -> [Result] | Error +%% d(Directory) -> [Result] | Error + +%% -> [Faulty] | Error; Faulty = {undefined, Calls} | {unused, Funs} +%% No user variables have been assigned digraphs, so there is no +%% need to call xref_base:delete/1. +m(Module) when is_atom(Module) -> + case xref_utils:find_beam(Module) of + {ok, File} -> + Fun = fun(S) -> + xref_base:add_module(S, File, {builtins,true}) + end, + case catch do_functions_analysis(Fun) of + {error, _, {no_debug_info, _}} -> + catch do_modules_analysis(Fun); + Result -> + Result + end; + Error -> Error + end; +m(File) -> + case xref_utils:split_filename(File, ".beam") of + false -> + {error, xref_base, {invalid_filename, File}}; + {Dir, BaseName} -> + BeamFile = filename:join(Dir, BaseName), + Fun = fun(S) -> + xref_base:add_module(S, BeamFile, {builtins, true}) + end, + case catch do_functions_analysis(Fun) of + {error, _, {no_debug_info, _}} -> + catch do_modules_analysis(Fun); + Result -> + Result + end + end. + +%% -> [Faulty] | Error; Faulty = {undefined, Calls} | {unused, Funs} +d(Directory) -> + Fun = fun(S) -> + xref_base:add_directory(S, Directory, {builtins, true}) + end, + Fun1 = fun(S) -> + case Fun(S) of + {ok, [], _S} -> + no_modules; + Reply -> + Reply + end + end, + case catch do_functions_analysis(Fun1) of + no_modules -> + catch do_modules_analysis(Fun); + Result -> + Result + end. + +start(Name) when is_atom(Name) -> + start(Name, []); +start(Opts0) when is_list(Opts0) -> + {Args, Opts} = split_args(Opts0), + gen_server:start(xref, Args, Opts). + +start(Name, Opts0) when is_list(Opts0) -> + {Args, Opts} = split_args(Opts0), + gen_server:start({local, Name}, xref, Args, Opts); +start(Name, Opt) -> + start(Name, [Opt]). + +split_args(Opts) -> + case keysearch(xref_mode, 1, Opts) of + {value, Mode} -> + {[Mode], keydelete(xref_mode, 1, Opts)}; + false -> + {[], Opts} + end. + +stop(Name) -> + gen_server:call(Name, stop, infinity). + +add_release(Name, Dir) -> + gen_server:call(Name, {add_release, Dir}, infinity). + +add_release(Name, Dir, Options) -> + gen_server:call(Name, {add_release, Dir, Options}, infinity). + +add_application(Name, Dir) -> + gen_server:call(Name, {add_application, Dir}, infinity). + +add_application(Name, Dir, Options) -> + gen_server:call(Name, {add_application, Dir, Options}, infinity). + +add_module(Name, File) -> + gen_server:call(Name, {add_module, File}, infinity). + +add_module(Name, File, Options) -> + gen_server:call(Name, {add_module, File, Options}, infinity). + +add_directory(Name, Dir) -> + gen_server:call(Name, {add_directory, Dir}, infinity). + +add_directory(Name, Dir, Options) -> + gen_server:call(Name, {add_directory, Dir, Options}, infinity). + +replace_module(Name, Module, File) -> + gen_server:call(Name, {replace_module, Module, File}, infinity). + +replace_module(Name, Module, File, Options) -> + gen_server:call(Name, {replace_module, Module, File, Options}, infinity). + +replace_application(Name, App, Dir) -> + gen_server:call(Name, {replace_application, App, Dir}, infinity). + +replace_application(Name, App, Dir, Options) -> + gen_server:call(Name, {replace_application, App, Dir, Options}, infinity). + +remove_module(Name, Mod) -> + gen_server:call(Name, {remove_module, Mod}, infinity). + +remove_application(Name, App) -> + gen_server:call(Name, {remove_application, App}, infinity). + +remove_release(Name, Rel) -> + gen_server:call(Name, {remove_release, Rel}, infinity). + +get_library_path(Name) -> + gen_server:call(Name, get_library_path, infinity). + +set_library_path(Name, Path) -> + gen_server:call(Name, {set_library_path, Path}, infinity). + +set_library_path(Name, Path, Options) -> + gen_server:call(Name, {set_library_path, Path, Options}, infinity). + +info(Name) -> + gen_server:call(Name, info, infinity). + +info(Name, What) -> + gen_server:call(Name, {info, What}, infinity). + +info(Name, What, Qual) -> + gen_server:call(Name, {info, What, Qual}, infinity). + +update(Name) -> + gen_server:call(Name, update, infinity). + +update(Name, Options) -> + gen_server:call(Name, {update, Options}, infinity). + +forget(Name) -> + gen_server:call(Name, forget, infinity). + +forget(Name, Variable) -> + gen_server:call(Name, {forget, Variable}, infinity). + +variables(Name) -> + gen_server:call(Name, variables, infinity). + +variables(Name, Options) -> + gen_server:call(Name, {variables, Options}, infinity). + +analyse(Name, What) -> + gen_server:call(Name, {analyze, What}, infinity). + +analyse(Name, What, Options) -> + gen_server:call(Name, {analyze, What, Options}, infinity). + +analyze(Name, What) -> + gen_server:call(Name, {analyze, What}, infinity). + +analyze(Name, What, Options) -> + gen_server:call(Name, {analyze, What, Options}, infinity). + +q(Name, Q) -> + gen_server:call(Name, {qry, Q}, infinity). + +q(Name, Q, Options) -> + gen_server:call(Name, {qry, Q, Options}, infinity). + +get_default(Name) -> + gen_server:call(Name, get_default, infinity). + +get_default(Name, Option) -> + gen_server:call(Name, {get_default, Option}, infinity). + +set_default(Name, OptionValues) -> + gen_server:call(Name, {set_default, OptionValues}, infinity). + +set_default(Name, Option, Value) -> + gen_server:call(Name, {set_default, Option, Value}, infinity). + +format_error({error, Module, Error}) -> + Module:format_error(Error); +format_error(E) -> + io_lib:format("~p~n", [E]). + +%%%---------------------------------------------------------------------- +%%%Callback functions from gen_server +%%%---------------------------------------------------------------------- + +%%---------------------------------------------------------------------- +%% Func: init/1 +%% Returns: {ok, State} | +%% {ok, State, Timeout} | +%% ignore | +%% {stop, Reason} +%%---------------------------------------------------------------------- +init(Args) -> + case xref_base:new(Args) of + {ok, S} -> + {ok, S}; + {error, _Module, Reason} -> + {stop, Reason} + end. + +%%---------------------------------------------------------------------- +%% Func: handle_call/3 +%% Returns: {reply, Reply, State} | +%% {reply, Reply, State, Timeout} | +%% {noreply, State} | +%% {noreply, State, Timeout} | +%% {stop, Reason, Reply, State} | (terminate/2 is called) +%% {stop, Reason, State} (terminate/2 is called) +%%---------------------------------------------------------------------- +handle_call(stop, _From, State) -> + {stop, normal, stopped, State}; +handle_call({add_release, Dir}, _From, State) -> + case xref_base:add_release(State, Dir) of + {ok, ReleaseName, NewState} -> + {reply, {ok, ReleaseName}, NewState}; + Error -> + {reply, Error, State} + end; +handle_call({add_release, Dir, Options}, _From, State) -> + case xref_base:add_release(State, Dir, Options) of + {ok, ReleaseName, NewState} -> + {reply, {ok, ReleaseName}, NewState}; + Error -> + {reply, Error, State} + end; +handle_call({add_application, Dir}, _From, State) -> + case xref_base:add_application(State, Dir) of + {ok, AppName, NewState} -> + {reply, {ok, AppName}, NewState}; + Error -> + {reply, Error, State} + end; +handle_call({add_application, Dir, Options}, _From, State) -> + case xref_base:add_application(State, Dir, Options) of + {ok, AppName, NewState} -> + {reply, {ok, AppName}, NewState}; + Error -> + {reply, Error, State} + end; +handle_call({add_module, File}, _From, State) -> + case xref_base:add_module(State, File) of + {ok, Module, NewState} -> + {reply, {ok, Module}, NewState}; + Error -> + {reply, Error, State} + end; +handle_call({add_module, File, Options}, _From, State) -> + case xref_base:add_module(State, File, Options) of + {ok, Module, NewState} -> + {reply, {ok, Module}, NewState}; + Error -> + {reply, Error, State} + end; +handle_call({replace_application, Appl, Dir}, _From, State) -> + case xref_base:replace_application(State, Appl, Dir) of + {ok, AppName, NewState} -> + {reply, {ok, AppName}, NewState}; + Error -> + {reply, Error, State} + end; +handle_call({replace_application, Appl, Dir, Opts}, _From, State) -> + case xref_base:replace_application(State, Appl, Dir, Opts) of + {ok, AppName, NewState} -> + {reply, {ok, AppName}, NewState}; + Error -> + {reply, Error, State} + end; +handle_call({remove_module, Mod}, _From, State) -> + case xref_base:remove_module(State, Mod) of + {ok, NewState} -> + {reply, ok, NewState}; + Error -> + {reply, Error, State} + end; +handle_call({remove_application, Appl}, _From, State) -> + case xref_base:remove_application(State, Appl) of + {ok, NewState} -> + {reply, ok, NewState}; + Error -> + {reply, Error, State} + end; +handle_call({remove_release, Rel}, _From, State) -> + case xref_base:remove_release(State, Rel) of + {ok, NewState} -> + {reply, ok, NewState}; + Error -> + {reply, Error, State} + end; +handle_call({add_directory, Dir}, _From, State) -> + case xref_base:add_directory(State, Dir) of + {ok, Modules, NewState} -> + {reply, {ok, Modules}, NewState}; + Error -> + {reply, Error, State} + end; +handle_call({add_directory, Dir, Options}, _From, State) -> + case xref_base:add_directory(State, Dir, Options) of + {ok, Modules, NewState} -> + {reply, {ok, Modules}, NewState}; + Error -> + {reply, Error, State} + end; +handle_call(get_library_path, _From, State) -> + Path = xref_base:get_library_path(State), + {reply, Path, State}; +handle_call({set_library_path, Path}, _From, State) -> + case xref_base:set_library_path(State, Path) of + {ok, NewState} -> + {reply, ok, NewState}; + Error -> + {reply, Error, State} + end; +handle_call({set_library_path, Path, Options}, _From, State) -> + case xref_base:set_library_path(State, Path, Options) of + {ok, NewState} -> + {reply, ok, NewState}; + Error -> + {reply, Error, State} + end; +handle_call({replace_module, Module, File}, _From, State) -> + case xref_base:replace_module(State, Module, File) of + {ok, Module, NewState} -> + {reply, {ok, Module}, NewState}; + Error -> + {reply, Error, State} + end; +handle_call({replace_module, Module, File, Options}, _From, State) -> + case xref_base:replace_module(State, Module, File, Options) of + {ok, Module, NewState} -> + {reply, {ok, Module}, NewState}; + Error -> + {reply, Error, State} + end; +handle_call(info, _From, State) -> + {reply, xref_base:info(State), State}; +handle_call({info, What}, _From, State) -> + {reply, xref_base:info(State, What), State}; +handle_call({info, What, Qual}, _From, State) -> + {reply, xref_base:info(State, What, Qual), State}; +handle_call(update, _From, State) -> + case xref_base:update(State) of + {ok, NewState, Modules} -> + {reply, {ok, Modules}, NewState}; + Error -> + {reply, Error, State} + end; +handle_call({update, Options}, _From, State) -> + case xref_base:update(State, Options) of + {ok, NewState, Modules} -> + {reply, {ok, Modules}, NewState}; + Error -> + {reply, Error, State} + end; +handle_call(forget, _From, State) -> + {ok, NewState} = xref_base:forget(State), + {reply, ok, NewState}; +handle_call({forget, Variable}, _From, State) -> + case xref_base:forget(State, Variable) of + {ok, NewState} -> + {reply, ok, NewState}; + Error -> + {reply, Error, State} + end; +handle_call(variables, _From, State) -> + %% The reason the ok-Error pattern is broken for variables, q and + %% analyze is that the state may have been updated even if an + %% error occurs. + {Reply, NewState} = xref_base:variables(State), + {reply, Reply, NewState}; +handle_call({variables, Options}, _From, State) -> + {Reply, NewState} = xref_base:variables(State, Options), + {reply, Reply, NewState}; +handle_call({analyze, What}, _From, State) -> + {Reply, NewState} = xref_base:analyze(State, What), + {reply, unsetify(Reply), NewState}; +handle_call({analyze, What, Options}, _From, State) -> + {Reply, NewState} = xref_base:analyze(State, What, Options), + {reply, unsetify(Reply), NewState}; +handle_call({qry, Q}, _From, State) -> + {Reply, NewState} = xref_base:q(State, Q), + {reply, unsetify(Reply), NewState}; +handle_call({qry, Q, Options}, _From, State) -> + {Reply, NewState} = xref_base:q(State, Q, Options), + {reply, unsetify(Reply), NewState}; +handle_call(get_default, _From, State) -> + Reply = xref_base:get_default(State), + {reply, Reply, State}; +handle_call({get_default, Option}, _From, State) -> + Reply = xref_base:get_default(State, Option), + {reply, Reply, State}; +handle_call({set_default, OptionValues}, _From, State) -> + case xref_base:set_default(State, OptionValues) of + {ok, NewState} -> + {reply, ok, NewState}; + Error -> + {reply, Error, State} + end; +handle_call({set_default, Option, Value}, _From, State) -> + case xref_base:set_default(State, Option, Value) of + {ok, OldValue, NewState} -> + {reply, {ok, OldValue}, NewState}; + Error -> + {reply, Error, State} + end. + +%%---------------------------------------------------------------------- +%% Func: handle_cast/2 +%% Returns: {noreply, State} | +%% {noreply, State, Timeout} | +%% {stop, Reason, State} (terminate/2 is called) +%%---------------------------------------------------------------------- +handle_cast(_Msg, State) -> {noreply, State}. + +%%---------------------------------------------------------------------- +%% Func: handle_info/2 +%% Returns: {noreply, State} | +%% {noreply, State, Timeout} | +%% {stop, Reason, State} (terminate/2 is called) +%%---------------------------------------------------------------------- +handle_info(_Info, State) -> + {noreply, State}. + +%%---------------------------------------------------------------------- +%% Func: terminate/2 +%% Purpose: Shutdown the server +%% Returns: any (ignored by gen_server) +%%---------------------------------------------------------------------- +terminate(_Reason, _State) -> + ok. + +%%---------------------------------------------------------------------- +%% Func: code_change/3 +%% Purpose: Convert process state when code is changed +%% Returns: {ok, NewState} +%%---------------------------------------------------------------------- +code_change(_OldVsn, State, _Extra) -> + {ok, State}. + +%%%---------------------------------------------------------------------- +%%% Internal functions +%%%---------------------------------------------------------------------- + +do_functions_analysis(FFun) -> + {ok, State} = xref_base:new(), + {ok, State1} = xref_base:set_library_path(State, code_path), + {ok, State2} = xref_base:set_default(State1, + [{verbose,false},{warnings,false}]), + State3 = case FFun(State2) of + {ok, _, S} -> S; + Error2 -> throw(Error2) + end, + {Undef, State4} = do_analysis(State3, undefined_function_calls), + {Unused, State5} = do_analysis(State4, locals_not_used), + {Deprecated, _} = do_analysis(State5, deprecated_function_calls), + [{deprecated,to_external(Deprecated)}, + {undefined,to_external(Undef)}, + {unused,to_external(Unused)}]. + +do_modules_analysis(FFun) -> + {ok, State} = xref_base:new({xref_mode, modules}), + {ok, State1} = xref_base:set_library_path(State, code_path), + {ok, State2} = xref_base:set_default(State1, + [{verbose,false},{warnings,false}]), + State3 = case FFun(State2) of + {ok, _, S} -> S; + Error2 -> throw(Error2) + end, + {Undef, State4} = do_analysis(State3, undefined_functions), + {Deprecated, _} = do_analysis(State4, deprecated_functions), + [{deprecated,to_external(Deprecated)}, + {undefined,to_external(Undef)}]. + +do_analysis(State, Analysis) -> + case xref_base:analyze(State, Analysis) of + {{ok, Reply}, NewState} -> + {Reply, NewState}; + {Error, _} -> + throw(Error) + end. + +unsetify(Reply={ok, X}) -> + case is_sofs_set(X) of + true -> {ok, to_external(X)}; + false -> Reply + end; +unsetify(Reply) -> + Reply. diff --git a/lib/tools/src/xref.hrl b/lib/tools/src/xref.hrl new file mode 100644 index 0000000000..fa8c5c746d --- /dev/null +++ b/lib/tools/src/xref.hrl @@ -0,0 +1,106 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2000-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% +%% + +%%% This file is meant to be included by xref_* only. + +-define(VAR_EXPR, '$F_EXPR'). +-define(MOD_EXPR, '$M_EXPR'). + +%%% Filenames are stored as directory and basename. A lot of heap can +%%% be saved by keeping only one (or few) copy of the directory name. + +%% 'data' in xref_mod holds "raw" data (as sets) for each module. The +%% data in 'variables' is derived from raw data. +-record(xref, { + version = 1, % version of the xref record + mode = functions, + variables = not_set_up, % table of variables + + modules = dict:new(), % dict-of(xref_mod()) + applications = dict:new(), % dict-of(xref_app()) + releases = dict:new(), % dict-of(xref_rel()) + + library_path = [], % [string()] | code_path + libraries = dict:new(), % dict-of(xref_lib()) + + builtins_default = false, % Default value of the 'builtins' option. + recurse_default = false, % Default value of the 'recurse' option. + verbose_default = false, % Default value of the 'verbose' option. + warnings_default = true % Default value of the 'warnings' option. + }). + +-record(xref_mod, { + name = '', + app_name = [], % [] or [AppName] + dir = "", % string(), directory where the BEAM file resides + mtime, % modification time for file + builtins, % whether calls to built-in functions are included + info, % number of exports, locals etc. + no_unresolved = 0, % number of unresolved calls + data + %% Data has been read from the BEAM file, and is represented here + %% as a list of sets. + %% If xref.mode = functions: + %% [ + %% DefAt, M -> P(V * N) + %% L, M -> P(V) + %% X, M -> P(V) + %% LCallAt, M -> P(V * V -> P(N)) + %% XCallAt, M -> P(V * V -> P(N)) + %% CallAt, M -> P(V * V -> P(N)) + %% LC, M -> P(V * V) + %% XC, M -> P(V * V) + %% LU, M -> P(V) + %% EE, M -> P(EV * EV) + %% ECallAt, M -> P(EV * EV -> P(N)) + %% Unres, M -> P(V * V) + %% LPredefined M -> P(V) + %% ] + %% + %% If xref.mode = modules: + %% [ + %% X, M -> P(V) + %% I M -> P(V) + %% ] + }). + +-record(xref_app, { + name = '', + rel_name = [], % [] or [RelName] + vsn = [], + dir = "" % where BEAM files are read from + }). + +-record(xref_rel, { + name = '', + dir = "" % where application directories reside + }). + +-record(xref_lib, { + name = '', % atom(), module name + dir = "" % string(), directory where the file resides + }). + +-record(xref_var, { + name = '', % atom(), variable name + value, % set or pair of sets, variable value + vtype, % VarType (predef, tmp, user) + otype, % ObjectType (vertex, edge, etc.) + type % Type (function, module, etc.) + }). diff --git a/lib/tools/src/xref_base.erl b/lib/tools/src/xref_base.erl new file mode 100644 index 0000000000..d0dbf4a2b4 --- /dev/null +++ b/lib/tools/src/xref_base.erl @@ -0,0 +1,1804 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2000-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(xref_base). + +-export([new/0, new/1, delete/1, + add_directory/2, add_directory/3, + add_module/2, add_module/3, + add_application/2, add_application/3, + replace_module/3, replace_module/4, + replace_application/3, replace_application/4, + remove_module/2, remove_application/2, remove_release/2, + add_release/2, add_release/3, + get_library_path/1, set_library_path/2, set_library_path/3, + set_up/1, set_up/2, + q/2, q/3, info/1, info/2, info/3, update/1, update/2, + forget/1, forget/2, variables/1, variables/2, + analyze/2, analyze/3, analysis/1, + get_default/2, set_default/3, + get_default/1, set_default/2]). + +-export([format_error/1]). + +%% The following functions are exported for testing purposes only: +-export([do_add_module/4, do_add_application/2, do_add_release/2, + do_remove_module/2]). + +-import(lists, + [filter/2, flatten/1, foldl/3, keysearch/3, map/2, mapfoldl/3, + member/2, reverse/1, sort/1, usort/1]). + +-import(sofs, + [constant_function/2, converse/1, difference/2, domain/1, + empty_set/0, family/1, family_difference/2, intersection/2, + family_projection/2, family_to_relation/1, family_union/1, + family_union/2, from_sets/1, from_term/1, a_function/1, + image/2, family_intersection/2, inverse/1, is_empty_set/1, + multiple_relative_product/2, no_elements/1, + partition_family/2, projection/2, range/1, relation/1, + relation_to_family/1, relative_product1/2, restriction/2, + restriction/3, set/1, specification/2, substitution/2, + to_external/1, union/1, union/2, union_of_family/1]). + +-include("xref.hrl"). + +-define(Suffix, ".beam"). + +%-define(debug, true). + +-ifdef(debug). +-define(FORMAT(P, A), io:format(P, A)). +-else. +-define(FORMAT(P, A), ok). +-endif. + +%% +%% Exported functions +%% + +new() -> + new([]). + +%% -> {ok, InitialState} +new(Options) -> + Modes = [functions,modules,function,module], + case xref_utils:options(Options, [{xref_mode,Modes}]) of + {[[function]], []} -> + {ok, #xref{mode = functions}}; + {[[module]], []} -> + {ok, #xref{mode = modules}}; + {[[OM]], []} -> + {ok, #xref{mode = OM}}; + _ -> + error({invalid_options, Options}) + end. + +%% -> ok +%% Need not be called by the server. +delete(State) when State#xref.variables =:= not_set_up -> + ok; +delete(State) -> + Fun = fun({X, _}) -> + case catch digraph:info(X) of + Info when is_list(Info) -> + true = digraph:delete(X); + _Else -> + ok + end + end, + map(Fun, dict:to_list(State#xref.variables)), + ok. + +add_directory(State, Dir) -> + add_directory(State, Dir, []). + +%% -> {ok, Modules, NewState} | Error +add_directory(State, Dir, Options) -> + ValOptions = option_values([builtins, recurse, verbose, warnings], State), + case xref_utils:options(Options, ValOptions) of + {[[OB], [OR], [OV], [OW]], []} -> + catch do_add_directory(Dir, [], OB, OR, OV, OW, State); + _ -> + error({invalid_options, Options}) + end. + +add_module(State, File) -> + add_module(State, File, []). + +%% -> {ok, Module, NewState} | Error +add_module(State, File, Options) -> + ValOptions = option_values([builtins, verbose, warnings], State), + case xref_utils:options(Options, ValOptions) of + {[[OB], [OV], [OW]], []} -> + case catch do_add_a_module(File, [], OB, OV, OW, State) of + {ok, [Module], NewState} -> + {ok, Module, NewState}; + {ok, [], _NewState} -> + error({no_debug_info, File}); + Error -> + Error + end; + _ -> + error({invalid_options, Options}) + end. + +add_application(State, AppDir) -> + add_application(State, AppDir, []). + +%% -> {ok, AppName, NewState} | Error +add_application(State, AppDir, Options) -> + OptVals = option_values([builtins, verbose, warnings], State), + ValidOptions = [{name, ["", fun check_name/1]} | OptVals], + case xref_utils:options(Options, ValidOptions) of + {[ApplName, [OB], [OV], [OW]], []} -> + catch do_add_application(AppDir, [], ApplName, OB, OV, OW, State); + _ -> + error({invalid_options, Options}) + end. + +replace_module(State, Module, File) -> + replace_module(State, Module, File, []). + +%% -> {ok, Module, NewState} | Error +replace_module(State, Module, File, Options) -> + ValidOptions = option_values([verbose, warnings], State), + case xref_utils:options(Options, ValidOptions) of + {[[OV], [OW]], []} -> + catch do_replace_module(Module, File, OV, OW, State); + _ -> + error({invalid_options, Options}) + end. + +replace_application(State, Appl, Dir) -> + replace_application(State, Appl, Dir, []). + +%% -> {ok, AppName, NewState} | Error +replace_application(State, Appl, Dir, Options) -> + ValidOptions = option_values([builtins, verbose, warnings], State), + case xref_utils:options(Options, ValidOptions) of + {[[OB], [OV], [OW]], []} -> + catch do_replace_application(Appl, Dir, OB, OV, OW, State); + _ -> + error({invalid_options, Options}) + end. + +%% -> {ok, NewState} | Error +remove_module(State, Mod) when is_atom(Mod) -> + remove_module(State, [Mod]); +remove_module(State, [Mod | Mods]) -> + case catch do_remove_module(State, Mod) of + {ok, _OldXMod, NewState} -> + remove_module(NewState, Mods); + Error -> + Error + end; +remove_module(State, []) -> + {ok, State}. + +%% -> {ok, NewState} | Error +remove_application(State, Appl) when is_atom(Appl) -> + remove_application(State, [Appl]); +remove_application(State, [Appl | Appls]) -> + case catch do_remove_application(State, Appl) of + {ok, _OldXApp, NewState} -> + remove_application(NewState, Appls); + Error -> + Error + end; +remove_application(State, []) -> + {ok, State}. + +%% -> {ok, NewState} | Error +remove_release(State, Rel) when is_atom(Rel) -> + remove_release(State, [Rel]); +remove_release(State, [Rel | Rels]) -> + case catch do_remove_release(State, Rel) of + {ok, _OldXRel, NewState} -> + remove_release(NewState, Rels); + Error -> + Error + end; +remove_release(State, []) -> + {ok, State}. + +add_release(State, RelDir) -> + add_release(State, RelDir, []). + +%% -> {ok, ReleaseName, NewState} | Error +add_release(State, RelDir, Options) -> + ValidOptions0 = option_values([builtins, verbose, warnings], State), + ValidOptions = [{name, ["", fun check_name/1]} | ValidOptions0], + case xref_utils:options(Options, ValidOptions) of + {[RelName, [OB], [OV], [OW]], []} -> + catch do_add_release(RelDir, RelName, OB, OV, OW, State); + _ -> + error({invalid_options, Options}) + end. + +get_library_path(State) -> + {ok, State#xref.library_path}. + +set_library_path(State, Path) -> + set_library_path(State, Path, []). + +%% -> {ok, NewState} | Error +set_library_path(State, code_path, _Options) -> + S1 = State#xref{library_path = code_path, libraries = dict:new()}, + {ok, take_down(S1)}; +set_library_path(State, Path, Options) -> + case xref_utils:is_path(Path) of + true -> + ValidOptions = option_values([verbose], State), + case xref_utils:options(Options, ValidOptions) of + {[[OV]], []} -> + do_add_libraries(Path, OV, State); + _ -> + error({invalid_options, Options}) + end; + false -> + error({invalid_path, Path}) + end. + +set_up(State) -> + set_up(State, []). + +%% -> {ok, NewState} | Error +set_up(State, Options) -> + ValidOptions = option_values([verbose], State), + case xref_utils:options(Options, ValidOptions) of + {[[Verbose]], []} -> + do_set_up(State, Verbose); + _ -> + error({invalid_options, Options}) + end. + +q(S, Q) -> + q(S, Q, []). + +%% -> {{ok, Answer}, NewState} | {Error, NewState} +q(S, Q, Options) when is_atom(Q) -> + q(S, atom_to_list(Q), Options); +q(S, Q, Options) -> + case xref_utils:is_string(Q, 1) of + true -> + case set_up(S, Options) of + {ok, S1} -> + case xref_compiler:compile(Q, S1#xref.variables) of + {NewT, Ans} -> + {{ok, Ans}, S1#xref{variables = NewT}}; + Error -> + {Error, S1} + end; + Error -> + {Error, S} + end; + false -> + {error({invalid_query, Q}), S} + end. + +%% -> InfoList +info(State) -> + D0 = sort(dict:to_list(State#xref.modules)), + D = map(fun({_M, XMod}) -> XMod end, D0), + NoApps = length(dict:to_list(State#xref.applications)), + NoRels = length(dict:to_list(State#xref.releases)), + No = no_sum(State, D), + [{library_path, State#xref.library_path}, {mode, State#xref.mode}, + {no_releases, NoRels}, {no_applications, NoApps}] ++ No. + +info(State, What) -> + do_info(State, What). + +%% -> [{what(), InfoList}] +info(State, What, Qual) -> + catch do_info(State, What, Qual). + +update(State) -> + update(State, []). + +%% -> {ok, NewState, Modules} | Error +update(State, Options) -> + ValidOptions = option_values([verbose, warnings], State), + case xref_utils:options(Options, ValidOptions) of + {[[OV],[OW]], []} -> + catch do_update(OV, OW, State); + _ -> + error({invalid_options, Options}) + end. + +%% -> {ok, NewState} +forget(State) -> + {U, _P} = do_variables(State), + {ok, foldl(fun(V, S) -> {ok, NS} = forget(S, V), NS end, State, U)}. + +%% -> {ok, NewState} | Error +forget(State, Variable) when State#xref.variables =:= not_set_up -> + error({not_user_variable, Variable}); +forget(State, Variable) when is_atom(Variable) -> + forget(State, [Variable]); +forget(State, Variables) -> + Vars = State#xref.variables, + do_forget(Variables, Vars, Variables, State). + +variables(State) -> + variables(State, [user]). + +%% -> {{ok, Answer}, NewState} | {Error, NewState} +%% Answer = [{vartype(), [VariableName]}] +variables(State, Options) -> + ValidOptions = option_values([verbose], State), + case xref_utils:options(Options, [user, predefined | ValidOptions]) of + {[User,Predef,[OV]],[]} -> + case do_set_up(State, OV) of + {ok, NewState} -> + {U, P} = do_variables(NewState), + R1 = if User -> [{user, U}]; true -> [] end, + R = if + Predef -> [{predefined,P} | R1]; + true -> R1 + end, + {{ok, R}, NewState}; + Error -> + {Error, State} + end; + _ -> + {error({invalid_options, Options}), State} + end. + +analyze(State, Analysis) -> + analyze(State, Analysis, []). + +%% -> {{ok, Answer}, NewState} | {Error, NewState} +analyze(State, Analysis, Options) -> + case analysis(Analysis, State#xref.mode) of + P when is_list(P) -> + q(State, P, Options); + error -> + R = case analysis(Analysis, functions) of + error -> unknown_analysis; + P when is_list(P) -> unavailable_analysis + end, + Error = error({R, Analysis}), + {Error, State} + end. + +analysis(Analysis) -> + analysis(Analysis, functions). + +%% -> string() | Error +analysis(undefined_function_calls, functions) -> + "(XC - UC) || (XU - X - B)"; +analysis(undefined_functions, modules) -> + %% "XU * (L + U)" is equivalent, but the following works when L is + %% not available. + "XU - X - B"; +analysis(undefined_functions, functions) -> + %% "XU * ((L + U) - range UC)" is equivalent. + "XU - range UC - X - B"; +analysis(locals_not_used, functions) -> + %% The Inter Call Graph is used to get local functions that are not + %% used (indirectly) from any export: "(domain EE + range EE) * L". + %% But then we only get locals that make some calls, so we add + %% locals that are not used at all: "L * (UU + XU - LU)". + "L * ((UU + XU - LU) + domain EE + range EE)"; +analysis(exports_not_used, _) -> + %% Local calls are not considered here. "X * UU" would do otherwise. + "X - XU"; +analysis({call, F}, functions) -> + make_query("range (E | ~w : Fun)", [F]); +analysis({use, F}, functions) -> + make_query("domain (E || ~w : Fun)", [F]); +analysis({module_call, M}, _) -> + make_query("range (ME | ~w : Mod)", [M]); +analysis({module_use, M}, _) -> + make_query("domain (ME || ~w : Mod)", [M]); +analysis({application_call, A}, _) -> + make_query("range (AE | ~w : App)", [A]); +analysis({application_use, A}, _) -> + make_query("domain (AE || ~w : App)", [A]); +analysis({release_call, R}, _) -> + make_query("range (RE | ~w : Rel)", [R]); +analysis({release_use, R}, _) -> + make_query("domain (RE || ~w : Rel)", [R]); +analysis(deprecated_function_calls, functions) -> + "XC || DF"; +analysis({deprecated_function_calls,Flag}, functions) -> + case deprecated_flag(Flag) of + undefined -> error; + I -> make_query("XC || DF_~w", [I]) + end; +analysis(deprecated_functions, _) -> + "XU * DF"; +analysis({deprecated_functions,Flag}, _) -> + case deprecated_flag(Flag) of + undefined -> error; + I -> make_query("XU * DF_~w", [I]) + end; +analysis(_, _) -> + error. + +%% -> {ok, OldValue, NewState} | Error +set_default(State, Option, Value) -> + case get_default(State, Option) of + {ok, OldValue} -> + Values = option_values([Option], State), + case xref_utils:options([{Option,Value}], Values) of + {_, []} -> + NewState = set_def(Option, Value, State), + {ok, OldValue, NewState}; + {_, Unknown} -> + error({invalid_options, Unknown}) + end; + Error -> + Error + end. + +%% -> {ok, Value} | Error +get_default(State, Option) -> + case catch current_default(State, Option) of + {'EXIT', _} -> + error({invalid_options, [Option]}); + Value -> + {ok, Value} + end. + +%% -> [{Option, Value}] +get_default(State) -> + Fun = fun(O) -> V = current_default(State, O), {O, V} end, + map(Fun, [builtins, recurse, verbose, warnings]). + +%% -> {ok, NewState} -> Error +set_default(State, Options) -> + Opts = [builtins, recurse, verbose, warnings], + ValidOptions = option_values(Opts, State), + case xref_utils:options(Options, ValidOptions) of + {Values = [[_], [_], [_], [_]], []} -> + {ok, set_defaults(Opts, Values, State)}; + _ -> + error({invalid_options, Options}) + end. + +format_error({error, Module, Error}) -> + Module:format_error(Error); +format_error({invalid_options, Options}) -> + io_lib:format("Unknown option(s) or invalid option value(s): ~p~n", + [Options]); +format_error({invalid_filename, Term}) -> + io_lib:format("A file name (a string) was expected: ~p~n", [Term]); +format_error({no_debug_info, FileName}) -> + io_lib:format("The BEAM file ~p has no debug info~n", [FileName]); +format_error({invalid_path, Term}) -> + io_lib:format("A path (a list of strings) was expected: ~p~n", [Term]); +format_error({invalid_query, Term}) -> + io_lib:format("A query (a string or an atom) was expected: ~p~n", [Term]); +format_error({not_user_variable, Variable}) -> + io_lib:format("~p is not a user variable~n", [Variable]); +format_error({unknown_analysis, Term}) -> + io_lib:format("~p is not a predefined analysis~n", [Term]); +format_error({module_mismatch, Module, ReadModule}) -> + io_lib:format("Name of read module ~p does not match analyzed module ~p~n", + [ReadModule, Module]); +format_error({release_clash, {Release, Dir, OldDir}}) -> + io_lib:format("The release ~p read from ~p clashes with release " + "already read from ~p~n", [Release, Dir, OldDir]); +format_error({application_clash, {Application, Dir, OldDir}}) -> + io_lib:format("The application ~p read from ~p clashes with application " + "already read from ~p~n", [Application, Dir, OldDir]); +format_error({module_clash, {Module, Dir, OldDir}}) -> + io_lib:format("The module ~p read from ~p clashes with module " + "already read from ~p~n", [Module, Dir, OldDir]); +format_error({no_such_release, Name}) -> + io_lib:format("There is no analyzed release ~p~n", [Name]); +format_error({no_such_application, Name}) -> + io_lib:format("There is no analyzed application ~p~n", [Name]); +format_error({no_such_module, Name}) -> + io_lib:format("There is no analyzed module ~p~n", [Name]); +format_error({no_such_info, Term}) -> + io_lib:format("~p is not one of 'modules', 'applications', " + "'releases' and 'libraries'~n", [Term]); +format_error(E) -> + io_lib:format("~p~n", [E]). + +%% +%% Local functions +%% + +check_name([N]) when is_atom(N) -> true; +check_name(_) -> false. + +do_update(OV, OW, State) -> + Changed = updated_modules(State), + Fun = fun({Mod,File}, S) -> + {ok, _M, NS} = do_replace_module(Mod, File, OV, OW, S), + NS + end, + NewState = foldl(Fun, State, Changed), + {ok, NewState, to_external(domain(a_function(Changed)))}. + +%% -> [{Module, File}] +updated_modules(State) -> + Fun = fun({M,XMod}, L) -> + RTime = XMod#xref_mod.mtime, + File = module_file(XMod), + case xref_utils:file_info(File) of + {ok, {_, file, readable, MTime}} when MTime =/= RTime -> + [{M,File} | L]; + _Else -> + L + end + end, + foldl(Fun, [], dict:to_list(State#xref.modules)). + +do_forget([Variable | Variables], Vars, Vs, State) -> + case dict:find(Variable, Vars) of + {ok, #xref_var{vtype = user}} -> + do_forget(Variables, Vars, Vs, State); + _ -> + error({not_user_variable, Variable}) + end; +do_forget([], Vars, Vs, State) -> + Fun = fun(V, VT) -> + {ok, #xref_var{value = Value}} = dict:find(V, VT), + VT1 = xref_compiler:update_graph_counter(Value, -1, VT), + dict:erase(V, VT1) + end, + NewVars = foldl(Fun, Vars, Vs), + NewState = State#xref{variables = NewVars}, + {ok, NewState}. + +%% -> {ok, Module, State} | throw(Error) +do_replace_module(Module, File, OV, OW, State) -> + {ok, OldXMod, State1} = do_remove_module(State, Module), + OldApp = OldXMod#xref_mod.app_name, + OB = OldXMod#xref_mod.builtins, + case do_add_a_module(File, OldApp, OB, OV, OW, State1) of + {ok, [Module], NewState} -> + {ok, Module, NewState}; + {ok, [ReadModule], _State} -> + throw_error({module_mismatch, Module, ReadModule}); + {ok, [], _NewState} -> + throw_error({no_debug_info, File}) + end. + +do_replace_application(Appl, Dir, OB, OV, OW, State) -> + {ok, OldXApp, State1} = do_remove_application(State, Appl), + Rel = OldXApp#xref_app.rel_name, + N = OldXApp#xref_app.name, + %% The application name is kept; the name of Dir is not used + %% as source for a "new" application name. + do_add_application(Dir, Rel, [N], OB, OV, OW, State1). + +%% -> {ok, ReleaseName, NewState} | throw(Error) +do_add_release(Dir, RelName, OB, OV, OW, State) -> + ok = is_filename(Dir), + case xref_utils:release_directory(Dir, true, "ebin") of + {ok, ReleaseDirName, ApplDir, Dirs} -> + ApplDirs = xref_utils:select_last_application_version(Dirs), + Release = case RelName of + [[]] -> ReleaseDirName; + [Name] -> Name + end, + XRel = #xref_rel{name = Release, dir = ApplDir}, + NewState = do_add_release(State, XRel), + add_rel_appls(ApplDirs, [Release], OB, OV, OW, NewState); + Error -> + throw(Error) + end. + +do_add_release(S, XRel) -> + Release = XRel#xref_rel.name, + case dict:find(Release, S#xref.releases) of + {ok, OldXRel} -> + Dir = XRel#xref_rel.dir, + OldDir = OldXRel#xref_rel.dir, + throw_error({release_clash, {Release, Dir, OldDir}}); + error -> + D1 = dict:store(Release, XRel, S#xref.releases), + S#xref{releases = D1} + end. + +add_rel_appls([ApplDir | ApplDirs], Release, OB, OV, OW, State) -> + {ok, _AppName, NewState} = + add_appldir(ApplDir, Release, [[]], OB, OV, OW, State), + add_rel_appls(ApplDirs, Release, OB, OV, OW, NewState); +add_rel_appls([], [Release], _OB, _OV, _OW, NewState) -> + {ok, Release, NewState}. + +do_add_application(Dir0, Release, Name, OB, OV, OW, State) -> + ok = is_filename(Dir0), + case xref_utils:select_application_directories([Dir0], "ebin") of + {ok, [ApplD]} -> + add_appldir(ApplD, Release, Name, OB, OV, OW, State); + Error -> + throw(Error) + end. + +%% -> {ok, AppName, NewState} | throw(Error) +add_appldir(ApplDir, Release, Name, OB, OV, OW, OldState) -> + {AppName0, Vsn, Dir} = ApplDir, + AppName = case Name of + [[]] -> AppName0; + [N] -> N + end, + AppInfo = #xref_app{name = AppName, rel_name = Release, + vsn = Vsn, dir = Dir}, + State1 = do_add_application(OldState, AppInfo), + {ok, _Modules, NewState} = + do_add_directory(Dir, [AppName], OB, false, OV, OW, State1), + {ok, AppName, NewState}. + +%% -> State | throw(Error) +do_add_application(S, XApp) -> + Application = XApp#xref_app.name, + case dict:find(Application, S#xref.applications) of + {ok, OldXApp} -> + Dir = XApp#xref_app.dir, + OldDir = OldXApp#xref_app.dir, + throw_error({application_clash, {Application, Dir, OldDir}}); + error -> + D1 = dict:store(Application, XApp, S#xref.applications), + S#xref{applications = D1} + end. + +%% -> {ok, Modules, NewState} | throw(Error) +do_add_directory(Dir, AppName, Bui, Rec, Ver, War, State) -> + ok = is_filename(Dir), + {FileNames, Errors, Jams, Unreadable} = + xref_utils:scan_directory(Dir, Rec, [?Suffix], [".jam"]), + warnings(War, jam, Jams), + warnings(War, unreadable, Unreadable), + case Errors of + [] -> + do_add_modules(FileNames, AppName, Bui, Ver, War, State, []); + [Error | _] -> + throw(Error) + end. + +do_add_modules([], _AppName, _OB, _OV, _OW, State, Modules) -> + {ok, sort(Modules), State}; +do_add_modules([File | Files], AppName, OB, OV, OW, State, Modules) -> + {ok, M, NewState} = do_add_module(File, AppName, OB, OV, OW, State), + do_add_modules(Files, AppName, OB, OV, OW, NewState, M ++ Modules). + +%% -> {ok, Module, State} | throw(Error) +do_add_a_module(File, AppName, Builtins, Verbose, Warnings, State) -> + case xref_utils:split_filename(File, ?Suffix) of + false -> + throw_error({invalid_filename, File}); + Splitname -> + do_add_module(Splitname, AppName, Builtins, Verbose, + Warnings, State) + end. + +%% -> {ok, Module, State} | throw(Error) +%% Options: verbose, warnings, builtins +do_add_module({Dir, Basename}, AppName, Builtins, Verbose, Warnings, State) -> + File = filename:join(Dir, Basename), + {ok, M, Bad, NewState} = + do_add_module1(Dir, File, AppName, Builtins, Verbose, Warnings, State), + filter(fun({Tag,B}) -> warnings(Warnings, Tag, [[File,B]]) end, Bad), + {ok, M, NewState}. + +do_add_module1(Dir, File, AppName, Builtins, Verbose, Warnings, State) -> + message(Verbose, reading_beam, [File]), + Mode = State#xref.mode, + Me = self(), + Fun = fun() -> Me ! {self(), abst(File, Builtins, Mode)} end, + case xref_utils:subprocess(Fun, [link, {min_heap_size,100000}]) of + {ok, _M, no_abstract_code} when Verbose -> + message(Verbose, skipped_beam, []), + {ok, [], [], State}; + {ok, _M, no_abstract_code} when not Verbose -> + message(Warnings, no_debug_info, [File]), + {ok, [], [], State}; + {ok, M, Data, UnresCalls0} -> + %% Remove duplicates. Identical unresolved calls on the + %% same line are counted as _one_ unresolved call. + UnresCalls = usort(UnresCalls0), + message(Verbose, done, []), + NoUnresCalls = length(UnresCalls), + case NoUnresCalls of + 0 -> ok; + 1 -> warnings(Warnings, unresolved_summary1, [[M]]); + N -> warnings(Warnings, unresolved_summary, [[M, N]]) + end, + T = case xref_utils:file_info(File) of + {ok, {_, _, _, Time}} -> Time; + Error -> throw(Error) + end, + XMod = #xref_mod{name = M, app_name = AppName, dir = Dir, + mtime = T, builtins = Builtins, + no_unresolved = NoUnresCalls}, + do_add_module(State, XMod, UnresCalls, Data); + Error -> + message(Verbose, error, []), + throw(Error) + end. + +abst(File, Builtins, Mode) when Mode =:= functions -> + case beam_lib:chunks(File, [abstract_code, exports, attributes]) of + {ok, {M,[{abstract_code,NoA},_X,_A]}} when NoA =:= no_abstract_code -> + {ok, M, NoA}; + {ok, {M, [{abstract_code, {abstract_v1, Forms}}, + {exports,X0}, {attributes,A}]}} -> + %% R7. + X = xref_utils:fa_to_mfa(X0, M), + D = deprecated(A, X, M), + xref_reader:module(M, Forms, Builtins, X, D); + {ok, {M, [{abstract_code, {abstract_v2, Forms}}, + {exports,X0}, {attributes,A}]}} -> + %% R8-R9B. + X = xref_utils:fa_to_mfa(X0, M), + D = deprecated(A, X, M), + xref_reader:module(M, Forms, Builtins, X, D); + {ok, {M, [{abstract_code, {raw_abstract_v1, Code}}, + {exports,X0}, {attributes,A}]}} -> + %% R9C- + Forms0 = epp:interpret_file_attribute(Code), + {_,_,Forms,_} = sys_pre_expand:module(Forms0, []), + X = mfa_exports(X0, A, M), + D = deprecated(A, X, M), + xref_reader:module(M, Forms, Builtins, X, D); + Error when element(1, Error) =:= error -> + Error + end; +abst(File, Builtins, Mode) when Mode =:= modules -> + case beam_lib:chunks(File, [exports, imports, attributes]) of + {ok, {Mod, [{exports,X0}, {imports,I0}, {attributes,At}]}} -> + X1 = mfa_exports(X0, At, Mod), + X = filter(fun(MFA) -> not (predef_fun())(MFA) end, X1), + D = deprecated(At, X, Mod), + I = case Builtins of + true -> + I0; + false -> + Fun = fun({M,F,A}) -> + not xref_utils:is_builtin(M, F, A) + end, + filter(Fun, I0) + end, + {ok, Mod, {X, I, D}, []}; + Error when element(1, Error) =:= error -> + Error + end. + +mfa_exports(X0, Attributes, M) -> + %% Adjust arities for abstract modules. + X1 = case xref_utils:is_abstract_module(Attributes) of + true -> + [{F,adjust_arity(F,A)} || {F,A} <- X0]; + false -> + X0 + end, + xref_utils:fa_to_mfa(X1, M). + +adjust_arity(F, A) -> + case xref_utils:is_static_function(F, A) of + true -> A; + false -> A - 1 + end. + +deprecated(A, X, M) -> + DF = {[],[],[],[]}, + case keysearch(deprecated, 1, A) of + {value, {deprecated, D0}} -> + depr(D0, M, DF, X, []); + false -> + {DF,[]} + end. + +depr([D | Depr], M, DF, X, Bad) -> + case depr_cat(D, M, X) of + {I,Dt} -> + NDF = setelement(I, DF, Dt ++ element(I, DF)), + depr(Depr, M, NDF, X, Bad); + undefined -> + depr(Depr, M, DF, X, [D | Bad]) + end; +depr([], _M, DF, _X, Bad) -> + {DF, reverse(Bad)}. + +depr_cat({F, A, Flg}, M, X) -> + case deprecated_flag(Flg) of + undefined -> undefined; + I -> depr_fa(F, A, X, M, I) + end; +depr_cat({F, A}, M, X) -> + depr_fa(F, A, X, M, 4); +depr_cat(module, M, X) -> + depr_fa('_', '_', X, M, 4); +depr_cat(_D, _M, _X) -> + undefined. + +depr_fa('_', '_', X, _M, I) -> + {I, X}; +depr_fa(F, '_', X, _M, I) when is_atom(F) -> + {I, filter(fun({_,F1,_}) -> F1 =:= F end, X)}; +depr_fa(F, A, _X, M, I) when is_atom(F), is_integer(A), A >= 0 -> + {I, [{M,F,A}]}; +depr_fa(_F, _A, _X, _M, _I) -> + undefined. + +%% deprecated_flag(Flag) -> integer() | undefined +%% Maps symbolic flags for deprecated functions to integers. + +%deprecated_flag(1) -> 1; +%deprecated_flag(2) -> 2; +%deprecated_flag(3) -> 3; +deprecated_flag(next_version) -> 1; +deprecated_flag(next_major_release) -> 2; +deprecated_flag(eventually) -> 3; +deprecated_flag(_) -> undefined. + +%% -> {ok, Module, Bad, State} | throw(Error) +%% Assumes: +%% L U X is a subset of dom DefAt +%% dom CallAt = LC U XC +%% Attrs is collected from the attribute 'xref' (experimental). +do_add_module(S, XMod, Unres, Data) -> + M = XMod#xref_mod.name, + case dict:find(M, S#xref.modules) of + {ok, OldXMod} -> + BF2 = module_file(XMod), + BF1 = module_file(OldXMod), + throw_error({module_clash, {M, BF1, BF2}}); + error -> + do_add_module(S, M, XMod, Unres, Data) + end. + +%%do_add_module(S, M, _XMod, _Unres, Data)-> +%% {ok, M, [], S}; +do_add_module(S, M, XMod, Unres0, Data) when S#xref.mode =:= functions -> + {DefAt0, LPreCAt0, XPreCAt0, LC0, XC0, X0, Attrs, Depr} = Data, + %% Bad is a list of bad values of 'xref' attributes. + {ALC0,AXC0,Bad0} = Attrs, + FT = [tspec(func)], + FET = [tspec(fun_edge)], + PCA = [tspec(pre_call_at)], + + XPreCAt1 = xref_utils:xset(XPreCAt0, PCA), + LPreCAt1 = xref_utils:xset(LPreCAt0, PCA), + DefAt = xref_utils:xset(DefAt0, [tspec(def_at)]), + X1 = xref_utils:xset(X0, FT), + XC1 = xref_utils:xset(XC0, FET), + LC1 = xref_utils:xset(LC0, FET), + AXC1 = xref_utils:xset(AXC0, PCA), + ALC1 = xref_utils:xset(ALC0, PCA), + UnresCalls = xref_utils:xset(Unres0, PCA), + Unres = domain(UnresCalls), + + DefinedFuns = domain(DefAt), + {AXC, ALC, Bad1, LPreCAt2, XPreCAt2} = + extra_edges(AXC1, ALC1, Bad0, DefinedFuns), + Bad = map(fun(B) -> {xref_attr, B} end, Bad1), + LPreCAt = union(LPreCAt1, LPreCAt2), + XPreCAt = union(XPreCAt1, XPreCAt2), + NoCalls = no_elements(LPreCAt) + no_elements(XPreCAt), + LCallAt = relation_to_family(LPreCAt), + XCallAt = relation_to_family(XPreCAt), + CallAt = family_union(LCallAt, XCallAt), + %% Local and exported functions with no definitions are removed. + L = difference(DefinedFuns, X1), + X = difference(DefinedFuns, L), + XC = union(XC1, AXC), + LC = union(LC1, ALC), + + {DF1,DF_11,DF_21,DF_31,DBad} = depr_mod(Depr, X), + + %% {EE, ECallAt} = inter_graph(X, L, LC, XC, LCallAt, XCallAt), + Self = self(), + Fun = fun() -> inter_graph(Self, X, L, LC, XC, CallAt) end, + {EE, ECallAt} = + xref_utils:subprocess(Fun, [link, {min_heap_size,100000}]), + + [DefAt2,L2,X2,LCallAt2,XCallAt2,CallAt2,LC2,XC2,EE2,ECallAt2, + DF2,DF_12,DF_22,DF_32] = + pack([DefAt,L,X,LCallAt,XCallAt,CallAt,LC,XC,EE,ECallAt, + DF1,DF_11,DF_21,DF_31]), + + %% Foo = [DefAt2,L2,X2,LCallAt2,XCallAt2,CallAt2,LC2,XC2,EE2,ECallAt2, + %% DF2,DF_12,DF_22,DF_32], + %% io:format("{~p, ~p, ~p},~n", [M, pack:lsize(Foo), pack:usize(Foo)]), + + LU = range(LC2), + + LPredefined = predefined_funs(LU), + + MS = xref_utils:xset(M, atom), + T = from_sets({MS,DefAt2,L2,X2,LCallAt2,XCallAt2,CallAt2, + LC2,XC2,LU,EE2,ECallAt2,Unres,LPredefined, + DF2,DF_12,DF_22,DF_32}), + + NoUnres = XMod#xref_mod.no_unresolved, + Info = no_info(X2, L2, LC2, XC2, EE2, Unres, NoCalls, NoUnres), + + XMod1 = XMod#xref_mod{data = T, info = Info}, + S1 = S#xref{modules = dict:store(M, XMod1, S#xref.modules)}, + {ok, [M], DBad++Bad, take_down(S1)}; +do_add_module(S, M, XMod, _Unres, Data) when S#xref.mode =:= modules -> + {X0, I0, Depr} = Data, + X1 = xref_utils:xset(X0, [tspec(func)]), + I1 = xref_utils:xset(I0, [tspec(func)]), + {DF1,DF_11,DF_21,DF_31,DBad} = depr_mod(Depr, X1), + [X2,I2,DF2,DF_12,DF_22,DF_32] = pack([X1,I1,DF1,DF_11,DF_21,DF_31]), + MS = xref_utils:xset(M, atom), + T = from_sets({MS, X2, I2, DF2, DF_12, DF_22, DF_32}), + Info = [], + XMod1 = XMod#xref_mod{data = T, info = Info}, + S1 = S#xref{modules = dict:store(M, XMod1, S#xref.modules)}, + {ok, [M], DBad, take_down(S1)}. + +depr_mod({Depr,Bad0}, X) -> + %% Bad0 are badly formed deprecated attributes. + %% Here deprecated functions that are neither BIFs nor exported + %% are deemed bad. do_set_up filters away BIFs if necessary. + {DF_10,DF_20,DF_30,DF0} = Depr, + FT = [tspec(func)], + DF1 = xref_utils:xset(DF0, FT), + DF_11 = xref_utils:xset(DF_10, FT), + DF_21 = xref_utils:xset(DF_20, FT), + DF_31 = xref_utils:xset(DF_30, FT), + + All = union(from_sets([DF1,DF_11,DF_21,DF_31])), + Fun = {external, fun({M,F,A}) -> xref_utils:is_builtin(M, F, A) end}, + XB = union(X, specification(Fun, All)), + DF_1 = intersection(DF_11, XB), + DF_2 = union(intersection(DF_21, XB), DF_1), + DF_3 = union(intersection(DF_31, XB), DF_2), + DF = union(intersection(DF1, XB), DF_3), + + Bad1 = difference(All, XB), + Bad2 = to_external(difference(Bad1, predefined_funs(Bad1))), + Bad = map(fun(B) -> {depr_attr, B} end, usort(Bad2++Bad0)), + {DF,DF_1,DF_2,DF_3,Bad}. + +%% Extra edges gathered from the attribute 'xref' (experimental) +extra_edges(CAX, CAL, Bad0, F) -> + AXC0 = domain(CAX), + ALC0 = domain(CAL), + AXC = restriction(AXC0, F), + ALC = restriction(2, restriction(ALC0, F), F), + LPreCAt2 = restriction(CAL, ALC), + XPreCAt2 = restriction(CAX, AXC), + Bad = Bad0 ++ to_external(difference(AXC0, AXC)) + ++ to_external(difference(ALC0, ALC)), + {AXC, ALC, Bad, LPreCAt2, XPreCAt2}. + +no_info(X, L, LC, XC, EE, Unres, NoCalls, NoUnresCalls) -> + NoUnres = no_elements(Unres), + [{no_calls, {NoCalls-NoUnresCalls, NoUnresCalls}}, + {no_function_calls, {no_elements(LC), no_elements(XC)-NoUnres, NoUnres}}, + {no_functions, {no_elements(L), no_elements(X)}}, + %% Note: this is overwritten in do_set_up(): + {no_inter_function_calls, no_elements(EE)}]. + +inter_graph(Pid, X, L, LC, XC, CallAt) -> + Pid ! {self(), inter_graph(X, L, LC, XC, CallAt)}. + +%% Inter Call Graph. +%inter_graph(_X, _L, _LC, _XC, _CallAt) -> +% {empty_set(), empty_set()}; +inter_graph(X, L, LC, XC, CallAt) -> + G = xref_utils:relation_to_graph(LC), + + Reachable0 = digraph_utils:reachable_neighbours(to_external(X), G), + Reachable = xref_utils:xset(Reachable0, [tspec(func)]), + % XL includes exports and locals that are not used by any exports + % (the locals are tacitly ignored in the comments below). + XL = union(difference(L, Reachable), X), + + % Immediate local calls between the module's own exports are qualified. + LEs = restriction(restriction(2, LC, XL), XL), + % External calls to the module's exports are qualified. + XEs = restriction(XC, XL), + Es = union(LEs, XEs), + + E1 = to_external(restriction(difference(LC, LEs), XL)), + R0 = xref_utils:xset(reachable(E1, G, []), + [{tspec(func), tspec(fun_edge)}]), + true = digraph:delete(G), + + % RL is a set of indirect local calls to exports. + RL = restriction(R0, XL), + % RX is a set of indirect external calls to exports. + RX = relative_product1(R0, XC), + R = union(RL, converse(RX)), + + EE0 = projection({external, fun({Ee2,{Ee1,_L}}) -> {Ee1,Ee2} end}, R), + EE = union(Es, EE0), + + % The first call in each chain, {e1,l}, contributes with the line + % number(s) l. + SFun = {external, fun({Ee2,{Ee1,Ls}}) -> {{Ee1,Ls},{Ee1,Ee2}} end}, + ECallAt1 = relative_product1(projection(SFun, R), CallAt), + ECallAt2 = union(ECallAt1, restriction(CallAt, Es)), + ECallAt = family_union(relation_to_family(ECallAt2)), + + ?FORMAT("XL=~p~nXEs=~p~nLEs=~p~nE1=~p~nR0=~p~nRL=~p~nRX=~p~nR=~p~n" + "EE=~p~nECallAt1=~p~nECallAt2=~p~nECallAt=~p~n~n", + [XL, XEs, LEs, E1, R0, RL, RX, R, EE, + ECallAt1, ECallAt2, ECallAt]), + {EE, ECallAt}. + +%% -> set of {V2,{V1,L1}} +reachable([E = {_X, L} | Xs], G, R) -> + Ns = digraph_utils:reachable([L], G), + reachable(Xs, G, reach(Ns, E, R)); +reachable([], _G, R) -> + R. + +reach([N | Ns], E, L) -> + reach(Ns, E, [{N, E} | L]); +reach([], _E, L) -> + L. + +tspec(func) -> {atom, atom, atom}; +tspec(fun_edge) -> {tspec(func), tspec(func)}; +tspec(def_at) -> {tspec(func), atom}; +tspec(pre_call_at) -> {tspec(fun_edge), atom}. + +%% -> {ok, OldXrefRel, NewState} | throw(Error) +do_remove_release(S, RelName) -> + case dict:find(RelName, S#xref.releases) of + error -> + throw_error({no_such_release, RelName}); + {ok, XRel} -> + S1 = take_down(S), + S2 = remove_rel(S1, RelName), + {ok, XRel, S2} + end. + +%% -> {ok, OldXrefApp, NewState} | throw(Error) +do_remove_application(S, AppName) -> + case dict:find(AppName, S#xref.applications) of + error -> + throw_error({no_such_application, AppName}); + {ok, XApp} -> + S1 = take_down(S), + S2 = remove_apps(S1, [AppName]), + {ok, XApp, S2} + end. + +%% -> {ok, OldXMod, NewState} | throw(Error) +do_remove_module(S, Module) -> + case dict:find(Module, S#xref.modules) of + error -> + throw_error({no_such_module, Module}); + {ok, XMod} -> + S1 = take_down(S), + {ok, XMod, remove_modules(S1, [Module])} + end. + +remove_rel(S, RelName) -> + Rels = [RelName], + Fun = fun({A,XApp}, L) when XApp#xref_app.rel_name =:= Rels -> + [A | L]; + (_, L) -> L + end, + Apps = foldl(Fun, [], dict:to_list(S#xref.applications)), + S1 = remove_apps(S, Apps), + NewReleases = remove_erase(Rels, S1#xref.releases), + S1#xref{releases = NewReleases}. + +remove_apps(S, Apps) -> + Fun = fun({M,XMod}, L) -> + case XMod#xref_mod.app_name of + [] -> L; + [AppName] -> [{AppName,M} | L] + end + end, + Ms = foldl(Fun, [], dict:to_list(S#xref.modules)), + Modules = to_external(image(relation(Ms), set(Apps))), + S1 = remove_modules(S, Modules), + NewApplications = remove_erase(Apps, S1#xref.applications), + S1#xref{applications = NewApplications}. + +remove_modules(S, Modules) -> + NewModules = remove_erase(Modules, S#xref.modules), + S#xref{modules = NewModules}. + +remove_erase([K | Ks], D) -> + remove_erase(Ks, dict:erase(K, D)); +remove_erase([], D) -> + D. + +do_add_libraries(Path, Verbose, State) -> + message(Verbose, lib_search, []), + {C, E} = xref_utils:list_path(Path, [?Suffix]), + message(Verbose, done, []), + MDs = to_external(relation_to_family(relation(C))), + %% message(Verbose, lib_check, []), + Reply = check_file(MDs, [], E, Path, State), + %% message(Verbose, done, []), + Reply. + +%%check_file([{_M, [{_N, Dir, File} | _]} | MDs], L, E, Path, State) -> +%% case beam_lib:version(filename:join(Dir, File)) of +%% {ok, {Module, _Version}} -> +%% XLib = #xref_lib{name = Module, dir = Dir}, +%% check_file(MDs, [{Module,XLib} | L], E, Path, State); +%% Error -> +%% check_file(MDs, L, [Error | E], Path, State) +%% end; +check_file([{Module, [{_N, Dir, _File} | _]} | MDs], L, E, Path, State) -> + XLib = #xref_lib{name = Module, dir = Dir}, + check_file(MDs, [{Module,XLib} | L], E, Path, State); +check_file([], L, [], Path, State) -> + D = dict:from_list(L), + State1 = State#xref{library_path = Path, libraries = D}, + %% Take down everything, that's simplest. + NewState = take_down(State1), + {ok, NewState}; +check_file([], _L, [E | _], _Path, _State) -> + E. + +%% -> {ok, NewState} | Error +%% Finding libraries may fail. +do_set_up(S, _VerboseOpt) when S#xref.variables =/= not_set_up -> + {ok, S}; +do_set_up(S, VerboseOpt) -> + message(VerboseOpt, set_up, []), + Reply = (catch do_set_up(S)), + message(VerboseOpt, done, []), + Reply. + +%% If data has been supplied using add_module/9 (and that is the only +%% sanctioned way), then DefAt, L, X, LCallAt, XCallAt, CallAt, XC, LC, +%% and LU are guaranteed to be functions (with all supplied +%% modules as domain (disregarding unknown modules, that is, modules +%% not supplied but hosting unknown functions)). +%% As a consequence, V and E are also functions. V is defined for unknown +%% modules also. +%% UU is also a function (thanks to sofs:family_difference/2...). +%% XU on the other hand can be a partial function (that is, not defined +%% for all modules). U is derived from XU, so U is also partial. +%% The inverse variables - LC_1, XC_1, E_1 and EE_1 - are all partial. +%% B is also partial. +do_set_up(S) when S#xref.mode =:= functions -> + ModDictList = dict:to_list(S#xref.modules), + [DefAt0, L, X0, LCallAt, XCallAt, CallAt, LC, XC, LU, + EE0, ECallAt, UC, LPredefined, + Mod_DF,Mod_DF_1,Mod_DF_2,Mod_DF_3] = make_families(ModDictList, 18), + + {XC_1, XU, XPredefined} = do_set_up_1(XC), + LC_1 = user_family(union_of_family(LC)), + E_1 = family_union(XC_1, LC_1), + Predefined = family_union(XPredefined, LPredefined), + + %% Add "hidden" functions to the exports. + X1 = family_union(X0, Predefined), + + F1 = family_union(L, X1), + V = family_union(F1, XU), + E = family_union(LC, XC), + + M = domain(V), + M2A = make_M2A(ModDictList), + {A2R,A} = make_A2R(S#xref.applications), + R = set(dict:fetch_keys(S#xref.releases)), + + %% Converting from edges of functions to edges of modules. + VEs = union_of_family(E), + Fun = {external, fun({{M1,_F1,_A1},{M2,_F2,_A2}}) -> {M1,M2} end}, + ME = projection(Fun, VEs), + ME2AE = multiple_relative_product({M2A, M2A}, ME), + + AE = range(ME2AE), + AE2RE = multiple_relative_product({A2R, A2R}, AE), + RE = range(AE2RE), + + AM = domain(F1), + %% Undef is the union of U0 and Lib: + {Undef, U0, Lib, Lib_DF, Lib_DF_1, Lib_DF_2, Lib_DF_3} = + make_libs(XU, F1, AM, S#xref.library_path, S#xref.libraries), + {B, U} = make_builtins(U0), + X1_B = family_union(X1, B), + F = family_union(F1, Lib), + DF = family_union(family_intersection(Mod_DF, X1_B), Lib_DF), + DF_1 = family_union(family_intersection(Mod_DF_1, X1_B), Lib_DF_1), + DF_2 = family_union(family_intersection(Mod_DF_2, X1_B), Lib_DF_2), + DF_3 = family_union(family_intersection(Mod_DF_3, X1_B), Lib_DF_3), + % If we have 'used' too, then there will be a set LU U XU... + UU = family_difference(family_difference(F1, LU), XU), + DefAt = make_defat(Undef, DefAt0), + + LM = domain(Lib), + UM = difference(difference(domain(U), AM), LM), + X = family_union(X1, Lib), + + %% Inter Call Graph. Calls to exported functions (library + %% functions inclusive) as well as calls within modules. This is a + %% way to discard calls to local functions in other modules. + EE_conv = converse(union_of_family(EE0)), + EE_exported = restriction(EE_conv, union_of_family(X)), + EE_local = + specification({external, fun({{M1,_,_},{M2,_,_}}) -> M1 =:= M2 end}, + EE_conv), + EE_0 = converse(union(EE_local, EE_exported)), + EE_1 = user_family(EE_0), + EE1 = partition_family({external, fun({{M1,_,_}, _MFA2}) -> M1 end}, + EE_0), + %% Make sure EE is defined for all modules: + EE = family_union(family_difference(EE0, EE0), EE1), + IFun = + fun({Mod,EE_M}, XMods) -> + IMFun = + fun(XrefMod) -> + [NoCalls, NoFunctionCalls, + NoFunctions, _NoInter] = XrefMod#xref_mod.info, + NewInfo = [NoCalls, NoFunctionCalls, NoFunctions, + {no_inter_function_calls,length(EE_M)}], + XrefMod#xref_mod{info = NewInfo} + end, + dict:update(Mod, IMFun,XMods) + end, + XrefMods1 = foldl(IFun, S#xref.modules, to_external(EE)), + S1 = S#xref{modules = XrefMods1}, + + UC_1 = user_family(union_of_family(UC)), + + ?FORMAT("DefAt ~p~n", [DefAt]), + ?FORMAT("U=~p~nLib=~p~nB=~p~nLU=~p~nXU=~p~nUU=~p~n", [U,Lib,B,LU,XU,UU]), + ?FORMAT("E_1=~p~nLC_1=~p~nXC_1=~p~n", [E_1,LC_1,XC_1]), + ?FORMAT("EE=~p~nEE_1=~p~nECallAt=~p~n", [EE, EE_1, ECallAt]), + ?FORMAT("DF=~p~nDF_1=~p~nDF_2=~p~nDF_3=~p~n", [DF, DF_1, DF_2, DF_3]), + + Vs = [{'L',L}, {'X',X},{'F',F},{'U',U},{'B',B},{'UU',UU}, + {'XU',XU},{'LU',LU},{'V',V},{v,V}, + {'LC',{LC,LC_1}},{'XC',{XC,XC_1}},{'E',{E,E_1}},{e,{E,E_1}}, + {'EE',{EE,EE_1}},{'UC',{UC,UC_1}}, + {'M',M},{'A',A},{'R',R}, + {'AM',AM},{'UM',UM},{'LM',LM}, + {'ME',ME},{'AE',AE},{'RE',RE}, + {'DF',DF},{'DF_1',DF_1},{'DF_2',DF_2},{'DF_3',DF_3}, + {me2ae, ME2AE},{ae, AE2RE},{m2a, M2A},{a2r, A2R}, + {def_at, DefAt}, {call_at, CallAt}, {e_call_at, ECallAt}, + {l_call_at, LCallAt}, {x_call_at, XCallAt}], + finish_set_up(S1, Vs); +do_set_up(S) when S#xref.mode =:= modules -> + ModDictList = dict:to_list(S#xref.modules), + [X0, I0, Mod_DF, Mod_DF_1, Mod_DF_2, Mod_DF_3] = + make_families(ModDictList, 7), + I = union_of_family(I0), + AM = domain(X0), + + {XU, Predefined} = make_predefined(I, AM), + %% Add "hidden" functions to the exports. + X1 = family_union(X0, Predefined), + V = family_union(X1, XU), + + M = union(AM, domain(XU)), + M2A = make_M2A(ModDictList), + {A2R,A} = make_A2R(S#xref.applications), + R = set(dict:fetch_keys(S#xref.releases)), + + ME = projection({external, fun({M1,{M2,_F2,_A2}}) -> {M1,M2} end}, + family_to_relation(I0)), + ME2AE = multiple_relative_product({M2A, M2A}, ME), + + AE = range(ME2AE), + AE2RE = multiple_relative_product({A2R, A2R}, AE), + RE = range(AE2RE), + + %% Undef is the union of U0 and Lib: + {_Undef, U0, Lib, Lib_DF, Lib_DF_1, Lib_DF_2, Lib_DF_3} = + make_libs(XU, X1, AM, S#xref.library_path, S#xref.libraries), + {B, U} = make_builtins(U0), + X1_B = family_union(X1, B), + DF = family_union(family_intersection(Mod_DF, X1_B), Lib_DF), + DF_1 = family_union(family_intersection(Mod_DF_1, X1_B), Lib_DF_1), + DF_2 = family_union(family_intersection(Mod_DF_2, X1_B), Lib_DF_2), + DF_3 = family_union(family_intersection(Mod_DF_3, X1_B), Lib_DF_3), + + LM = domain(Lib), + UM = difference(difference(domain(U), AM), LM), + X = family_union(X1, Lib), + + Empty = empty_set(), + Vs = [{'X',X},{'U',U},{'B',B},{'XU',XU},{v,V}, + {e,{Empty,Empty}}, + {'M',M},{'A',A},{'R',R}, + {'AM',AM},{'UM',UM},{'LM',LM}, + {'ME',ME},{'AE',AE},{'RE',RE}, + {'DF',DF},{'DF_1',DF_1},{'DF_2',DF_2},{'DF_3',DF_3}, + {me2ae, ME2AE},{ae, AE2RE},{m2a, M2A},{a2r, A2R}, + {def_at, Empty}, {call_at, Empty}, {e_call_at, Empty}, + {l_call_at, Empty}, {x_call_at, Empty}], + finish_set_up(S, Vs). + +finish_set_up(S, Vs) -> + T = do_finish_set_up(Vs, dict:new()), + S1 = S#xref{variables = T}, + %% io:format("~p <= state <= ~p~n", [pack:lsize(S), pack:usize(S)]), + {ok, S1}. + +do_finish_set_up([{Key, Value} | Vs], T) -> + {Type, OType} = var_type(Key), + Val = #xref_var{name = Key, value = Value, vtype = predef, + otype = OType, type = Type}, + T1 = dict:store(Key, Val, T), + do_finish_set_up(Vs, T1); +do_finish_set_up([], T) -> + T. + +var_type('B') -> {function, vertex}; +var_type('F') -> {function, vertex}; +var_type('L') -> {function, vertex}; +var_type('LU') -> {function, vertex}; +var_type('U') -> {function, vertex}; +var_type('UU') -> {function, vertex}; +var_type('V') -> {function, vertex}; +var_type('X') -> {function, vertex}; +var_type('XU') -> {function, vertex}; +var_type('DF') -> {function, vertex}; +var_type('DF_1') -> {function, vertex}; +var_type('DF_2') -> {function, vertex}; +var_type('DF_3') -> {function, vertex}; +var_type('A') -> {application, vertex}; +var_type('AM') -> {module, vertex}; +var_type('LM') -> {module, vertex}; +var_type('M') -> {module, vertex}; +var_type('UM') -> {module, vertex}; +var_type('R') -> {release, vertex}; +var_type('E') -> {function, edge}; +var_type('EE') -> {function, edge}; +var_type('LC') -> {function, edge}; +var_type('UC') -> {function, edge}; +var_type('XC') -> {function, edge}; +var_type('AE') -> {application, edge}; +var_type('ME') -> {module, edge}; +var_type('RE') -> {release, edge}; +var_type(_) -> {foo, bar}. + +make_families(ModDictList, N) -> + Fun1 = fun({_,XMod}) -> XMod#xref_mod.data end, + Ss = from_sets(map(Fun1, ModDictList)), + %% io:format("~n~p <= module data <= ~p~n", + %% [pack:lsize(Ss), pack:usize(Ss)]), + make_fams(N, Ss, []). + +make_fams(1, _Ss, L) -> + L; +make_fams(I, Ss, L) -> + Fun = {external, fun(R) -> {element(1, R), element(I, R)} end}, + make_fams(I-1, Ss, [projection(Fun, Ss) | L]). + +make_M2A(ModDictList) -> + Fun = fun({M,XMod}) -> {M, XMod#xref_mod.app_name} end, + Mod0 = family(map(Fun, ModDictList)), + Mod = family_to_relation(Mod0), + Mod. + +make_A2R(ApplDict) -> + AppDict = dict:to_list(ApplDict), + Fun = fun({A,XApp}) -> {A, XApp#xref_app.rel_name} end, + Appl0 = family(map(Fun, AppDict)), + AllApps = domain(Appl0), + Appl = family_to_relation(Appl0), + {Appl, AllApps}. + +do_set_up_1(XC) -> + %% Call Graph cross reference... + XCp = union_of_family(XC), + XC_1 = user_family(XCp), + + %% I - functions used externally from some module + %% XU - functions used externally per module. + I = range(XCp), + + {XU, XPredefined} = make_predefined(I, domain(XC)), + {XC_1, XU, XPredefined}. + +make_predefined(I, CallingModules) -> + XPredefined0 = predefined_funs(I), + XPredefined1 = converse(substitution(1, XPredefined0)), + %% predefined funs in undefined modules are still undefined... + XPredefined2 = restriction(XPredefined1, CallingModules), + XPredefined = relation_to_family(XPredefined2), + XU = partition_family(1, I), + {XU, XPredefined}. + +predefined_funs(Functions) -> + specification({external, predef_fun()}, Functions). + +predef_fun() -> + PredefinedFuns = xref_utils:predefined_functions(), + fun({_M,F,A}) -> member({F,A}, PredefinedFuns) end. + +make_defat(Undef, DefAt0) -> + % Complete DefAt with unknown functions: + Zero = from_term(0), + DAL = family_projection(fun(S) -> constant_function(S, Zero) end, Undef), + family_union(DefAt0, DAL). + +%% -> {Unknown U Lib, Unknown, Lib} | throw(Error) +make_libs(XU, F, AM, LibPath, LibDict) -> + Undef = family_difference(XU, F), + UM = difference(domain(family_to_relation(Undef)), AM), + Fs = case is_empty_set(UM) of + true -> + []; + false when LibPath =:= code_path -> + BFun = fun(M, A) -> case xref_utils:find_beam(M) of + {ok, File} -> [File | A]; + _ -> A + end + end, + foldl(BFun, [], to_external(UM)); + false -> + Libraries = dict:to_list(LibDict), + Lb = restriction(a_function(Libraries), UM), + MFun = fun({M,XLib}) -> + #xref_lib{dir = Dir} = XLib, + xref_utils:module_filename(Dir, M) + end, + map(MFun, to_external(Lb)) + end, + Fun = fun(FileName, Deprs) -> + case beam_lib:chunks(FileName, [exports, attributes]) of + {ok, {M, [{exports,X}, {attributes,A}]}} -> + Exports = mfa_exports(X, A, M), + %% No warnings for bad attributes... + {Deprecated,_Bad} = deprecated(A, Exports, M), + {{M,Exports}, [{M,Deprecated} | Deprs]}; + Error -> + throw(Error) + end + end, + {XL, DL} = mapfoldl(Fun, [], Fs), + LF = from_term(XL), + %% Undef is the first argument to make sure that the whole of LF + %% becomes garbage: + Lib = family_intersection(Undef, LF), + {B,_} = make_builtins(Undef), + DLib = family_union(Lib, B), + [DF_1,DF_21,DF_31,DF1] = depr_lib(4, DL, DL, [], [], DLib), + DF_2 = family_union(DF_21, DF_1), + DF_3 = family_union(DF_31, DF_2), + DF = family_union(DF1, DF_3), + U = family_difference(Undef, Lib), + {Undef, U, Lib, DF, DF_1, DF_2, DF_3}. + +depr_lib(0, _, _, LL, [], _Lib) -> + LL; +depr_lib(I, [], DL, LL, L, Lib) -> + DT = family_intersection(Lib, from_term(L)), + depr_lib(I-1, DL, DL, [DT | LL], [], Lib); +depr_lib(I, [{M,D} | Ds], DL, LL, L, Lib) -> + depr_lib(I, Ds, DL, LL, [{M,element(I, D)} | L], Lib). + +make_builtins(U0) -> + Tmp = family_to_relation(U0), + Fun2 = {external, fun({_M,{M,F,A}}) -> xref_utils:is_builtin(M, F, A) end}, + B = relation_to_family(specification(Fun2, Tmp)), + U = family_difference(U0, B), + {B, U}. + +% Returns a family that may not be defined for all modules. +user_family(R) -> + partition_family({external, fun({_MFA1, {M2,_,_}}) -> M2 end}, R). + +do_variables(State) -> + Fun = fun({Name, #xref_var{vtype = user}}, {P,U}) -> + {P,[Name | U]}; + ({Name, #xref_var{vtype = predef}}, A={P,U}) -> + case atom_to_list(Name) of + [H|_] when H>= $a, H=<$z -> A; + _Else -> {[Name | P], U} + end; + ({{tmp, V}, _}, A) -> + io:format("Bug in ~p: temporary ~p~n", [?MODULE, V]), A; + (_V, A) -> A + end, + {U,P} = foldl(Fun, {[],[]}, dict:to_list(State#xref.variables)), + {sort(P), sort(U)}. + +%% Throws away the variables derived from raw data. +take_down(S) when S#xref.variables =:= not_set_up -> + S; +take_down(S) -> + S#xref{variables = not_set_up}. + +make_query(Format, Args) -> + flatten(io_lib:format(Format, Args)). + +set_defaults([O | Os], [[V] | Vs], State) -> + NewState = set_def(O, V, State), + set_defaults(Os, Vs, NewState); +set_defaults([], [], State) -> + State. + +set_def(builtins, Value, State) -> + State#xref{builtins_default = Value}; +set_def(recurse, Value, State) -> + State#xref{recurse_default = Value}; +set_def(verbose, Value, State) -> + State#xref{verbose_default = Value}; +set_def(warnings, Value, State) -> + State#xref{warnings_default = Value}. + +option_values([Option | Options], State) -> + Default = current_default(State, Option), + [{Option, [Default,true,false]} | option_values(Options, State)]; +option_values([], _State) -> + []. + +current_default(State, builtins) -> + State#xref.builtins_default; +current_default(State, recurse) -> + State#xref.recurse_default; +current_default(State, verbose) -> + State#xref.verbose_default; +current_default(State, warnings) -> + State#xref.warnings_default. + +%% sets are used here to avoid long execution times +do_info(S, modules) -> + D = sort(dict:to_list(S#xref.modules)), + map(fun({_M,XMod}) -> mod_info(XMod) end, D); +do_info(S, applications) -> + AppMods = to_external(relation_to_family(relation(app_mods(S)))), + Sum = sum_mods(S, AppMods), + map(fun(AppSum) -> app_info(AppSum, S) end, Sum); +do_info(S, releases) -> + {RA, RRA} = rel_apps(S), + rel_apps_sums(RA, RRA, S); +do_info(S, libraries) -> + D = sort(dict:to_list(S#xref.libraries)), + map(fun({_L,XLib}) -> lib_info(XLib) end, D); +do_info(_S, I) -> + error({no_such_info, I}). + +do_info(S, Type, E) when is_atom(E) -> + do_info(S, Type, [E]); +do_info(S, modules, Modules0) when is_list(Modules0) -> + Modules = to_external(set(Modules0)), + XMods = find_info(Modules, S#xref.modules, no_such_module), + map(fun(XMod) -> mod_info(XMod) end, XMods); +do_info(S, applications, Applications) when is_list(Applications) -> + _XA = find_info(Applications, S#xref.applications, no_such_application), + AM = relation(app_mods(S)), + App = set(Applications), + AppMods_S = relation_to_family(restriction(AM, App)), + AppSums = sum_mods(S, to_external(AppMods_S)), + map(fun(AppSum) -> app_info(AppSum, S) end, AppSums); +do_info(S, releases, Releases) when is_list(Releases) -> + _XR = find_info(Releases, S#xref.releases, no_such_release), + {AR, RRA} = rel_apps(S), + AR_S = restriction(2, relation(AR), set(Releases)), + rel_apps_sums(to_external(AR_S), RRA, S); +do_info(S, libraries, Libraries0) when is_list(Libraries0) -> + Libraries = to_external(set(Libraries0)), + XLibs = find_info(Libraries, S#xref.libraries, no_such_library), + map(fun(XLib) -> lib_info(XLib) end, XLibs); +do_info(_S, I, J) when is_list(J) -> + throw_error({no_such_info, I}). + +find_info([E | Es], Dict, Error) -> + case dict:find(E, Dict) of + error -> + throw_error({Error, E}); + {ok, X} -> + [X | find_info(Es, Dict, Error)] + end; +find_info([], _Dict, _Error) -> + []. + +%% -> {[{AppName, RelName}], [{RelName, XApp}]} +rel_apps(S) -> + D = sort(dict:to_list(S#xref.applications)), + Fun = fun({_A, XApp}, Acc={AR, RRA}) -> + case XApp#xref_app.rel_name of + [] -> Acc; + [R] -> + AppName = XApp#xref_app.name, + {[{AppName, R} | AR], [{R, XApp} | RRA]} + end + end, + foldl(Fun, {[], []}, D). + +%% -> [{{RelName, [XApp]}, Sums}] +rel_apps_sums(AR, RRA0, S) -> + AppMods = app_mods(S), % [{AppName, XMod}] + RRA1 = relation_to_family(relation(RRA0)), + RRA = inverse(substitution(1, RRA1)), + %% RRA is [{RelName,{RelName,[XApp]}}] + RelMods = relative_product1(relation(AR), relation(AppMods)), + RelAppsMods = relative_product1(RRA, RelMods), + RelsAppsMods = to_external(relation_to_family(RelAppsMods)), + %% [{{RelName, [XApp]}, [XMod]}] + Sum = sum_mods(S, RelsAppsMods), + map(fun(RelAppsSums) -> rel_info(RelAppsSums, S) end, Sum). + +%% -> [{AppName, XMod}] +app_mods(S) -> + D = sort(dict:to_list(S#xref.modules)), + Fun = fun({_M,XMod}, Acc) -> + case XMod#xref_mod.app_name of + [] -> Acc; + [AppName] -> [{AppName, XMod} | Acc] + end + end, + foldl(Fun, [], D). + +mod_info(XMod) -> + #xref_mod{name = M, app_name = AppName, builtins = BuiltIns, + dir = Dir, info = Info} = XMod, + App = sup_info(AppName), + {M, [{application, App}, {builtins, BuiltIns}, {directory, Dir} | Info]}. + +app_info({AppName, ModSums}, S) -> + XApp = dict:fetch(AppName, S#xref.applications), + #xref_app{rel_name = RelName, vsn = Vsn, dir = Dir} = XApp, + Release = sup_info(RelName), + {AppName, [{directory,Dir}, {release, Release}, {version,Vsn} | ModSums]}. + +rel_info({{RelName, XApps}, ModSums}, S) -> + NoApps = length(XApps), + XRel = dict:fetch(RelName, S#xref.releases), + Dir = XRel#xref_rel.dir, + {RelName, [{directory, Dir}, {no_applications, NoApps} | ModSums]}. + +lib_info(XLib) -> + #xref_lib{name = LibName, dir = Dir} = XLib, + {LibName, [{directory,Dir}]}. + +sup_info([]) -> []; +sup_info([Name]) -> + [Name]. + +sum_mods(S, AppsMods) -> + sum_mods(S, AppsMods, []). + +sum_mods(S, [{N, XMods} | NX], L) -> + sum_mods(S, NX, [{N, no_sum(S, XMods)} | L]); +sum_mods(_S, [], L) -> + reverse(L). + +no_sum(S, L) when S#xref.mode =:= functions -> + no_sum(L, 0, 0, 0, 0, 0, 0, 0, 0, length(L)); +no_sum(S, L) when S#xref.mode =:= modules -> + [{no_analyzed_modules, length(L)}]. + +no_sum([XMod | D], C0, UC0, LC0, XC0, UFC0, L0, X0, EV0, NoM) -> + [{no_calls, {C,UC}}, + {no_function_calls, {LC,XC,UFC}}, + {no_functions, {L,X}}, + {no_inter_function_calls, EV}] = XMod#xref_mod.info, + no_sum(D, C0+C, UC0+UC, LC0+LC, XC0+XC, UFC0+UFC, L0+L, X0+X, EV0+EV, NoM); +no_sum([], C, UC, LC, XC, UFC, L, X, EV, NoM) -> + [{no_analyzed_modules, NoM}, + {no_calls, {C,UC}}, + {no_function_calls, {LC,XC,UFC}}, + {no_functions, {L,X}}, + {no_inter_function_calls, EV}]. + +%% -> ok | throw(Error) +is_filename(F) when is_atom(F) -> + ok; +is_filename(F) -> + case xref_utils:is_string(F, 31) of + true -> + ok; + false -> + throw_error({invalid_filename, F}) + end. + +module_file(XMod) -> + xref_utils:module_filename(XMod#xref_mod.dir, XMod#xref_mod.name). + +warnings(_Flag, _Message, []) -> true; +warnings(Flag, Message, [F | Fs]) -> + message(Flag, Message, F), + warnings(Flag, Message, Fs). + +%% pack(term()) -> term() +%% +%% The identify function. The returned term does not use more heap +%% than the given term. Tuples that are equal (=:=/2) are made +%% "the same". +%% +%% The process dictionary is used because it seems to be faster than +%% anything else right now... +%% +%pack(T) -> T; +pack(T) -> + PD = erase(), + NT = pack1(T), + %% true = T =:= NT, + %% io:format("erasing ~p elements...~n", [length(erase())]), + erase(), % wasting heap (and time)... + map(fun({K,V}) -> put(K, V) end, PD), + NT. + +pack1(C) when not is_tuple(C), not is_list(C) -> + C; +pack1([T | Ts]) -> + %% don't store conscells... + [pack1(T) | pack1(Ts)]; +%% Optimization. +pack1(T={Mod,Fun,_}) when is_atom(Mod), is_atom(Fun) -> % MFA + case get(T) of + undefined -> put(T, T), T; + NT -> NT + end; +pack1({C, L}) when is_list(L) -> % CallAt + {pack1(C), L}; +pack1({MFA, L}) when is_integer(L) -> % DefAt + {pack1(MFA), L}; +%% End optimization. +pack1([]) -> + []; +pack1(T) -> % when is_tuple(T) + case get(T) of + undefined -> + NT = tpack(T, tuple_size(T), []), + put(NT, NT), + NT; + NT -> + NT + end. + +tpack(_T, 0, L) -> + list_to_tuple(L); +tpack(T, I, L) -> + tpack(T, I-1, [pack1(element(I, T)) | L]). + +message(true, What, Arg) -> + case What of + reading_beam -> + io:format("~s... ", Arg); + skipped_beam -> + io:format("skipped (no debug information)~n", Arg); + no_debug_info -> + io:format("Skipping ~s (no debug information)~n", Arg); + unresolved_summary1 -> + io:format("~p: 1 unresolved call~n", Arg); + unresolved_summary -> + io:format("~p: ~p unresolved calls~n", Arg); + jam -> + io:format("Skipping ~s (probably JAM file)~n", [Arg]); + unreadable -> + io:format("Skipping ~s (unreadable)~n", [Arg]); + xref_attr -> + io:format("~s: Skipping 'xref' attribute ~w~n", Arg); + depr_attr -> + io:format("~s: Skipping 'deprecated' attribute ~w~n", Arg); + lib_search -> + io:format("Scanning library path for BEAM files... ", []); + lib_check -> + io:format("Checking library files... ", []); + set_up -> + io:format("Setting up...", Arg); + done -> + io:format("done~n", Arg); + error -> + io:format("error~n", Arg); + Else -> + io:format("~p~n", [{Else,Arg}]) + end; +message(_, _, _) -> + true. + +throw_error(Reason) -> + throw(error(Reason)). + +error(Reason) -> + {error, ?MODULE, Reason}. diff --git a/lib/tools/src/xref_compiler.erl b/lib/tools/src/xref_compiler.erl new file mode 100644 index 0000000000..67ac8c617d --- /dev/null +++ b/lib/tools/src/xref_compiler.erl @@ -0,0 +1,928 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2000-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(xref_compiler). + +-include("xref.hrl"). + +%-define(debug, true). + +-ifdef(debug). +-define(FORMAT(P, A), io:format(P, A)). +-define(CALL(F), F). +-else. +-define(FORMAT(P, A), ok). +-define(CALL(F), ok). +-endif. + +-export([compile/2]). + +-export([update_graph_counter/3]). + +-export([format_error/1]). + +-import(lists, + [concat/1, foldl/3, nthtail/2, reverse/1, sort/1, sublist/2]). + +-import(sofs, + [composite/2, difference/2, empty_set/0, from_term/1, + intersection/2, is_empty_set/1, multiple_relative_product/2, + projection/2, relation/1, relation_to_family/1, + restriction/2, substitution/2, to_external/1, union/2, + union_of_family/1]). + +%% +%% Exported functions +%% + +compile(Chars, Table) -> + case xref_scanner:scan(Chars) of + {ok, Tokens} -> + case xref_parser:parse(Tokens) of + {ok, ParseTree} -> + ?FORMAT("ParseTree ~p~n", [ParseTree]), + case catch statements(ParseTree, Table) of + E={error, _, _} -> + E; + {ok, UV, P} -> + %% User variables to be. + Table1 = user_vars(UV, Table), + ?CALL(statistics(runtime)), + Reply = i(P, Table1), + ?CALL({_, Time} = statistics(runtime)), + ?FORMAT("Result in ~p ms~n",[Time]), + Reply + end; + {error, {Line, _Module, Error}} -> + error({parse_error, Line, Error}) + end; + {error, Info, Line} -> + error({parse_error, Line, Info}) + end. + +format_error({error, Module, Error}) -> + Module:format_error(Error); +format_error({parse_error, Line, Error}) -> + format_parse_error(Error, format_line(Line)); +format_error({variable_reassigned, Expr}) -> + io_lib:format("Variable assigned more than once: ~s~n", [Expr]); +format_error({unknown_variable, Name}) -> + io_lib:format("Variable ~p used before set~n", [Name]); +format_error({type_error, Expr}) -> + io_lib:format("Operator applied to argument(s) of different or " + "invalid type(s): ~s~n", [Expr]); +format_error({type_mismatch, Expr1, Expr2}) -> + io_lib:format("Constants of different types: ~s, ~s~n", + [Expr1, Expr2]); +format_error({unknown_constant, Constant}) -> + io_lib:format("Unknown constant ~s~n", [Constant]); +format_error(E) -> + io_lib:format("~p~n", [E]). + +%% +%% Local functions +%% + +user_vars([{{user,Name}, Val} | UV], Table) -> + user_vars(UV, dict:store(Name, Val, Table)); +user_vars([_V | UV], Table) -> + user_vars(UV, Table); +user_vars([], Table) -> + Table. + +statements(Stmts, Table) -> + statements(Stmts, Table, [], []). + +statements([Stmt={assign, VarType, Name, E} | Stmts0], Table, L, UV) -> + case dict:find(Name, Table) of + {ok, _} -> + throw_error({variable_reassigned, xref_parser:t2s(Stmt)}); + error -> + {Type, OType, NewE} = t_expr(E, Table), + Val = #xref_var{name = Name, vtype = VarType, + otype = OType, type = Type}, + NewTable = dict:store(Name, Val, Table), + Stmts = if Stmts0 =:= [] -> [{variable, Name}]; true -> Stmts0 end, + Variable = {VarType, Name}, + Put = {put, Variable, NewE}, + statements(Stmts, NewTable, [Put | L], [{Variable,Val} | UV]) + end; +statements([Expr], Table, L, UV) -> + {Type, OType, NewE} = t_expr(Expr, Table), + E1 = un_familiarize(Type, OType, NewE), + NE = case {Type, OType} of + %% Edges with empty sets of line numbers are removed. + {{line, _}, edge} -> + {relation_to_family, E1}; + {_Type, edge_closure} -> + %% Fake a closure usage, just to make sure it is destroyed. + E2 = {fun graph_access/2, E1, E1}, + {fun(_E) -> 'closure()' end, E2}; + _Else -> E1 + end, + {ok, UV, stats(L, NE)}. + +stats([{put, V, X} | Ss], E) -> + stats(Ss, {put, V, X, E}); +stats([], E) -> + E. + +t_expr(E, Table) -> + {expr, Type, OType, E1} = check_expr(E, Table), + ?FORMAT("TExpr:~n~p~n",[E1]), + E2 = convert(E1), + ?FORMAT("After conversion:~n~p~n",[E2]), + {Type, OType, E2}. + +%%% check_expr/2 translates Expr in xref_parser.yrl into TExpr: +%%% +%%% TExpr = {expr, Type, ObjectType, Expr} +%%% Expr = {constants, [Constant]} +%%% | {variable, {VarType, VarName}} +%%% | {call, Call, Expr} +%%% | {call, Call, Expr, Expr} +%%% | {call, restriction, integer(), Expr, Expr} +%%% | {convert, ObjectType, Type, Type} +%%% | {convert, Type, Type} +%%% Constant = atom() | {atom(), atom()} | MFA | {MFA, MFA} +%%% Call = atom() % function in the sofs module +%%% | fun() +%%% Type = {line, LineType} | function | module | application | release +%%% | number +%%% LineType = line | local_call | external_call | export_call | all_line_call +%%% VarType = predef | user | tmp +%%% ObjectType = vertex | vertex_set | edge | edge_set | edge_closure | path +%%% | number +%%% MFA = {atom(), atom(), integer()} + +%% -> TExpr +check_expr({list, L}, Table) -> + check_constants(L, Table); +check_expr({tuple, L}, Table) -> + {expr, Type, vertex, _Consts} = check_constants(L, Table), + Cs = reverse(constant_vertices(L, [])), + {expr, Type, path, {constants, Cs}}; +check_expr({variable, Name}, Table) -> + case dict:find(Name, Table) of + {ok, #xref_var{vtype = VarType, otype = OType, type = Type}} -> + V0 = {variable, {VarType, Name}}, + V = case {VarType, Type, OType} of + {predef, release, _} -> V0; + {predef, application, _} -> V0; + {predef, module, _} -> V0; + {predef, function, vertex} -> V0; + {predef, function, edge} -> {call, union_of_family, V0}; + _Else -> V0 + end, + {expr, Type, OType, V}; + error -> + throw_error({unknown_variable, Name}) + end; +check_expr({type, {type, _Type}, E}, Table) -> + check_expr(E, Table); +check_expr(Expr={type, {convert, NewType0}, E}, Table) -> + NewType = what_type(NewType0), + {expr, OldType, OType, NE} = check_expr(E, Table), + ok = check_conversion(OType, OldType, NewType, Expr), + {expr, NewType, OType, {convert, OType, OldType, NewType, NE}}; +check_expr(Expr={set, SOp, E}, Table) -> + {expr, Type, OType0, E1} = check_expr(E, Table), + OType = case {OType0, SOp} of + {edge, range} -> vertex; + {edge, domain} -> vertex; + {edge, weak} -> edge; + {edge, strict} -> edge; + {edge_set, range} -> vertex_set; + {edge_set, domain} -> vertex_set; + {edge_set, weak} -> edge_set; + {edge_set, strict} -> edge_set; + _ -> + throw_error({type_error, xref_parser:t2s(Expr)}) + end, + Op = set_op(SOp), + NE = function_vertices_to_family(Type, OType, {call, Op, E1}), + {expr, Type, OType, NE}; +check_expr(Expr={graph, Op, E}, Table) -> + {expr, Type, NOType, E1} = check_expr(E, Table), + case Type of + {line, _LineType} -> + throw_error({type_error, xref_parser:t2s(Expr)}); + _Else -> + ok + end, + OType = + case {NOType, Op} of + {edge, components} -> vertex_set; + {edge, condensation} -> edge_set; + {edge, closure} -> edge_closure; + {edge_closure, components} -> vertex_set; + {edge_closure, condensation} -> edge_set; + {edge_closure, closure} -> edge_closure; + %% Neither need nor want these ones: + %% {edge_set, closure} -> edge_set_closure; + %% {edge_set, components} -> vertex_set_set; + _ -> + throw_error({type_error, xref_parser:t2s(Expr)}) + end, + E2 = {convert, NOType, edge_closure, E1}, + NE = case Op of + closure -> E2; + _Op -> use_of_closure(Op, E2) + end, + {expr, Type, OType, NE}; +check_expr(Expr={numeric, '#', E}, Table) -> + {expr, Type, OType, E1} = check_expr(E, Table), + case OType of + vertex -> ok; + vertex_set -> ok; + edge -> ok; + edge_set -> ok; + _Else -> throw_error({type_error, xref_parser:t2s(Expr)}) + end, + NE = {convert, OType, Type, number, E1}, + {expr, number, number, {call, no_elements, NE}}; +check_expr(Expr={set, SOp, E1, E2}, Table) -> + %% sets and numbers... + {expr, Type1, OType1, NE1} = check_expr(E1, Table), + {expr, Type2, OType2, NE2} = check_expr(E2, Table), + OType = case {OType1, OType2} of + {vertex, vertex} -> vertex; + {edge, edge} -> edge; + {number, number} -> number; + _ -> throw_error({type_error, xref_parser:t2s(Expr)}) + end, + case OType of + number -> + {expr, number, number, {call, ari_op(SOp), NE1, NE2}}; + _Else -> % set + {Type, NewE1, NewE2} = + case {type_ord(Type1), type_ord(Type2)} of + {T1, T2} when T1 =:= T2 -> + %% Example: if Type1 = {line, line} and + %% Type2 = {line, export_line}, then this is not + %% correct, but works: + {Type1, NE1, NE2}; + {T1, T2} when T1 < 2; T2 < 2 -> + throw_error({type_error, xref_parser:t2s(Expr)}); + {T1, T2} when T1 > T2 -> + {Type2, {convert, OType, Type1, Type2, NE1}, NE2}; + {T1, T2} when T1 < T2 -> + {Type1, NE1, {convert, OType, Type2, Type1, NE2}} + end, + Op = set_op(SOp, Type, OType), + {expr, Type, OType, {call, Op, NewE1, NewE2}} + end; +check_expr(Expr={restr, ROp, E1, E2}, Table) -> + {expr, Type1, OType1, NE1} = check_expr(E1, Table), + {expr, Type2, OType2, NE2} = check_expr(E2, Table), + case {Type1, Type2} of + {{line, _LineType1}, _Type2} -> + throw_error({type_error, xref_parser:t2s(Expr)}); + {_Type1, {line, _LineType2}} -> + throw_error({type_error, xref_parser:t2s(Expr)}); + _ -> + ok + end, + case {OType1, OType2} of + {edge, vertex} when ROp =:= '|||' -> + {expr, _, _, R1} = restriction('|', E1, Type1, NE1, Type2, NE2), + {expr, _, _, R2} = restriction('||', E1, Type1, NE1, Type2, NE2), + {expr, Type1, edge, {call, intersection, R1, R2}}; + {edge, vertex} -> + restriction(ROp, E1, Type1, NE1, Type2, NE2); + {edge_closure, vertex} when ROp =:= '|||' -> + {expr, _, _, R1} = + closure_restriction('|', Type1, Type2, OType2, NE1, NE2), + {expr, _, _, R2} = + closure_restriction('||', Type1, Type2, OType2, NE1, NE2), + {expr, Type1, edge, {call, intersection, R1, R2}}; + {edge_closure, vertex} -> + closure_restriction(ROp, Type1, Type2, OType2, NE1, NE2); + _ -> + throw_error({type_error, xref_parser:t2s(Expr)}) + end; +check_expr(Expr={path, E1, E2}, Table) -> + {expr, Type1, OType1a, E1a} = check_expr(E1, Table), + {expr, Type2, OType2, E2a} = check_expr(E2, Table), + case {Type1, Type2} of + {{line, _LineType1}, _Type2} -> + throw_error({type_error, xref_parser:t2s(Expr)}); + {_Type1, {line, _LineType2}} -> + throw_error({type_error, xref_parser:t2s(Expr)}); + _Else -> + ok + end, + E2b = {convert, OType2, Type2, Type1, E2a}, + {OType1, NE1} = path_arg(OType1a, E1a), + NE2 = case {OType1, OType2} of + {path, edge} -> {convert, OType2, edge_closure, E2b}; + {path, edge_closure} when Type1 =:= Type2 -> E2b; + _ -> throw_error({type_error, xref_parser:t2s(Expr)}) + end, + {expr, Type1, path, use_of_closure(path, NE2, NE1)}; +check_expr({regexpr, RExpr, Type0}, _Table) -> + %% Using the "universal" variables is not optimal as regards speed, + %% but it is simple... + Type = what_type(Type0), + V = case Type of + function -> v; + module -> 'M'; + application -> 'A'; + release -> 'R' + end, + Var = {variable, {predef, V}}, + Call = {call, fun(E, V2) -> xref_utils:regexpr(E, V2) end, + {constants, RExpr}, Var}, + {expr, Type, vertex, Call}; +check_expr(C={constant, _Type, _OType, _C}, Table) -> + check_constants([C], Table). + +path_arg(edge, E={constants, C}) -> + case to_external(C) of + [{V1,V2}] -> {path, {constants, [V1, V2]}}; + _ -> {edge, E} + end; +path_arg(OType, E) -> + {OType, E}. + +check_conversion(OType, Type1, Type2, Expr) -> + case conversions(OType, Type1, Type2) of + ok -> ok; + not_ok -> throw_error({type_error, xref_parser:t2s(Expr)}) + end. + +%% Allowed conversions. +conversions(_OType, {line, LineType}, {line, LineType}) -> ok; +conversions(edge, {line, _}, {line, all_line_call}) -> ok; +conversions(edge, From, {line, Line}) + when is_atom(From), Line =/= all_line_call -> ok; +conversions(vertex, From, {line, line}) when is_atom(From) -> ok; +conversions(vertex, From, To) when is_atom(From), is_atom(To) -> ok; +conversions(edge, From, To) when is_atom(From), is_atom(To) -> ok; +%% "Extra": +conversions(edge, {line, Line}, To) + when is_atom(To), Line =/= all_line_call -> ok; +conversions(vertex, {line, line}, To) when is_atom(To) -> ok; +conversions(_OType, _From, _To) -> not_ok. + +set_op(union, {line, _LineType}, edge) -> family_union; +set_op(intersection, {line, _LineType}, edge) -> family_intersection; +set_op(difference, {line, _LineType}, edge) -> family_difference; +set_op(union, function, vertex) -> family_union; +set_op(intersection, function, vertex) -> family_intersection; +set_op(difference, function, vertex) -> family_difference; +set_op(SOp, _Type, _OType) -> SOp. + +set_op(weak) -> weak_relation; +set_op(strict) -> strict_relation; +set_op(Op) -> Op. + +ari_op(union) -> fun(X, Y) -> X + Y end; +ari_op(intersection) -> fun(X, Y) -> X * Y end; +ari_op(difference) -> fun(X, Y) -> X - Y end. + +restriction(ROp, E1, Type1, NE1, Type2, NE2) -> + {Column, _} = restr_op(ROp), + case NE1 of + {call, union_of_family, _E} when ROp =:= '|' -> + restriction(Column, Type1, E1, Type2, NE2); + {call, union_of_family, _E} when ROp =:= '||' -> + E1p = {inverse, E1}, + restriction(Column, Type1, E1p, Type2, NE2); + _ -> + NE2a = {convert, vertex, Type2, Type1, NE2}, + NE2b = family_to_function_vertices(Type1, vertex, NE2a), + {expr, Type1, edge, {call, restriction, Column, NE1, NE2b}} + end. + +restriction(Column, Type1, VE, Type2, E2) when Type1 =:= function -> + M = {convert, vertex, Type2, module, E2}, + Restr = {call, union_of_family, {call, restriction, VE, M}}, + C = {convert, vertex, Type2, Type1, E2}, + F = family_to_function_vertices(Type1, vertex, C), + {expr, Type1, edge, {call, restriction, Column, Restr, F}}. + +closure_restriction(Op, Type1, Type2, OType2, E1, E2) -> + {_, Fun} = restr_op(Op), + E2a = {convert, OType2, Type2, Type1, E2}, + E2b = family_to_function_vertices(Type1, vertex, E2a), + {expr, Type1, edge, use_of_closure(Fun, E1, E2b)}. + +restr_op('|') -> {1, call}; +restr_op('||') -> {2, use}. + +%% Closures (digraphs) must be deleted, but not too soon. A wrapper +%% is inserted here for every use of a closure, to make sure that a +%% 'save' and an 'unput' instruction are inserted for every digraph, in +%% particular the temporary ones. The 'unput' instruction must occur +%% _after_ the call to the function that uses the digraph (the default +%% is that it is inserted _before_ the call). +use_of_closure(Op, C) -> + access_of_closure(C, {call, fun(X) -> xref_utils:Op(X) end, C}). + +use_of_closure(Op, C, E) -> + access_of_closure(C, {call, fun(X, Y) -> xref_utils:Op(X, Y) end, C, E}). + +access_of_closure(C, E) -> + {call, fun graph_access/2, C, E}. + +check_constants(Cs=[C={constant, Type0, OType, _Con} | Cs1], Table) -> + check_mix(Cs1, Type0, OType, C), + Types = case Type0 of + unknown -> ['Rel', 'App', 'Mod']; + T -> [T] + end, + case split(Types, Cs, Table) of + [{TypeToBe, _Cs}] -> + S = from_term([Con || {constant, _T, _OT, Con} <- Cs]), + Type = what_type(TypeToBe), + E = function_vertices_to_family(Type, OType, {constants, S}), + {expr, Type, OType, E}; + [{Type1, [C1|_]}, {Type2, [C2|_]} | _] -> + throw_error({type_mismatch, + make_vertex(Type1, C1), + make_vertex(Type2, C2)}) + end. + +check_mix([C={constant, 'Fun', OType, _Con} | Cs], 'Fun', OType, _C0) -> + check_mix(Cs, 'Fun', OType, C); +check_mix([C={constant, Type, OType, _Con} | Cs], Type0, OType, _C0) + when Type =/= 'Fun', Type0 =/= 'Fun' -> + check_mix(Cs, Type, OType, C); +check_mix([C | _], _Type0, _OType0, C0) -> + throw_error({type_mismatch, xref_parser:t2s(C0), xref_parser:t2s(C)}); +check_mix([], _Type0, _OType0, _C0) -> + ok. + +split(Types, Cs, Table) -> + Vs = from_term(constant_vertices(Cs, [])), + split(Types, Vs, empty_set(), unknown, Table, []). + +split([Type | Types], Vs, AllSoFar, _Type, Table, L) -> + S0 = known_vertices(Type, Vs, Table), + S = difference(S0, AllSoFar), + case is_empty_set(S) of + true -> + split(Types, Vs, AllSoFar, Type, Table, L); + false -> + All = union(AllSoFar, S0), + split(Types, Vs, All, Type, Table, + [{Type, to_external(S)} | L]) + end; +split([], Vs, All, Type, _Table, L) -> + case to_external(difference(Vs, All)) of + [] -> L; + [C|_] -> throw_error({unknown_constant, make_vertex(Type, C)}) + end. + +make_vertex(Type, C) -> + xref_parser:t2s({constant, Type, vertex, C}). + +constant_vertices([{constant, _Type, edge, {A,B}} | Cs], L) -> + constant_vertices(Cs, [A, B | L]); +constant_vertices([{constant, _Type, vertex, V} | Cs], L) -> + constant_vertices(Cs, [V | L]); +constant_vertices([], L) -> + L. + +known_vertices('Fun', Cs, T) -> + M = projection(1, Cs), + F = union_of_family(restriction(fetch_value(v, T), M)), + intersection(Cs, F); +known_vertices('Mod', Cs, T) -> + intersection(Cs, fetch_value('M', T)); +known_vertices('App', Cs, T) -> + intersection(Cs, fetch_value('A', T)); +known_vertices('Rel', Cs, T) -> + intersection(Cs, fetch_value('R', T)). + +function_vertices_to_family(function, vertex, E) -> + {call, partition_family, 1, E}; +function_vertices_to_family(_Type, _OType, E) -> + E. + +family_to_function_vertices(function, vertex, E) -> + {call, union_of_family, E}; +family_to_function_vertices(_Type, _OType, E) -> + E. + +-define(Q(E), {quote, E}). + +convert({inverse, {variable, Variable}}) -> + {get, {inverse, var_name(Variable)}}; +convert({variable, Variable}) -> + {get, var_name(Variable)}; +convert({convert, FromOType, ToOType, E}) -> + convert(convert(E), FromOType, ToOType); +convert({convert, OType, FromType, ToType, E}) -> + convert(convert(E), OType, FromType, ToType); +convert({call, Op, E}) -> + {Op, convert(E)}; +convert({call, Op, E1, E2}) -> + {Op, convert(E1), convert(E2)}; +convert({call, Op, E1, E2, E3}) -> + {Op, convert(E1), convert(E2), convert(E3)}; +convert({constants, Constants}) -> + ?Q(Constants); +convert(I) when is_integer(I) -> + ?Q(I). + +var_name({predef, VarName}) -> VarName; +var_name(Variable) -> Variable. + +convert(E, OType, OType) -> + E; +convert(E, edge, edge_closure) -> + {fun(S) -> xref_utils:closure(S) end, E}. + +convert(E, OType, FromType, number) -> + un_familiarize(FromType, OType, E); +convert(E, OType, FromType, ToType) -> + case {type_ord(FromType), type_ord(ToType)} of + {FT, To} when FT =:= To -> + E; + {FT, ToT} when FT > ToT -> + special(OType, FromType, ToType, E); + {FT, ToT} when FT < ToT -> + general(OType, FromType, ToType, E) + end. + +-define(T(V), {tmp, V}). + +general(_ObjectType, FromType, ToType, X) when FromType =:= ToType -> + X; +general(edge, {line, _LineType}, ToType, LEs) -> + VEs = {projection, ?Q({external, fun({V1V2,_Ls}) -> V1V2 end}), LEs}, + general(edge, function, ToType, VEs); +general(edge, function, ToType, VEs) -> + MEs = {projection, + ?Q({external, fun({{M1,_,_},{M2,_,_}}) -> {M1,M2} end}), + VEs}, + general(edge, module, ToType, MEs); +general(edge, module, ToType, MEs) -> + AEs = {image, {get, me2ae}, MEs}, + general(edge, application, ToType, AEs); +general(edge, application, release, AEs) -> + {image, {get, ae}, AEs}; +general(vertex, {line, _LineType}, ToType, L) -> + V = {partition_family, ?Q(1), {domain, L}}, + general(vertex, function, ToType, V); +general(vertex, function, ToType, V) -> + M = {domain, V}, + general(vertex, module, ToType, M); +general(vertex, module, ToType, M) -> + A = {image, {get, m2a}, M}, + general(vertex, application, ToType, A); +general(vertex, application, release, A) -> + {image, {get, a2r}, A}. + +special(_ObjectType, FromType, ToType, X) when FromType =:= ToType -> + X; +special(edge, {line, _LineType}, {line, all_line_call}, Calls) -> + {put, ?T(mods), + {projection, + ?Q({external, fun({{{M1,_,_},{M2,_,_}},_}) -> {M1,M2} end}), + Calls}, + {put, ?T(def_at), + {union, {image, {get, def_at}, + {union, {domain, {get, ?T(mods)}}, + {range, {get, ?T(mods)}}}}}, + {fun funs_to_lines/2, + {get, ?T(def_at)}, Calls}}}; +special(edge, function, {line, LineType}, VEs) -> + Var = if + LineType =:= line -> call_at; + LineType =:= export_call -> e_call_at; + LineType =:= local_call -> l_call_at; + LineType =:= external_call -> x_call_at + end, + line_edges(VEs, Var); +special(edge, module, ToType, MEs) -> + VEs = {image, + {projection, + ?Q({external, fun(FE={{M1,_,_},{M2,_,_}}) -> {{M1,M2},FE} end}), + {union, + {image, {get, e}, + {projection, ?Q({external, fun({M1,_M2}) -> M1 end}), MEs}}}}, + MEs}, + special(edge, function, ToType, VEs); +special(edge, application, ToType, AEs) -> + MEs = {inverse_image, {get, me2ae}, AEs}, + special(edge, module, ToType, MEs); +special(edge, release, ToType, REs) -> + AEs = {inverse_image, {get, ae}, REs}, + special(edge, application, ToType, AEs); +special(vertex, function, {line, _LineType}, V) -> + {restriction, + {union_of_family, {restriction, {get, def_at}, {domain, V}}}, + {union_of_family, V}}; +special(vertex, module, ToType, M) -> + V = {restriction, {get, v}, M}, + special(vertex, function, ToType, V); +special(vertex, application, ToType, A) -> + M = {inverse_image, {get, m2a}, A}, + special(vertex, module, ToType, M); +special(vertex, release, ToType, R) -> + A = {inverse_image, {get, a2r}, R}, + special(vertex, application, ToType, A). + +line_edges(VEs, CallAt) -> + {put, ?T(ves), VEs, + {put, ?T(m1), + {projection, ?Q({external, fun({{M1,_,_},_}) -> M1 end}), + {get, ?T(ves)}}, + {image, {projection, ?Q({external, fun(C={VV,_L}) -> {VV,C} end}), + {union, {image, {get, CallAt}, {get, ?T(m1)}}}}, + {get, ?T(ves)}}}}. + +%% {(((v1,l1),(v2,l2)),l) : +%% (v1,l1) in DefAt and (v2,l2) in DefAt and ((v1,v2),L) in CallAt} +funs_to_lines(DefAt, CallAt) -> + T1 = multiple_relative_product({DefAt, DefAt}, projection(1, CallAt)), + T2 = composite(substitution(1, T1), CallAt), + Fun = fun({{{V1,V2},{L1,L2}},Ls}) -> {{{V1,L1},{V2,L2}},Ls} end, + projection({external, Fun}, T2). + +what_type('Rel') -> release; +what_type('App') -> application; +what_type('Mod') -> module; +what_type('Fun') -> function; +what_type('Lin') -> {line, line}; +what_type('LLin') -> {line, local_call}; +what_type('XLin') -> {line, external_call}; +what_type('ELin') -> {line, export_call}; +what_type('XXL') -> {line, all_line_call}. + +type_ord({line, all_line_call}) -> 0; +type_ord({line, _LT}) -> 1; +type_ord(function) -> 2; +type_ord(module) -> 3; +type_ord(application) -> 4; +type_ord(release) -> 5. + +%% While evaluating, sets of vertices are represented as families. +%% Sets of edges are not families, but plain sets (this might change). +%% Calls (with line numbers) are "straightened" out here, but will be +%% families again shortly, unless just counted. +un_familiarize(function, vertex, E) -> + {union_of_family, E}; +un_familiarize({line, _}, edge, E) -> + {family_to_relation, E}; +un_familiarize(_Type, _OType, E) -> + E. + +%% Expressions are evaluated using a stack and tail recursion. +%% Common subexpressions are evaluated once only, using a table for +%% storing temporary results. +%% (Using a table _and_ a stack is perhaps not a very good way of +%% doing things.) +i(E, Table) -> + Start = 1, + {N, _NE, _NI, NT} = find_nodes(E, Start, dict:new()), + {Vs, UVs0, L} = save_vars(dict:to_list(NT), NT, [], [], []), + + VarsToSave = to_external(relation_to_family(relation(Vs))), + Fun = fun({NN,S}, D) -> + dict:store(NN, {extra,S,dict:fetch(NN, D)}, D) + end, + D = foldl(Fun, dict:from_list(L), VarsToSave), + + UVs = reverse(sort(UVs0)), + {_D, Is0} = make_instructions(N, UVs, D), + Is = insert_unput(Is0), + ?FORMAT("Instructions:~n~p~n~n~n", [Is]), + %% Well, compiles _and_ evaluates... + evaluate(Is, Table, []). + +%% Traverses the expression tree in postorder, giving a unique number +%% to each node. A table is created, and common subexpressions found. +find_nodes(E={quote,_}, I, T) -> + find_node(E, I, T); +find_nodes({get, Var}, I, T) -> + find_node({var,Var}, I, T); +find_nodes({put, Var, E1, E2}, I, T) -> + {_NE1_N, NE1, I1, T1} = find_nodes(E1, I, T), + %% Now NE1 is considered used once, which is wrong. Fixed below. + NT = dict:store({var, Var}, NE1, T1), + find_nodes(E2, I1, NT); +find_nodes(Tuple, I, T) when is_tuple(Tuple) -> + [Tag0 | L] = tuple_to_list(Tuple), + Fun = fun(A, {L0, I0, T0}) -> + {NA, _E, NI, NT} = find_nodes(A, I0, T0), + {[NA | L0], NI, NT} + end, + {NL, NI, T1} = foldl(Fun, {[], I, T}, L), + Tag = case Tag0 of + _ when is_function(Tag0) -> Tag0; + _ when is_atom(Tag0) -> {sofs, Tag0} + end, + find_node({apply, Tag, NL}, NI, T1). + +find_node(E, I, T) -> + case dict:find(E, T) of + {ok, {reuse, N}} -> + {N, E, I, T}; + {ok, N} when is_integer(N) -> + {N, E, I, dict:store(E, {reuse, N}, T)}; + {ok, E1} -> + find_node(E1, I, T); + error -> + {I, E, I+1, dict:store(E, I, T)} + end. + +%% Creates save instructions for those values (stored on the stack while +%% evaluating) that are to be used after the result has been popped. +save_vars([{I, {reuse,N}} | DL], D, Vs, UVs, L) -> + save_vars(DL, D, [{N, {save, {tmp, N}}} | Vs], UVs, [{N, I} | L]); +save_vars([{I, N} | DL], D, Vs, UVs, L) when is_integer(N) -> + save_vars(DL, D, Vs, UVs, [{N, I} | L]); +save_vars([{{var,V={user,_}}, I} | DL], D, Vs, UVs, L) -> + N = case dict:fetch(I, D) of + {reuse, N0} -> N0; + N0 -> N0 + end, + save_vars(DL, D, [{N, {save, V}} | Vs], [N | UVs], L); +save_vars([{{var,{tmp,_}}, _I} | DL], D, Vs, UVs, L) -> + save_vars(DL, D, Vs, UVs, L); +save_vars([], _D, Vs, UVs, L) -> + {Vs, UVs, L}. + +%% Traverses the expression again, this time using more or less the +%% inverse of the table created by find_nodes. The first time a node +%% is visited, its children are traversed, the following times a +%% get instructions are inserted (using the saved value). +make_instructions(N, UserVars, D) -> + {D1, Is0} = make_instrs(N, D, []), + %% Assignments the results of which are not used by the final + %% expression are handled here. Instructions are created for user + %% variables only (assignment of a closure is handled properly + %% without further action). + make_more_instrs(UserVars, D1, Is0). + +make_more_instrs([UV | UVs], D, Is) -> + case dict:find(UV, D) of + error -> + make_more_instrs(UVs, D, Is); + _Else -> + {ND, NIs} = make_instrs(UV, D, Is), + make_more_instrs(UVs, ND, [pop | NIs]) + end; +make_more_instrs([], D, Is) -> + {D, Is}. + +make_instrs(N, D, Is) -> + case dict:find(N, D) of + {ok, {extra, Save, Val}} -> + {D1, Is1} = make_instr(Val, D, Is), + {dict:erase(N, D1), Save ++ Is1}; + {ok, Val} -> + {D1, Is1} = make_instr(Val, D, Is), + {dict:erase(N, D1), Is1}; + error -> + {D, [{get, {tmp, N}} | Is]} + end. + +make_instr({var, V}, D, Is) -> + {D, [{get, V} | Is]}; +make_instr(Q = {quote, _T}, D, Is) -> + {D, [Q | Is]}; +make_instr({apply, MF, Ns}, D, Is) -> + Fun = fun(N, {D0, Is0}) -> make_instrs(N, D0, Is0) end, + {D1, Is1} = foldl(Fun, {D, Is}, Ns), + {D1, [{apply, MF, length(Ns)} | Is1]}. + +%% Makes sure that temporary results are removed from the table as soon +%% as they are no longer needed. +%% Assignments may create extra save instructions, which are removed here. +insert_unput(L) -> + insert_unput(L, dict:new(), []). + +insert_unput([I={get, V={tmp, _}} | Is], D, L) -> + case dict:find(V, D) of + {ok, _} -> insert_unput(Is, D, [I | L]); + error -> insert_unput(Is, dict:store(V, [], D), [I, {unput, V} | L]) + end; +insert_unput([I={save, V={tmp,_}} | Is], D, L) -> + case dict:find(V, D) of + {ok, _} -> + insert_unput(Is, dict:erase(V, D), [I | L]); + error -> + %% Extra save removed. + insert_unput(Is, dict:erase(V, D), L) + end; +insert_unput([I | Is], D, L) -> + insert_unput(Is, D, [I | L]); +insert_unput([], _D, L) -> + L. + +graph_access(_G, V) -> + %% _G may have been deleted by an unput already + V. + +evaluate([{apply, MF, NoAs} | P], T, S) -> + Args = sublist(S, NoAs), + NewS = nthtail(NoAs, S), + ?FORMAT("Applying ~p/~p~n", [MF,NoAs]), + evaluate(P, T, [apply(MF, Args) | NewS]); +evaluate([{quote, Val} | P], T, S) -> + evaluate(P, T, [Val | S]); +evaluate([{get, Var} | P], T, S) when is_atom(Var) -> % predefined + Value = fetch_value(Var, T), + Val = case Value of + {R, _} -> R; % relation + _ -> Value % simple set + end, + evaluate(P, T, [Val | S]); +evaluate([{get, {inverse, Var}} | P], T, S) -> % predefined, inverse + {_, R} = fetch_value(Var, T), + evaluate(P, T, [R | S]); +evaluate([{get, {user, Var}} | P], T, S) -> + Val = fetch_value(Var, T), + evaluate(P, T, [Val | S]); +evaluate([{get, Var} | P], T, S) -> % tmp + evaluate(P, T, [dict:fetch(Var, T) | S]); +evaluate([{save, Var={tmp, _}} | P], T, S=[Val | _]) -> + T1 = update_graph_counter(Val, +1, T), + evaluate(P, dict:store(Var, Val, T1), S); +evaluate([{save, {user, Name}} | P], T, S=[Val | _]) -> + #xref_var{vtype = user, otype = OType, type = Type} = dict:fetch(Name, T), + NewVar = #xref_var{name = Name, value = Val, + vtype = user, otype = OType, type = Type}, + T1 = update_graph_counter(Val, +1, T), + NT = dict:store(Name, NewVar, T1), + evaluate(P, NT, S); +evaluate([{unput, Var} | P], T, S) -> + T1 = update_graph_counter(dict:fetch(Var, T), -1, T), + evaluate(P, dict:erase(Var, T1), S); +evaluate([pop | P], T, [_ | S]) -> + evaluate(P, T, S); +evaluate([], T, [R]) -> + {T, R}. + +%% (PossibleGraph, 1 | -1, dict()) -> dict() +%% Use the same table for everything... Here: Reference counters for digraphs. +update_graph_counter(Value, Inc, T) -> + case catch digraph:info(Value) of + Info when is_list(Info) -> + case dict:find(Value, T) of + {ok, 1} when Inc =:= -1 -> + true = digraph:delete(Value), + dict:erase(Value, T); + {ok, C} -> + dict:store(Value, C+Inc, T); + error when Inc =:= 1 -> + dict:store(Value, 1, T) + end; + _EXIT -> + T + end. + +fetch_value(V, D) -> + #xref_var{value = Value} = dict:fetch(V, D), + Value. + +format_parse_error(["invalid_regexp", String, Error], Line) -> + io_lib:format("Invalid regular expression \"~s\"~s: ~s~n", + [String, Line, lists:flatten(Error)]); +format_parse_error(["invalid_regexp_variable", Var], Line) -> + io_lib:format("Invalid wildcard variable ~p~s " + "(only '_' is allowed)~n", [Var, Line]); +format_parse_error(["missing_type", Expr], Line) -> + io_lib:format("Missing type of regular expression ~s~s~n", + [Expr, Line]); +format_parse_error(["type_mismatch", Expr], Line) -> + io_lib:format("Type does not match structure of constant~s: ~s~n", + [Line, Expr]); +format_parse_error(["invalid_operator", Op], Line) -> + io_lib:format("Invalid operator ~p~s~n", [Op, Line]); +format_parse_error(Error, Line) -> + io_lib:format("Parse error~s: ~s~n", [Line, lists:flatten(Error)]). + +format_line(-1) -> + " at end of string"; +format_line(0) -> + ""; +format_line(Line) when is_integer(Line) -> + concat([" on line ", Line]). + +throw_error(Reason) -> + throw(error(Reason)). + +error(Reason) -> + {error, ?MODULE, Reason}. diff --git a/lib/tools/src/xref_parser.yrl b/lib/tools/src/xref_parser.yrl new file mode 100644 index 0000000000..e23dce1dec --- /dev/null +++ b/lib/tools/src/xref_parser.yrl @@ -0,0 +1,303 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2000-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% +%% + +Nonterminals +xref statements statement expr constants constant const +assign_op prefix_op add_op mult_op count_op restr_op path_op cast_op +regexp regatom regint regvar regstr +variable id type. + +Terminals +edge vertex var atom decl cast 'of' string integer +'(' ')' '[' ']' ',' '+' '-' '*' '|' '||' '|||' '=' ':=' '#' '{' '}' ':' '/'. + +Rootsymbol xref. + +Endsymbol '$end'. + +xref -> statements : '$1'. + +assign_op -> '=' : tmp. +assign_op -> ':=' : user. +add_op -> '+' : union. +add_op -> '-' : difference. +mult_op -> '*' : intersection. +count_op -> '#' : '#'. +restr_op -> '|' : '|'. +restr_op -> '||' : '||'. +restr_op -> '|||' : '|||'. +path_op -> 'of' : 'of'. +cast_op -> '(' cast ')' : value_of('$2'). +prefix_op -> id : '$1'. + +Left 200 add_op. +Left 300 mult_op. +Left 400 count_op. +Left 500 restr_op. +Left 600 path_op. +Unary 700 cast_op. +Unary 700 prefix_op. + +statements -> statement : ['$1']. +statements -> expr : ['$1']. +statements -> statement ',' statements : ['$1' | '$3']. + +statement -> variable assign_op expr : {assign, '$2', '$1', '$3'}. + +expr -> '[' constant constants ']' type : type({list, ['$2' | '$3']}, '$5'). +expr -> '{' constant constants '}' type : type({tuple, ['$2' | '$3']}, '$5'). +expr -> constant type : type('$1', '$2'). +expr -> variable : {variable, '$1'}. +expr -> expr add_op expr : {set, '$2', '$1', '$3'}. +expr -> expr mult_op expr : {set, '$2', '$1', '$3'}. +expr -> count_op expr : prefix('$1', '$2'). +expr -> expr restr_op expr : {restr, '$2', '$1', '$3'}. +expr -> expr path_op expr : {path, '$1', '$3'}. +expr -> cast_op expr : {type, {convert, '$1'}, '$2'}. +expr -> prefix_op expr : prefix('$1', '$2'). +expr -> regexp : '$1'. +expr -> '(' expr ')' : '$2'. + +constants -> '$empty' : []. +constants -> ',' constant constants : ['$2' | '$3']. + +constant -> const : '$1'. + +const -> id : {constant, unknown, vertex, '$1'}. +const -> edge : value_of('$1'). +const -> vertex : value_of('$1'). + +regexp -> regstr type : regexp(atom, '$1', '$2'). +regexp -> regatom ':' regatom '/' regint type : + regexp(func, {'$1', '$3', '$5'}, '$6'). + +regatom -> regstr : '$1'. +regatom -> id : {atom, '$1'}. +regatom -> regvar : '$1'. + +regint -> regstr : '$1'. +regint -> integer : {integer, value_of('$1')}. +regint -> regvar : '$1'. + +regstr -> string : check_regexp(value_of('$1')). +regvar -> variable : check_regexp_variable('$1'). + +id -> atom : value_of('$1'). +variable -> var : value_of('$1'). + +type -> decl : value_of('$1'). +type -> '$empty' : unknown. + +Erlang code. + +-export([t2s/1]). + +-import(lists, [concat/1, flatten/1]). + +%%% Syntax of the parse tree: +%%% Start = [Statement] +%%% Statement = {assign, AOp, VarName, Expr} +%%% | Expr +%%% AOp = tmp | user +%%% Expr = Constants | Variable | Unary | Binary | RegExpr +%%% Constants = {list, [Constant]} % not empty list +%%% | {tuple, [Constant]} +%%% | Constant % only to avoid [ and ] in error messages... +%%% Constant = {constant, 'Fun', vertex, MFA} | +%%% {constant, AtomType, vertex, atom()} | +%%% {constant, 'Fun', edge, {MFA, MFA}} | +%%% {constant, AtomType, edge, {atom(), atom()}} +%%% Variable = {variable, VarName} +%%% VarName = atom() +%%% Unary = {set, SetUOp, Expr} +%%% | {graph, GraphUOp, Expr} +%%% | {type, {TypeOp, Type}, Expr} +%%% | {numeric, NumOp, Expr, Expr} +%%% SetUOp = range | domain | weak | strict +%%% GraphUOp = components | condensation | closure +%%% Binary = {set, SetBOp, Expr, Expr} +%%% | {restr, RestrOp, Expr, Expr} +%%% | {path, Expr, Expr} +%%% SetBOp = union | intersection | difference +%%% RestrOp = '|' | '||' | '|||' +%%% TypeOp = type | convert +%%% NumOp = '#' +%%% RegExpr = {regexpr, RExpr, Type} +%%% RExpr = string() | {AtomReg, AtomReg, IntReg} +%%% AtomReg = string() | atom() | variable() +%%% IntReg = string() | integer() +%%% MFA = {atom(), atom(), integer()} +%%% Type = 'Rel' | 'App' | 'Mod' | 'Fun' +%%% | 'Lin' | 'LLin' | 'XLin' | 'ELin' | 'XXL' +%%% AtomType = unknown | 'Rel' | 'App' | 'Mod' + +value_of(Token) -> + element(3, Token). + +prefix(Op, Expr) -> + case is_prefix_op(Op) of + false -> + return_error(0, ["invalid_operator", Op]); + UOp -> + {UOp, Op, Expr} + end. + +is_prefix_op(range) -> set; +is_prefix_op(domain) -> set; +is_prefix_op(weak) -> set; +is_prefix_op(strict) -> set; +is_prefix_op(components) -> graph; +is_prefix_op(condensation) -> graph; +is_prefix_op(closure) -> graph; +is_prefix_op('#') -> numeric; +is_prefix_op(_) -> false. + +check_regexp(String) -> + case regexp:parse(String) of + {ok, _Expr} -> + {regexpr, String}; + {error, Reason} -> + F = regexp:format_error(Reason), + return_error(0, ["invalid_regexp", String, F]) + end. + +check_regexp_variable('_') -> + variable; +check_regexp_variable(Var) -> + return_error(0, ["invalid_regexp_variable", Var]). + +regexp(func, RExpr, unknown) -> + {regexpr, RExpr, 'Fun'}; +regexp(_, RExpr, unknown) -> + return_error(0, ["missing_type", t2s({regexpr, RExpr, unknown})]); +regexp(Kind, RExpr, Type) -> + E = {type, {type, Type}, {regexpr, RExpr, Type}}, + case Type of + 'Fun' when Kind =:= func -> E; + 'Mod' when Kind =:= atom -> E; + 'App' when Kind =:= atom -> E; + 'Rel' when Kind =:= atom -> E; + _Else -> return_error(0, ["type_mismatch", t2s(E)]) + end. + +type(Expr, unknown) -> + Expr; +type(Expr, Type) -> + {type, {type, Type}, type_constants(Expr, Type, Expr)}. + +type_constants({list, L}, Type, E) -> + {list, type_constants(L, Type, E)}; +type_constants({tuple, L}, Type, E) -> + {tuple, type_constants(L, Type, E)}; +type_constants([C | Cs], Type, E) -> + [type_constants(C, Type, E) | type_constants(Cs, Type, E)]; +type_constants([], _Type, _E) -> + []; +type_constants({constant, unknown, OType, Con}, 'Rel', _E) -> + {constant, 'Rel', OType, Con}; +type_constants({constant, unknown, OType, Con}, 'App', _E) -> + {constant, 'App', OType, Con}; +type_constants({constant, unknown, OType, Con}, 'Mod', _E) -> + {constant, 'Mod', OType, Con}; +type_constants(C={constant, Type, _OType, _Con}, Type, _E) -> + C; +type_constants(_C, Type, E) -> + return_error(0, ["type_mismatch", t2s({type, {type, Type}, E})]). + +t2s(T) -> + concat(flatten(e2s(T, 0))). + +%% Does not handle list of statements. +e2s({assign, VarType, Name, E}, P) -> + [left(P, 100), Name, name_it(VarType), e2s(E, 100), right(P, 100)]; +e2s({constant, 'Fun', vertex, MFA}, _P) -> + mfa2s(MFA); +e2s({constant, _Type, vertex, A}, _P) -> + [c2s(A)]; +e2s({constant, 'Fun', edge, {MFA1,MFA2}}, _P) -> + [mfa2s(MFA1),' -> ',mfa2s(MFA2)]; +e2s({constant, _Type, edge, {A1,A2}}, _P) -> + [c2s(A1),' -> ',c2s(A2)]; +e2s({variable, Name}, _P) -> + [Name]; +e2s({list, E}, _P) -> + ['[', e2s(E, 0), ']']; +e2s({tuple, E}, _P) -> + ['{', e2s(E, 0), '}']; +e2s({type, {convert, Type}, E}, P) -> + [left(P, 700), '(',Type,') ', e2s(E, 700), right(P, 700)]; +e2s({type, {type, Type}, E}, P) -> + [left(P, 700), e2s(E, 700), ' : ', Type, right(P, 700)]; +e2s({set, Op, E}, P) -> + [left(P, 700), name_it(Op), ' ', e2s(E, 700), right(P, 700)]; +e2s({graph, Op, E}, P) -> + [left(P, 700), name_it(Op), ' ', e2s(E, 700), right(P, 700)]; +e2s({numeric, Op, E}, P) -> + [left(P, 400), name_it(Op), ' ', e2s(E, 400), right(P, 400)]; +e2s({set, Op, E1, E2}, P) -> + P1 = prio(Op), + [left(P, P1), e2s(E1, P1),name_it(Op),e2s(E2, P1+50), right(P, P1)]; +e2s({path, E1, E2}, P) -> + P1 = 600, + [left(P, P1), e2s(E1, P1),' of ',e2s(E2, P1+50), right(P, P1)]; +e2s({regexpr, Expr={regexpr,_}, _Type}, _P) -> + [re(Expr)]; +e2s({regexpr, {M,F,A}, _Type}, _P) -> + [re(M),':',re(F),'/', re(A)]; +e2s({restr, Op, E1, E2}, P) -> + P1 = 500, + [left(P, P1), e2s(E1, P1),name_it(Op),e2s(E2, P1+50), right(P, P1)]; +e2s([], _P) -> + []; +e2s([E], P) -> + e2s(E, P); +e2s([E | Es], P) -> + [e2s(E, P),', ',e2s(Es, P)]. + +mfa2s({M,F,A}) -> + [c2s(M),':',c2s(F),'/',A]. + +c2s(C) -> + [S] = io_lib:format("~p", [C]), + list_to_atom(S). + +re(variable) -> ['_']; +re({atom, Atom}) -> [Atom]; +re({integer, Int}) -> [Int]; +re({regexpr, Str}) -> ['"',erlang:list_to_atom(Str),'"']. + +left(P1, P2) when P1 > P2 -> ['(']; +left(_P1, _P2) -> []. + +right(P1, P2) when P1 > P2 -> [')']; +right(_P1, _P2) -> []. + +prio(intersection) -> 300; +prio(difference) -> 200; +prio(union) -> 200. + +name_it(tmp) -> ' = '; +name_it(user) -> ' := '; +name_it('|') -> ' | '; +name_it('||') -> ' || '; +name_it('|||') -> ' ||| '; +name_it(union) -> ' + '; +name_it(intersection) -> ' * '; +name_it(difference) -> ' - '; +name_it(Name) -> Name. diff --git a/lib/tools/src/xref_reader.erl b/lib/tools/src/xref_reader.erl new file mode 100644 index 0000000000..db755c31d8 --- /dev/null +++ b/lib/tools/src/xref_reader.erl @@ -0,0 +1,352 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2000-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(xref_reader). + +-export([module/5]). + +-import(lists, [keysearch/3, member/2, reverse/1]). + +-record(xrefr, + {module=[], + function=[], + def_at=[], + l_call_at=[], + x_call_at=[], + el=[], + ex=[], + x=[], + df, + builtins_too=false, + is_abstr, % abstract module? + funvars=[], % records variables bound to funs + % (for coping with list comprehension) + matches=[], % records other bound variables + unresolved=[], % unresolved calls, {{mfa(),mfa()},Line} + %% experimental; -xref(FunEdge) is recognized. + lattrs=[], % local calls, {{mfa(),mfa()},Line} + xattrs=[], % external calls, -"- + battrs=[] % badly formed xref attributes, term(). + }). + +-include("xref.hrl"). + +%% sys_pre_expand has modified the forms slightly compared to what +%% erl_id_trans recognizes. + +%% The versions of the abstract code are as follows: +%% R7: abstract_v1 +%% R8: abstract_v2 + +%% -> {ok, Module, {DefAt, CallAt, LC, XC, X, Attrs}, Unresolved}} | EXIT +%% Attrs = {ALC, AXC, Bad} +%% ALC, AXC and Bad are extracted from the attribute 'xref'. An experiment. +module(Module, Forms, CollectBuiltins, X, DF) -> + Attrs = [{Attr,V} || {attribute,_Line,Attr,V} <- Forms], + IsAbstract = xref_utils:is_abstract_module(Attrs), + S = #xrefr{module = Module, builtins_too = CollectBuiltins, + is_abstr = IsAbstract, x = X, df = DF}, + forms(Forms, S). + +forms([F | Fs], S) -> + S1 = form(F, S), + forms(Fs, S1); +forms([], S) -> + #xrefr{module = M, def_at = DefAt, + l_call_at = LCallAt, x_call_at = XCallAt, + el = LC, ex = XC, x = X, df = Depr, + lattrs = AL, xattrs = AX, battrs = B, unresolved = U} = S, + Attrs = {lists:reverse(AL), lists:reverse(AX), lists:reverse(B)}, + {ok, M, {DefAt, LCallAt, XCallAt, LC, XC, X, Attrs, Depr}, U}. + +form({attribute, Line, xref, Calls}, S) -> % experimental + #xrefr{module = M, function = Fun, + lattrs = L, xattrs = X, battrs = B} = S, + attr(Calls, Line, M, Fun, L, X, B, S); +form({attribute, _Line, _Attr, _Val}, S) -> + S; +form({function, 0, 'MNEMOSYNE RULE', 1, _Clauses}, S) -> + S; +form({function, 0, 'MNEMOSYNE QUERY', 2, _Clauses}, S) -> + S; +form({function, 0, 'MNEMOSYNE RECFUNDEF', 1, _Clauses}, S) -> + S; +form({function, 0, module_info, 0, _Clauses}, S) -> + S; +form({function, 0, module_info, 1, _Clauses}, S) -> + S; +form({function, Line, Name, Arity, Clauses}, S) -> + MFA0 = {S#xrefr.module, Name, Arity}, + MFA = adjust_arity(S, MFA0), + S1 = S#xrefr{function = MFA}, + S2 = S1#xrefr{def_at = [{MFA,Line} | S#xrefr.def_at]}, + S3 = clauses(Clauses, S2), + S3#xrefr{function = []}. + +clauses(Cls, S) -> + #xrefr{funvars = FunVars, matches = Matches} = S, + clauses(Cls, FunVars, Matches, S). + +clauses([{clause, _Line, _H, G, B} | Cs], FunVars, Matches, S) -> + S1 = case S#xrefr.builtins_too of + true -> expr(G, S); + false -> S + end, + S2 = expr(B, S1), + S3 = S2#xrefr{funvars = FunVars, matches = Matches}, + clauses(Cs, S3); +clauses([], _FunVars, _Matches, S) -> + S. + +attr([E={From, To} | As], Ln, M, Fun, AL, AX, B, S) -> + case mfa(From, M) of + {_, _, MFA} when MFA =:= Fun; [] =:= Fun -> + attr(From, To, Ln, M, Fun, AL, AX, B, S, As, E); + {_, _, _} -> + attr(As, Ln, M, Fun, AL, AX, [E | B], S); + _ -> + attr(Fun, E, Ln, M, Fun, AL, AX, B, S, As, E) + end; +attr([To | As], Ln, M, Fun, AL, AX, B, S) -> + attr(Fun, To, Ln, M, Fun, AL, AX, B, S, As, To); +attr([], _Ln, _M, _Fun, AL, AX, B, S) -> + S#xrefr{lattrs = AL, xattrs = AX, battrs = B}. + +attr(From, To, Ln, M, Fun, AL, AX, B, S, As, E) -> + case {mfa(From, M), mfa(To, M)} of + {{true,_,F}, {_,external,T}} -> + attr(As, Ln, M, Fun, AL, [{{F,T},Ln} | AX], B, S); + {{true,_,F}, {_,local,T}} -> + attr(As, Ln, M, Fun, [{{F,T},Ln} | AL], AX, B, S); + _ -> attr(As, Ln, M, Fun, AL, AX, [E | B], S) + end. + +mfa({F,A}, M) when is_atom(F), is_integer(A) -> + {true, local, {M,F,A}}; +mfa(MFA={M,F,A}, M1) when is_atom(M), is_atom(F), is_integer(A) -> + {M=:=M1, external, MFA}; +mfa(_, _M) -> false. + +expr({'if', _Line, Cs}, S) -> + clauses(Cs, S); +expr({'case', _Line, E, Cs}, S) -> + S1 = expr(E, S), + clauses(Cs, S1); +expr({'receive', _Line, Cs}, S) -> + clauses(Cs, S); +expr({'receive', _Line, Cs, To, ToEs}, S) -> + S1 = expr(To, S), + S2 = expr(ToEs, S1), + clauses(Cs, S2); +expr({'try',_Line,Es,Scs,Ccs,As}, S) -> + S1 = expr(Es, S), + S2 = clauses(Scs, S1), + S3 = clauses(Ccs, S2), + expr(As, S3); +expr({call, Line, + {remote, _, {atom,_,erlang}, {atom,_,make_fun}}, + [{atom,_,Mod}, {atom,_,Fun}, {integer,_,Arity}]}, S) -> + %% Added in R10B-6. M:F/A. + expr({'fun', Line, {function, Mod, Fun, Arity}}, S); +expr({'fun', Line, {function, Mod, Name, Arity}}, S) -> + %% Added in R10B-6. M:F/A. + As = lists:duplicate(Arity, {atom, Line, foo}), + external_call(Mod, Name, As, Line, false, S); +expr({'fun', Line, {function, Name, Arity}, _Extra}, S) -> + %% Added in R8. + handle_call(local, S#xrefr.module, Name, Arity, Line, S); +expr({'fun', _Line, {clauses, Cs}, _Extra}, S) -> + clauses(Cs, S); +expr({call, Line, {atom, _, Name}, As}, S) -> + S1 = handle_call(local, S#xrefr.module, Name, length(As), Line, S), + expr(As, S1); +expr({call, Line, {remote, _Line, {atom,_,Mod}, {atom,_,Name}}, As}, S) -> + external_call(Mod, Name, As, Line, false, S); +expr({call, Line, {remote, _Line, Mod, Name}, As}, S) -> + %% Added in R8. + external_call(erlang, apply, [Mod, Name, list2term(As)], Line, true, S); +expr({call, Line, F, As}, S) -> + external_call(erlang, apply, [F, list2term(As)], Line, true, S); +expr({match, _Line, {var,_,Var}, {'fun', _, {clauses, Cs}, _Extra}}, S) -> + %% This is what is needed in R7 to avoid warnings for the functions + %% that are passed around by the "expansion" of list comprehension. + S1 = S#xrefr{funvars = [Var | S#xrefr.funvars]}, + clauses(Cs, S1); +expr({match, _Line, {var,_,Var}, E}, S) -> + %% Used for resolving code like + %% Args = [A,B], apply(m, f, Args) + S1 = S#xrefr{matches = [{Var, E} | S#xrefr.matches]}, + expr(E, S1); +expr(T, S) when is_tuple(T) -> + expr(tuple_to_list(T), S); +expr([E | Es], S) -> + expr(Es, expr(E, S)); +expr(_E, S) -> + S. + +%% Mod and Fun may not correspond to something in the abstract code, +%% which is signalled by X =:= true. +external_call(Mod, Fun, ArgsList, Line, X, S) -> + Arity = length(ArgsList), + W = case xref_utils:is_funfun(Mod, Fun, Arity) of + true when erlang =:= Mod, apply =:= Fun, 2 =:= Arity -> apply2; + true when erts_debug =:= Mod, apply =:= Fun,4 =:= Arity -> debug4; + true when erlang =:= Mod, spawn_opt =:= Fun -> Arity - 1; + true -> Arity; + false when Mod =:= erlang -> + case erl_internal:type_test(Fun, Arity) of + true -> type; + false -> false + end; + false -> false + end, + S1 = if + W =:= type; X -> + S; + true -> + handle_call(external, Mod, Fun, Arity, Line, S) + end, + case {W, ArgsList} of + {false, _} -> + expr(ArgsList, S1); + {type, _} -> + expr(ArgsList, S1); + {apply2, [{tuple, _, [M,F]}, ArgsTerm]} -> + eval_args(M, F, ArgsTerm, Line, S1, ArgsList, []); + {1, [{tuple, _, [M,F]} | R]} -> % R = [] unless spawn_opt + eval_args(M, F, list2term([]), Line, S1, ArgsList, R); + {2, [Node, {tuple, _, [M,F]} | R]} -> % R = [] unless spawn_opt + eval_args(M, F, list2term([]), Line, S1, ArgsList, [Node | R]); + {3, [M, F, ArgsTerm | R]} -> % R = [] unless spawn_opt + eval_args(M, F, ArgsTerm, Line, S1, ArgsList, R); + {4, [Node, M, F, ArgsTerm | R]} -> % R = [] unless spawn_opt + eval_args(M, F, ArgsTerm, Line, S1, ArgsList, [Node | R]); + {debug4, [M, F, ArgsTerm, _]} -> + eval_args(M, F, ArgsTerm, Line, S1, ArgsList, []); + _Else -> % apply2, 1 or 2 + check_funarg(W, ArgsList, Line, S1) + end. + +eval_args(Mod, Fun, ArgsTerm, Line, S, ArgsList, Extra) -> + {IsSimpleCall, M, F} = mod_fun(Mod, Fun), + case term2list(ArgsTerm, [], S) of + undefined -> + S1 = unresolved(M, F, -1, Line, S), + expr(ArgsList, S1); + ArgsList2 when not IsSimpleCall -> + S1 = unresolved(M, F, length(ArgsList2), Line, S), + expr(ArgsList, S1); + ArgsList2 when IsSimpleCall -> + S1 = expr(Extra, S), + external_call(M, F, ArgsList2, Line, false, S1) + end. + +mod_fun({atom,_,M1}, {atom,_,F1}) -> {true, M1, F1}; +mod_fun({atom,_,M1}, _) -> {false, M1, ?VAR_EXPR}; +mod_fun(_, {atom,_,F1}) -> {false, ?MOD_EXPR, F1}; +mod_fun(_, _) -> {false, ?MOD_EXPR, ?VAR_EXPR}. + +check_funarg(W, ArgsList, Line, S) -> + {FunArg, Args} = fun_args(W, ArgsList), + S1 = case funarg(FunArg, S) of + true -> + S; + false when is_integer(W) -> % 1 or 2 + unresolved(?MOD_EXPR, ?VAR_EXPR, 0, Line, S); + false -> % apply2 + N = case term2list(Args, [], S) of + undefined -> -1; + As -> length(As) + end, + unresolved(?MOD_EXPR, ?VAR_EXPR, N, Line, S) + end, + expr(ArgsList, S1). + +funarg({'fun', _, _Clauses, _Extra}, _S) -> true; +funarg({var, _, Var}, S) -> member(Var, S#xrefr.funvars); +funarg({call,_,{remote,_,{atom,_,erlang},{atom,_,make_fun}},_MFA}, _S) -> + %% R10B-6. M:F/A. + true; +funarg(_, _S) -> false. + +fun_args(apply2, [FunArg, Args]) -> {FunArg, Args}; +fun_args(1, [FunArg | Args]) -> {FunArg, Args}; +fun_args(2, [_Node, FunArg | Args]) -> {FunArg, Args}. + +list2term([A | As]) -> + {cons, 0, A, list2term(As)}; +list2term([]) -> + {nil, 0}. + +term2list({cons, _Line, H, T}, L, S) -> + term2list(T, [H | L], S); +term2list({nil, _Line}, L, _S) -> + reverse(L); +term2list({var, _, Var}, L, S) -> + case keysearch(Var, 1, S#xrefr.matches) of + {value, {Var, E}} -> + term2list(E, L, S); + false -> + undefined + end; +term2list(_Else, _L, _S) -> + undefined. + +unresolved(M, F, A, Line, S) -> + handle_call(external, {M,F,A}, Line, S, true). + +handle_call(Locality, Module, Name, Arity, Line, S) -> + case xref_utils:is_builtin(Module, Name, Arity) of + true when not S#xrefr.builtins_too -> S; + _Else -> + To = {Module, Name, Arity}, + handle_call(Locality, To, Line, S, false) + end. + +handle_call(_Locality, {_, 'MNEMOSYNE RULE',1}, _Line, S, _) -> S; +handle_call(_Locality, {_, 'MNEMOSYNE QUERY', 2}, _Line, S, _) -> S; +handle_call(_Locality, {_, 'MNEMOSYNE RECFUNDEF',1}, _Line, S, _) -> S; +handle_call(Locality, To0, Line, S, IsUnres) -> + From = S#xrefr.function, + To = adjust_arity(S, To0), + Call = {From, To}, + CallAt = {Call, Line}, + S1 = if + IsUnres -> + S#xrefr{unresolved = [CallAt | S#xrefr.unresolved]}; + true -> + S + end, + case Locality of + local -> + S1#xrefr{el = [Call | S1#xrefr.el], + l_call_at = [CallAt | S1#xrefr.l_call_at]}; + external -> + S1#xrefr{ex = [Call | S1#xrefr.ex], + x_call_at = [CallAt | S1#xrefr.x_call_at]} + end. + +adjust_arity(#xrefr{is_abstr = true, module = M}, {M, F, A} = MFA) -> + case xref_utils:is_static_function(F, A) of + true -> + MFA; + false -> + {M,F,A-1} + end; +adjust_arity(_S, MFA) -> + MFA. diff --git a/lib/tools/src/xref_scanner.erl b/lib/tools/src/xref_scanner.erl new file mode 100644 index 0000000000..990f8aa87b --- /dev/null +++ b/lib/tools/src/xref_scanner.erl @@ -0,0 +1,91 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2000-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(xref_scanner). + +-export([scan/1]). + +scan(Chars) -> + case erl_scan:string(Chars) of + {ok, Tokens, _Line} -> + {ok, lex(a1(Tokens))}; + {error, {Line,Module,Info}, _EndLine} -> + {error, Module:format_error(Info), Line} + end. + +a1([{'-',N},{integer,N,1} | L]) -> + [{integer,N,-1} | a1(L)]; +a1([T | L]) -> + [T | a1(L)]; +a1([]) -> + []. + +-define(MFA(M,F,A,N), {atom,N,M}, {':',_}, {atom,_,F}, {'/',_}, {integer,_,A}). +-define(MFA2(M,F,A,N), + {'{',N},{atom,_,M},{',',_},{atom,_,F},{',',_},{integer,_,A},{'}',_}). +-define(DECL(N1,N2,T), {':',N1},{var,N2,T}). + +lex([{atom,N,V1},{'->',_},{atom,_,V2} | L]) -> + Constant = {constant, unknown, edge, {V1,V2}}, + [{edge,N,Constant} | lex(L)]; +lex([{'{',N},{atom,_,V1},{',',_},{atom,_,V2},{'}',_} | L]) -> + Constant = {constant, unknown, edge, {V1,V2}}, + [{edge,N,Constant} | lex(L)]; +lex([?MFA(M,F,A,N),{'->',_},?MFA(M2,F2,A2,_) | L]) -> + Constant = {constant, 'Fun', edge, {{M,F,A},{M2,F2,A2}}}, + [{edge,N,Constant} | lex(L)]; +lex([?MFA(M,F,A,N) | L]) -> + Constant = {constant, 'Fun', vertex, {M,F,A}}, + [{vertex,N,Constant} | lex(L)]; +lex([{'{',N},?MFA2(M,F,A,_),{',',_},?MFA2(M2,F2,A2,_),{'}',_} | L]) -> + Constant = {constant, 'Fun', edge, {{M,F,A},{M2,F2,A2}}}, + [{edge,N,Constant} | lex(L)]; +lex([?MFA2(M,F,A,N) | L]) -> + Constant = {constant, 'Fun', vertex, {M,F,A}}, + [{vertex,N,Constant} | lex(L)]; +lex([?DECL(N1,N2,Decl) | L]) -> + case is_type(Decl) of + false -> [?DECL(N1, N2, Decl) | lex(L)]; + true -> [{decl,N1,Decl} | lex(L)] + end; +lex([{':',N},{'=',_} | L]) -> + [{':=',N} | lex(L)]; +lex([{'||',N},{'|',_} | L]) -> + [{'|||',N} | lex(L)]; +lex([V={var,N,Var} | L]) -> + T = case is_type(Var) of + false -> V; + true -> {cast,N,Var} + end, + [T | lex(L)]; +lex([T | Ts]) -> + [T | lex(Ts)]; +lex([]) -> + [{'$end', -1}]. + +is_type('Rel') -> true; +is_type('App') -> true; +is_type('Mod') -> true; +is_type('Fun') -> true; +is_type('Lin') -> true; +is_type('LLin') -> true; +is_type('XLin') -> true; +is_type('ELin') -> true; +is_type('XXL') -> true; +is_type(_) -> false. diff --git a/lib/tools/src/xref_utils.erl b/lib/tools/src/xref_utils.erl new file mode 100644 index 0000000000..aeb7bf9f1c --- /dev/null +++ b/lib/tools/src/xref_utils.erl @@ -0,0 +1,725 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2000-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(xref_utils). + +-export([xset/2]). + +-export([is_directory/1, file_info/1, fa_to_mfa/2]). + +-export([is_string/2, is_path/1]). + +-export([module_filename/2, application_filename/1, application_filename/2]). + +-export([release_directory/3, select_application_directories/2, + filename_to_application/1, select_last_application_version/1, + split_filename/2, scan_directory/4, list_path/2]). + +-export([predefined_functions/0, is_funfun/3, is_builtin/3]). + +-export([is_static_function/2, is_abstract_module/1]). + +-export([closure/1, components/1, condensation/1, path/2, use/2, call/2]). + +-export([regexpr/2]). + +-export([relation_to_graph/1]). + +-export([find_beam/1]). + +-export([options/2]). + +-export([subprocess/2]). + +-export([format_error/1]). + +-import(lists, [append/1, delete/2, filter/2, foldl/3, foreach/2, + keydelete/3, keysearch/3, keysort/2, last/1, map/2, + member/2, reverse/1, sort/1]). + +-import(sofs, + [difference/2, domain/1, family/1, + family_to_relation/1, from_external/2, from_term/2, + intersection/2, partition/2, relation/1, relation_to_family/1, + restriction/2, set/1, to_external/1, type/1]). + +-include_lib("kernel/include/file.hrl"). + +%% +%% Exported functions +%% + +xset(L, T) when is_list(L) -> + from_external(lists:usort(L), T); +xset(S, T) -> + from_external(S, T). + +%% -> true | false | {error, ?MODULE, Reason} +%is_directory(F) -> +% filelib:is_dir(F); +is_directory(F) -> + case file:read_file_info(F) of + {ok, Info} -> + Info#file_info.type =:= directory; + {error, Error} -> + file_error(F, Error) + end. + +%% file_info(FileName) -> {ok, FileInfo} | {error, ?MODULE, Reason} +%% FileInfo = {FileName, DirOrFile, Readable, ModificationTime} +%% DirOrFile = directory | file +%% Readable = readable | unreadable +%% ModificationTime = {{Year, Month, Day}, {Hour, Minute, Second}} +%% +%% DirOrFile is equal to 'directory' ('file') if FileName is a +%% directory (regular file). +%% Readable is equal 'readable' ('unreadable') if FileName is readable +%% (unreadable). +%% ModificationTime is copied from file_info.mtime. +%% +file_info(F) -> + case file:read_file_info(F) of + {ok, Info} -> + Readable = case Info#file_info.access of + Access when Access =:= read; + Access =:= read_write -> + readable; + _ -> + unreadable + end, + Type = case Info#file_info.type of + directory -> directory; + regular -> file; + _ -> error + end, + case Type of + error -> error({unrecognized_file, F}); + _ -> {ok, {F, Type, Readable, Info#file_info.mtime}} + end; + {error, Error} -> + file_error(F, Error) + end. + + +fa_to_mfa(FAs, Mod) -> + fa_to_mfa(FAs, Mod, []). + +fa_to_mfa([{F,A} | MFs], Mod, L) -> + fa_to_mfa(MFs, Mod, [{Mod,F,A} | L]); +fa_to_mfa([], _Mod, L) -> + reverse(L). + +module_filename(Dir, Module) -> + filename:join(Dir, to_list(Module) ++ code:objfile_extension()). + +application_filename(AppName) -> + to_list(AppName) ++ ".app". + +application_filename(Dir, AppName) -> + filename:join(to_list(Dir), application_filename(AppName)). + +%% -> bool() +is_string([], _) -> + false; +is_string(Term, C) -> + is_string1(Term, C). + +is_string1([H | T], C) when H > C, H < 127 -> + is_string1(T, C); +is_string1([], _) -> + true; +is_string1(_, _) -> + false. + +%% -> bool() +is_path([S | Ss]) -> + case is_string(S, 31) of + true -> + is_path(Ss); + false -> + false + end; +is_path([]) -> + true; +is_path(_) -> + false. + +%==================================== +% Release and application functions. +%==================================== + +%%% ApplDir = {ApplicationName,NumericApplicationVersion,ApplicationDirectory} +%%% ApplicationName = atom() +%%% ApplicationDirectory = string() +%%% NumericApplicationVersion = [integer()] ("3.1.7" becomes [3,1,7]). +%%% [] means that the application has no version... +%%% +%%% ModuleName = ModuleFileName = string() +%%% ReleaseName = atom() + +%% release_directory(Directory, CheckLib, SubDirectory) -> +%% {ok, ReleaseName, AppDir, [ApplDir]} | {error, ?MODULE, Reason} +%% CheckLib = bool() +%% AppDir = string() +%% SubDirectory = string() +%% +%% Returns all sub directories of a given directory, assuming all sub +%% directories are application directories. If a sub directory has a +%% sub directory SubDirectory, that one is chosen as application +%% directory. If Directory has a sub directory 'lib' and CheckLib is +%% equal to 'true', applications are looked for on that +%% directory. ApplDir is the directory where applications reside. In +%% any case, the returned ReleaseName is the basename of the given +%% directory. +%% +release_directory(Dir, UseLib, SubDir) -> + SDir = subdir(Dir, "lib", UseLib), + case file:list_dir(SDir) of + {ok, FileNames} -> + Files = [filename:join(SDir, File) || File <- FileNames], + case select_application_directories(Files, SubDir) of + {ok, ApplDirs} -> + {ok, list_to_atom(filename:basename(Dir)), SDir, ApplDirs}; + Error -> + Error + end; + {error, Error} -> + file_error(SDir, Error) + end. + +%% select_application_directories([FileName], SubDirectory) -> +%% {ok, [ApplDir]} | {error, ?MODULE, Error} +%% SubDirectory = string() +%% +%% For each filename that is a directory, the filename is split into +%% an application name and an application version, if possible, using +%% '-' as separator. If not possible, the empty version - [] - is +%% used. If a directory has a sub directory called SubDirectory, that +%% one is returned as application directory rather than the directory +%% itself. +%% +select_application_directories(FileNames, Dir) -> + select_application_directories(FileNames, Dir, Dir =/= [], []). + +%% filename_to_application(FileName) -> +%% {ApplicationName,NumbericApplicationVersion} +%% +%% Interprets a filename as an application name and an application +%% version. If the filename (the basename actually) cannot be split +%% into two components using '-' as separator, the whole basename is +%% used as application name, and the version returned is []. +%% +filename_to_application(FileName) -> + Basename = filename:basename(FileName), + case catch filename2appl(Basename) of + {'EXIT',_} -> + {list_to_atom(Basename),[]}; + Split -> + Split + end. + +%% select_last_application_version([ApplDir]) -> [ApplDir] +%% +%% For each application that occurs with more than one version in the +%% input list, only the one with the last version is kept. +%% +select_last_application_version(AppVs) -> + TL = to_external(partition(1, relation(AppVs))), + [last(keysort(2, L)) || L <- TL]. + +%% scan_directory(Directory, Recurse, Collect, Watch) -> +%% {Collected, Errors, Seen, Unreadable} +%% +%% Watch = Collect = [string()] +%% Directory = string() | atom() +%% Recurse = bool() +%% Collected = [{Dir,Basename}] +%% Dir = Basename = Seen = Unreadable = [string()] +%% +%% Collected (Seen) contains those regular files with extension +%% occurring in Collect (Watch). Watch is tried only if a filename +%% does not match Collect. Only readable files occur in Collected, the +%% unreadable files (with extension matching Collect) go into +%% Unreadable. +%% +scan_directory(File, Recurse, Collect, Watch) -> + Init = [[] | {[],[],[]}], + [L | {E,J,U}] = find_files_dir(File, Recurse, Collect, Watch, Init), + {reverse(L), reverse(E), reverse(J), reverse(U)}. + +%% {Dir, Basename} | false +split_filename(File, Extension) -> + case catch begin + Dir = filename:dirname(File), + Basename = filename:basename(File, Extension), + {Dir, Basename++Extension} + end of + {'EXIT', _} -> + false; + R -> + R + end. + +%% list_path(Path, Extensions) -> +%% {[{Module, {integer(), Directory, Basename}}], [error()]} +%% +%% Path = [Directory] +%% Extensions = [string()] +%% Module = atom() +%% Directory = Basename = string() +%% +%% Files with any of the given extensions are searched for among +%% the given directories (Path). Directories "below" some of the given +%% directories are not searched (unless enumerated in Path). If some +%% file is found on more than one directory, the first one found is +%% returned (Path is searched from the beginning). +%% +list_path(P, Extensions) -> + list_dirs(P, 1, Extensions, [], []). + +list_dirs([D | Ds], I, Exts, CL, E) -> + Fun = fun(X, A) -> + File = filename:join(D, X), + case is_directory(File) of + false -> + Ext = filename:extension(X), + case member(Ext, Exts) of + true -> + M = list_to_atom(filename:basename(X, Ext)), + [{M, {I,D,X}} | A]; + false -> + A + end; + true -> + A; + _Else -> + A + end + end, + {NCL, NE} = case file:list_dir(D) of + {ok, C0} -> + {foldl(Fun, CL, C0), E}; + {error, Error} -> + {CL, [file_error(D, Error) | E]} + end, + list_dirs(Ds, I+1, Exts, NCL, NE); +list_dirs([], _I, _Exts, C, E) -> + {C, E}. + +%% Returns functions that are present in all modules. +predefined_functions() -> + [{module_info,0}, {module_info,1}]. + +%% Returns true if an MFA takes functional arguments. +is_funfun(erlang, apply, 2) -> true; +is_funfun(erlang, apply, 3) -> true; +is_funfun(erlang, spawn, 1) -> true; +is_funfun(erlang, spawn, 2) -> true; +is_funfun(erlang, spawn, 3) -> true; +is_funfun(erlang, spawn, 4) -> true; +is_funfun(erlang, spawn_link, 1) -> true; +is_funfun(erlang, spawn_link, 2) -> true; +is_funfun(erlang, spawn_link, 3) -> true; +is_funfun(erlang, spawn_link, 4) -> true; +is_funfun(erlang, spawn_opt, 2) -> true; +is_funfun(erlang, spawn_opt, 3) -> true; +is_funfun(erlang, spawn_opt, 4) -> true; +is_funfun(erlang, spawn_opt, 5) -> true; +is_funfun(erts_debug, apply, 4) -> true; +is_funfun(_, _, _) -> false. + +is_builtin(erts_debug, apply, 4) -> true; +is_builtin(M, F, A) -> + erlang:is_builtin(M, F, A). + +is_abstract_module(Attributes) -> + case keysearch(abstract, 1, Attributes) of + {value, {abstract, true}} -> + true; + {value, {abstract, Vals}} when is_list(Vals) -> + member(true, Vals); + _ -> + false + end. + +%% A "static function" is a function in an abstract module that may be +%% called directly. +is_static_function(module_info, 0) -> + true; +is_static_function(module_info, 1) -> + true; +is_static_function(new, _) -> + true; +is_static_function(instance, _) -> + true; +is_static_function(_F, _A) -> + false. + +%%% The following functions implement some of the operators recognized +%%% in xref_compiler.erl. + +closure(S) -> + relation_to_graph(S). + +components(G) -> + %% Returns a plain set of sets. + from_term(digraph_utils:cyclic_strong_components(G), [[atom]]). + +condensation(G) -> + G2 = digraph_utils:condensation(G), + %% A relation. The result can be only be used by a few set operations. + R = graph_to_relation(G2), + true = digraph:delete(G2), + R. + +path(G, [E]) -> + path(G, [E,E]); +path(G, P=[E1 | _]) -> + path(P, G, [[E1]]). + +use(G, V) -> + neighbours(to_external(V), G, reaching_neighbours, type(V)). + +call(G, V) -> + neighbours(to_external(V), G, reachable_neighbours, type(V)). + +regexpr({regexpr, RExpr}, Var) -> + Xs = match_list(to_external(Var), RExpr), + xset(Xs, type(Var)); +regexpr({ModExpr, FunExpr, ArityExpr}, Var) -> + Type = type(Var), + V1 = case {ModExpr,Type} of + {{atom, Mod},[{ModType, _}]} -> + restriction(Var, xset([Mod], [ModType])); + {{regexpr, MExpr},[{ModType, _}]} -> + Mods = match_list(to_external(domain(Var)), MExpr), + restriction(Var, xset(Mods, [ModType])); + {variable,_} -> + Var; + {_,_} -> % Var is the empty set + Var + end, + V2 = case FunExpr of + {atom, FunName} -> + V1L = to_external(V1), + xset(match_one(V1L, FunName, 2), Type); + {regexpr, FExpr} -> + V1L = to_external(V1), + xset(match_many(V1L, FExpr, 2), Type); + variable -> + V1 + end, + case ArityExpr of + {integer, Arity} -> + V2L = to_external(V2), + xset(match_one(V2L, Arity, 3), Type); + {regexpr, Expr} -> + V2L = to_external(V2), + xset(match_many(V2L, Expr, 3), Type); + variable -> + V2 + end. + +%% -> digraph() +relation_to_graph(S) -> + G = digraph:new(), + Fun = fun({From, To}) -> + digraph:add_vertex(G, From), + digraph:add_vertex(G, To), + digraph:add_edge(G, From, To) + end, + foreach(Fun, to_external(S)), + G. + +%% -> {ok, FileName} | Error | fault() +%% Finds a module's BEAM file. +find_beam(Module) when is_atom(Module) -> + case code:which(Module) of + non_existing -> + error({no_such_module, Module}); + preloaded -> + {_M, _Bin, File} = code:get_object_code(Module), + {ok, File}; + cover_compiled -> + error({cover_compiled, Module}); + File -> + {ok, File} + end; +find_beam(Culprit) -> + erlang:error(badarg, [Culprit]). + +%% options(Options, ValidOptions) -> {OptionValues, InvalidOptions} +%% +%% Options = [Option] | Option +%% ValidOptions = [atom() | {OptionName, ValidValues}] +%% OptionValues = [bool() | {OptionName, [term()]}] +%% OptionName = atom() +%% InvalidOptions = [Option] +%% Option = OptionName | {OptionName, term()} +%% ValidValues = [] | [DefaultValue | [ValidValue]] | [DefaultValue, Tester] +%% ValidValue = DefaultValue = term() +%% Tester = fun([term()]) -> bool() +%% +%% A Boolean Option has a name (an atom). A Value Option has a name +%% (an atom) and a value (a term). +%% +%% ValidOptions enumerates allowed options - a Boolean Option is +%% enumerated with its name, and a Value Option is enumerated with a +%% pair {Name, Values}, where Name is the option's name and Values is +%% a list of allowed values for the Value Option, the first one being +%% the default value (by convention). An empty list of allowed values +%% means that all terms are allowed as value (and that there is no +%% default value). Also if the only allowed value is the default +%% value, all terms are allowed as value. A function argument (Tester) +%% may be used for testing the supplied values (useful for a path...) +%% An allowed option must not be enumerated more than once, but +%% allowed values may be duplicated. +%% +%% OptionValues is a list of option values, where member i is the +%% value of option i in ValidOptions. The value of a Boolean Option is +%% 'true' if the option name is mentioned in Options, otherwise +%% 'false'. The value of a Value Option is a list of the option values +%% mentioned in Options for the Value Option. If the Value Option is +%% not mentioned in Options, the list contains the default value (if +%% there is no default value, the list is empty), and if it is +%% mentioned more than once, the values are sorted in standard order. +%% +%% InvalidOptions is a list of those options present in Options that +%% do not match any allowed option mentioned in ValidOptions. +%% +options(Options, Valid) -> + split_options(Options, [], [], [], Valid). + +subprocess(Fun, Opts) -> + Pid = spawn_opt(Fun, Opts), + receive + {Pid, Reply} -> Reply + end. + +format_error({error, Module, Error}) -> + Module:format_error(Error); +format_error({file_error, FileName, Reason}) -> + io_lib:format("~s: ~p~n", [FileName, file:format_error(Reason)]); +format_error({unrecognized_file, FileName}) -> + io_lib:format("~p is neither a regular file nor a directory~n", + [FileName]); +format_error({no_such_module, Module}) -> + io_lib:format("Cannot find module ~p using the code path~n", [Module]); +format_error({interpreted, Module}) -> + io_lib:format("Cannot use BEAM code of interpreted module ~p~n", [Module]); +format_error(E) -> + io_lib:format("~p~n", [E]). + +%% +%% Local functions +%% + +to_list(X) when is_atom(X) -> atom_to_list(X); +to_list(X) when is_list(X) -> X. + +select_application_directories([FileName|FileNames], Dir, Flag, L) -> + case is_directory(FileName) of + true -> + File = filename:basename(FileName), + {Name, Vsn} = filename_to_application(File), + ApplDir = {Name, Vsn, subdir(FileName, Dir, Flag)}, + select_application_directories(FileNames, Dir, Flag, [ApplDir|L]); + false -> + select_application_directories(FileNames, Dir, Flag, L); + Error -> + Error + end; +select_application_directories([], _Dir, _Flag, L) -> + {ok,reverse(L)}. + +subdir(Dir, _, false) -> + Dir; +subdir(Dir, SubDir, true) -> + EDir = filename:join(Dir, SubDir), + case is_directory(EDir) of + true -> EDir; + _FalseOrError -> Dir + end. + +%% Avoid "App-01.01" - the zeroes will be lost. +filename2appl(File) -> + Pos = string:rstr(File, "-"), + true = Pos > 1, + V = string:sub_string(File, Pos+1), + true = string:len(V) > 0, + VsnT = string:tokens(V, "."), + ApplName = string:sub_string(File, 1, Pos-1), + Vsn = [list_to_integer(Vsn) || Vsn <- VsnT], + {list_to_atom(ApplName),Vsn}. + +find_files_dir(Dir, Recurse, Collect, Watch, L) -> + case file:list_dir(Dir) of + {ok, Files} -> + find_files(sort(Files), Dir, Recurse, Collect, Watch, L); + {error, Error} -> + [B | {E,J,U}] = L, + [B | {[file_error(Dir, Error)|E],J,U}] + end. + +find_files([F | Fs], Dir, Recurse, Collect, Watch, L) -> + File = filename:join(Dir, F), + L1 = case file_info(File) of + {ok, {_, directory, readable, _}} when Recurse -> + find_files_dir(File, Recurse, Collect, Watch, L); + {ok, {_, directory, _, _}} -> + L; + Info -> + [B | EJU = {E,J,U}] = L, + Ext = filename:extension(File), + C = member(Ext, Collect), + case C of + true -> + case Info of + {ok, {_, file, readable, _}} -> + [[{Dir,F} | B] | EJU]; + {ok, {_, file, unreadable, _}} -> + [B | {E,J,[File|U]}]; + Error -> + [B | {[Error|E],J,U}] + end; + false -> + case member(Ext, Watch) of + true -> [B | {E,[File|J],U}]; + false -> L + end + end + end, + find_files(Fs, Dir, Recurse, Collect, Watch, L1); +find_files([], _Dir, _Recurse, _Collect, _Watch, L) -> + L. + +graph_to_relation(G) -> + Fun = fun(E) -> {_E, V1, V2, _Label} = digraph:edge(G, E), {V1, V2} end, + from_term(map(Fun, digraph:edges(G)), [{[atom],[atom]}]). + +path([E1, E2 | P], G, L) -> + case digraph:get_short_path(G, E1, E2) of + false -> + false; + [_V | Vs] -> + path([E2 | P], G, [Vs | L]) + end; +path([_], _G, L) -> + append(reverse(L)). + +neighbours(Vs, G, Fun, VT) -> + neighbours(Vs, G, Fun, VT, []). + +neighbours([V | Vs], G, Fun, VT, L) -> + Ns = digraph_utils:Fun([V], G), + neighbours(Ns, G, Fun, VT, L, V, Vs); +neighbours([], _G, _Fun, [VT], L) -> + xset(L, [{VT,VT}]). + +neighbours([N | Ns], G, Fun, VT, L, V, Vs) when Fun =:= reachable_neighbours -> + neighbours(Ns, G, Fun, VT, [{V, N} | L], V, Vs); +neighbours([N | Ns], G, Fun, VT, L, V, Vs) -> + neighbours(Ns, G, Fun, VT, [{N, V} | L], V, Vs); +neighbours([], G, Fun, VT, L, _V, Vs) -> + neighbours(Vs, G, Fun, VT, L). + +match_list(L, RExpr) -> + {ok, Expr} = regexp:parse(RExpr), + filter(fun(E) -> match(E, Expr) end, L). + +match_one(VarL, Con, Col) -> + select_each(VarL, fun(E) -> Con =:= element(Col, E) end). + +match_many(VarL, RExpr, Col) -> + {ok, Expr} = regexp:parse(RExpr), + select_each(VarL, fun(E) -> match(element(Col, E), Expr) end). + +match(I, Expr) when is_integer(I) -> + S = integer_to_list(I), + {match, 1, length(S)} =:= regexp:first_match(S, Expr); +match(A, Expr) when is_atom(A) -> + S = atom_to_list(A), + {match, 1, length(S)} =:= regexp:first_match(S, Expr). + +select_each([{Mod,Funs} | L], Pred) -> + case filter(Pred, Funs) of + [] -> + select_each(L, Pred); + NFuns -> + [{Mod,NFuns} | select_each(L, Pred)] + end; +select_each([], _Pred) -> + []. + +split_options([O | Os], A, P, I, V) when is_atom(O) -> + split_options(Os, [O | A], P, I, V); +split_options([O={Name,_} | Os], A, P, I, V) when is_atom(Name) -> + split_options(Os, A, [O | P], I, V); +split_options([O | Os], A, P, I, V) -> + split_options(Os, A, P, [O | I], V); +split_options([], A, P, I, V) -> + Atoms = to_external(set(A)), + Pairs = to_external(relation_to_family(relation(P))), + option_values(V, Atoms, Pairs, I, []); +split_options(O, A, P, I, V) -> + split_options([O], A, P, I, V). + +option_values([O | Os], A, P, I, Vs) when is_atom(O) -> + option_values(Os, delete(O, A), P, I, [member(O, A) | Vs]); +option_values([{Name, AllowedValues} | Os], A, P, I, Vs) -> + case keysearch(Name, 1, P) of + {value, {_, Values}} -> + option_value(Name, AllowedValues, Values, A, P, I, Vs, Os); + false when AllowedValues =:= [] -> + option_values(Os, A, P, I, [[] | Vs]); + false -> + [Default | _] = AllowedValues, + option_values(Os, A, P, I, [[Default] | Vs]) + end; +option_values([], A, P, Invalid, Values) -> + I2 = to_external(family_to_relation(family(P))), + {reverse(Values), Invalid ++ A ++ I2}. + +option_value(Name, [_Deflt, Fun], Vals, A, P, I, Vs, Os) + when is_function(Fun) -> + P1 = keydelete(Name, 1, P), + case Fun(Vals) of + true -> + option_values(Os, A, P1, I, [Vals | Vs]); + false -> + option_values(Os, A, [{Name,Vals} | P1], I, [[] | Vs]) + end; +option_value(Name, AllowedValues, Values, A, P, I, Vs, Os) -> + P1 = keydelete(Name, 1, P), + VS = set(Values), + AVS = set(AllowedValues), + V1 = to_external(intersection(VS, AVS)), + {V, NP} = case to_external(difference(VS, AVS)) of + _ when AllowedValues =:= [] -> {Values,P1}; + [] -> {V1,P1}; + _ when length(AllowedValues) =:= 1 -> + {Values,P1}; + I1 -> {V1,[{Name,I1} | P1]} + end, + option_values(Os, A, NP, I, [V | Vs]). + +file_error(File, Error) -> + error({file_error, File, Error}). + +error(Error) -> + {error, ?MODULE, Error}. -- cgit v1.2.3