path: root/lib/kernel/src/code_server.erl

%%
%% %CopyrightBegin%
%%
%% Copyright Ericsson AB 1998-2016. All Rights Reserved.
%%
%% Licensed under the Apache License, Version 2.0 (the "License");
%% you may not use this file except in compliance with the License.
%% You may obtain a copy of the License at
%%
%%     http://www.apache.org/licenses/LICENSE-2.0
%%
%% Unless required by applicable law or agreed to in writing, software
%% distributed under the License is distributed on an "AS IS" BASIS,
%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
%% See the License for the specific language governing permissions and
%% limitations under the License.
%%
%% %CopyrightEnd%
%%
-module(code_server).

%% This file holds the server part of the code_server.

-export([start_link/1,
	 call/1,
	 system_code_change/4,
	 error_msg/2, info_msg/2
	]).

-include_lib("kernel/include/file.hrl").
-include_lib("stdlib/include/ms_transform.hrl").

-import(lists, [foreach/2]).

-type on_load_item() :: {reference(),module(),file:name_all(),[pid()]}.

-record(state, {supervisor :: pid(),
		root :: file:name_all(),
		path :: [file:name_all()],
		moddb :: ets:tab(),
		namedb :: ets:tab(),
		mode = interactive :: 'interactive' | 'embedded',
		on_load = [] :: [on_load_item()]}).
-type state() :: #state{}.

-spec start_link([term()]) -> {'ok', pid()}.
start_link(Args) ->
    Ref = make_ref(),
    Parent = self(),
    Init = fun() -> init(Ref, Parent, Args) end,
    spawn_link(Init),
    receive 
	{Ref,Res} -> Res
    end.


%% -----------------------------------------------------------
%% Init the code_server process.
%% -----------------------------------------------------------

init(Ref, Parent, [Root,Mode]) ->
    register(?MODULE, self()),
    process_flag(trap_exit, true),

    Db = ets:new(code, [private]),
    foreach(fun (M) ->
		    %% Pre-loaded modules are always sticky.
		    ets:insert(Db, [{M,preloaded},{{sticky,M},true}])
	    end, erlang:pre_loaded()),
    Loaded0 = init:fetch_loaded(),
    Loaded = [{M,filename:join([P])} || {M,P} <- Loaded0], %Normalize.
    ets:insert(Db, Loaded),

    IPath =
	case Mode of
	    interactive ->
		LibDir = filename:append(Root, "lib"),
		{ok,Dirs} = erl_prim_loader:list_dir(LibDir),
		Paths = make_path(LibDir, Dirs),
		UserLibPaths = get_user_lib_dirs(),
		["."] ++ UserLibPaths ++ Paths;
	    _ ->
		[]
	end,

    Path = add_loader_path(IPath, Mode),
    State = #state{supervisor = Parent,
		   root = Root,
		   path = Path,
		   moddb = Db,
		   namedb = init_namedb(Path),
		   mode = Mode},

    Parent ! {Ref,{ok,self()}},
    loop(State).

get_user_lib_dirs() ->
    case os:getenv("ERL_LIBS") of
	LibDirs0 when is_list(LibDirs0) ->
	    Sep =
		case os:type() of
		    {win32, _} -> $;;
		    _          -> $:
		end,
	    LibDirs = split_paths(LibDirs0, Sep, [], []),
	    get_user_lib_dirs_1(LibDirs);
	false ->
	    []
    end.

get_user_lib_dirs_1([Dir|DirList]) ->
    case erl_prim_loader:list_dir(Dir) of
	{ok, Dirs} ->
	    Paths = make_path(Dir, Dirs),
	    %% Only add paths trailing with ./ebin.
	    [P || P <- Paths, filename:basename(P) =:= "ebin"] ++
		get_user_lib_dirs_1(DirList);
	error ->
	    get_user_lib_dirs_1(DirList)
    end;
get_user_lib_dirs_1([]) -> [].


split_paths([S|T], S, Path, Paths) ->
    split_paths(T, S, [], [lists:reverse(Path) | Paths]);
split_paths([C|T], S, Path, Paths) ->
    split_paths(T, S, [C|Path], Paths);
split_paths([], _S, Path, Paths) ->
    lists:reverse(Paths, [lists:reverse(Path)]).

-spec call(term()) -> term().
call(Req) ->
    ?MODULE ! {code_call, self(), Req},
    receive 
	{?MODULE, Reply} ->
	    Reply
    end.

reply(Pid, Res) ->
    Pid ! {?MODULE, Res}.

loop(#state{supervisor=Supervisor}=State0) ->
    receive 
	{code_call, Pid, Req} ->
	    case handle_call(Req, Pid, State0) of
		{reply, Res, State} ->
		    _ = reply(Pid, Res),
		    loop(State);
		{noreply, State} ->
		    loop(State);
		{stop, Why, stopped, State} ->
		    system_terminate(Why, Supervisor, [], State)
	    end;
	{'EXIT', Supervisor, Reason} ->
	    system_terminate(Reason, Supervisor, [], State0);
	{system, From, Msg} ->
	    handle_system_msg(running,Msg, From, Supervisor, State0);
	{'DOWN',Ref,process,_,Res} ->
	    State = finish_on_load(Ref, Res, State0),
	    loop(State);
	_Msg ->
	    loop(State0)
    end.

%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% System upgrade

handle_system_msg(SysState, Msg, From, Parent, Misc) ->
    case do_sys_cmd(SysState, Msg, Parent, Misc) of
	{suspended, Reply, NMisc} ->
	    gen_reply(From, Reply),
	    suspend_loop(suspended, Parent, NMisc);
	{running, Reply, NMisc} ->
	    gen_reply(From, Reply),
	    system_continue(Parent, [], NMisc)
    end.

gen_reply({To, Tag}, Reply) ->
    catch To ! {Tag, Reply}.

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

do_sys_cmd(_, suspend, _Parent, Misc) ->
    {suspended, ok, Misc};
do_sys_cmd(_, resume, _Parent, Misc) ->
    {running, ok, Misc};
do_sys_cmd(SysState, get_status, Parent, Misc) ->
    Status = {status, self(), {module, ?MODULE},
	      [get(), SysState, Parent, [], Misc]},
    {SysState, Status, Misc};
do_sys_cmd(SysState, {debug, _What}, _Parent, Misc) ->
    {SysState,ok,Misc};
do_sys_cmd(suspended, {change_code, Module, Vsn, Extra}, _Parent, Misc0) ->
    {Res, Misc} = 
	case catch ?MODULE:system_code_change(Misc0, Module, Vsn, Extra)  of
	    {ok, _} = Ok -> Ok;
	    Else -> {{error, Else}, Misc0}
	end,
    {suspended, Res, Misc};
do_sys_cmd(SysState, Other, _Parent, Misc) ->
    {SysState, {error, {unknown_system_msg, Other}}, Misc}.

system_continue(_Parent, _Debug, State) ->
    loop(State).

system_terminate(_Reason, _Parent, _Debug, _State) ->
    %% error_msg("~p terminating: ~p~n ", [?MODULE, Reason]),
    exit(shutdown).

-spec system_code_change(state(), module(), term(), term()) -> {'ok', state()}.
system_code_change(State, _Module, _OldVsn, _Extra) ->
    {ok, State}.

%%
%% The gen_server call back functions.
%%

handle_call({stick_dir,Dir}, _From, S) ->
    {reply,stick_dir(Dir, true, S),S};

handle_call({unstick_dir,Dir}, _From, S) ->
    {reply,stick_dir(Dir, false, S),S};

handle_call({stick_mod,Mod}, _From, S) ->
    {reply,stick_mod(Mod, true, S),S};

handle_call({unstick_mod,Mod}, _From, S) ->
    {reply,stick_mod(Mod, false, S),S};

handle_call({dir,Dir}, _From, S) ->
    Root = S#state.root,
    Resp = do_dir(Root,Dir,S#state.namedb),
    {reply,Resp,S};

handle_call({load_file,Mod}, From, St) when is_atom(Mod) ->
    load_file(Mod, From, St);

handle_call({add_path,Where,Dir0}, _From,
	    #state{namedb=Namedb,path=Path0}=S) ->
    {Resp,Path} = add_path(Where, Dir0, Path0, Namedb),
    {reply,Resp,S#state{path=Path}};

handle_call({add_paths,Where,Dirs0}, _From,
	    #state{namedb=Namedb,path=Path0}=S) ->
    {Resp,Path} = add_paths(Where, Dirs0, Path0, Namedb),
    {reply,Resp,S#state{path=Path}};

handle_call({set_path,PathList}, _From,
	    #state{path=Path0,namedb=Namedb}=S) ->
    {Resp,Path,NewDb} = set_path(PathList, Path0, Namedb),
    {reply,Resp,S#state{path=Path,namedb=NewDb}};

handle_call({del_path,Name}, _From,
	    #state{path=Path0,namedb=Namedb}=S) ->
    {Resp,Path} = del_path(Name, Path0, Namedb),
    {reply,Resp,S#state{path=Path}};

handle_call({replace_path,Name,Dir}, _From,
	    #state{path=Path0,namedb=Namedb}=S) ->
    {Resp,Path} = replace_path(Name, Dir, Path0, Namedb),
    {reply,Resp,S#state{path=Path}};

handle_call(get_path, _From, S) ->
    {reply,S#state.path,S};

%% Messages to load, delete and purge modules/files.
handle_call({load_abs,File,Mod}, From, S) when is_atom(Mod) ->
    case modp(File) of
	false ->
	    {reply,{error,badarg},S};
	true ->
	    load_abs(File, Mod, From, S)
    end;

handle_call({load_binary,Mod,File,Bin}, From, S) when is_atom(Mod) ->
    do_load_binary(Mod, File, Bin, From, S);

handle_call({load_native_partial,Mod,Bin}, _From, S) ->
    Architecture = erlang:system_info(hipe_architecture),
    Result = (catch hipe_unified_loader:load(Mod, Bin, Architecture)),
    Status = hipe_result_to_status(Result, S),
    {reply,Status,S};

handle_call({load_native_sticky,Mod,Bin,WholeModule}, _From, S) ->
    Architecture = erlang:system_info(hipe_architecture),
    Result = (catch hipe_unified_loader:load_module(Mod, Bin, WholeModule,
                                                    Architecture)),
    Status = hipe_result_to_status(Result, S),
    {reply,Status,S};

handle_call({ensure_loaded,Mod}, From, St) when is_atom(Mod) ->
    case erlang:module_loaded(Mod) of
	true ->
	    {reply,{module,Mod},St};
	false when St#state.mode =:= interactive ->
	    load_file(Mod, From, St);
	false ->
	    {reply,{error,embedded},St}
    end;

handle_call({delete,Mod}, _From, St) when is_atom(Mod) ->
    case catch erlang:delete_module(Mod) of
	true ->
	    ets:delete(St#state.moddb, Mod),
	    {reply,true,St};
	_ ->
	    {reply,false,St}
    end;

handle_call({purge,Mod}, _From, St) when is_atom(Mod) ->
    {reply,do_purge(Mod),St};

handle_call({soft_purge,Mod}, _From, St) when is_atom(Mod) ->
    {reply,do_soft_purge(Mod),St};

handle_call({is_loaded,Mod}, _From, St) when is_atom(Mod) ->
    {reply,is_loaded(Mod, St#state.moddb),St};

handle_call(all_loaded, _From, S) ->
    Db = S#state.moddb,
    {reply,all_loaded(Db),S};

handle_call({get_object_code,Mod}, _From, St) when is_atom(Mod) ->
    Path = St#state.path,
    case mod_to_bin(Path, Mod) of
	{_,Bin,FName} -> {reply,{Mod,Bin,FName},St};
	Error -> {reply,Error,St}
    end;

handle_call({is_sticky, Mod}, _From, S) ->
    Db = S#state.moddb,
    {reply, is_sticky(Mod,Db), S};

handle_call(stop,_From, S) ->
    {stop,normal,stopped,S};

handle_call({set_primary_archive, File, ArchiveBin, FileInfo, ParserFun},
	    _From, S=#state{mode=Mode}) ->
    case erl_prim_loader:set_primary_archive(File, ArchiveBin, FileInfo,
					     ParserFun) of
	{ok, Files} ->
	    {reply, {ok, Mode, Files}, S};
	{error, _Reason} = Error ->
	    {reply, Error, S}
    end;

handle_call(get_mode, _From, S=#state{mode=Mode}) ->
    {reply, Mode, S};

handle_call({finish_loading,Prepared,EnsureLoaded}, _From, S) ->
    {reply,finish_loading(Prepared, EnsureLoaded, S),S};

handle_call(Other,_From, S) ->
    error_msg(" ** Codeserver*** ignoring ~w~n ",[Other]),
    {noreply,S}.

%% --------------------------------------------------------------
%% Path handling functions.
%% --------------------------------------------------------------

%%
%% Create the initial path. 
%%
make_path(BundleDir, Bundles0) ->
    Bundles = choose_bundles(Bundles0),
    make_path(BundleDir, Bundles, []).

choose_bundles(Bundles) ->
    ArchiveExt = archive_extension(),
    Bs = lists:sort([create_bundle(B, ArchiveExt) || B <- Bundles]),
    [FullName || {_Name,_NumVsn,FullName} <-
		     choose(lists:reverse(Bs), [], ArchiveExt)].

create_bundle(FullName, ArchiveExt) ->
    BaseName = filename:basename(FullName, ArchiveExt),
    case split_base(BaseName) of
	{Name, VsnStr} ->
	    case vsn_to_num(VsnStr) of
		{ok, VsnNum} ->
		    {Name,VsnNum,FullName};
		false ->
		    {FullName,[0],FullName}
	    end;
	_ ->
	    {FullName,[0],FullName}
    end.

%% Convert "X.Y.Z. ..." to [K, L, M| ...]
vsn_to_num(Vsn) ->
    case is_vsn(Vsn) of
	true ->
	    {ok, [list_to_integer(S) || S <- split(Vsn, ".")]};
	_  ->
	    false
    end.

is_vsn(Str) when is_list(Str) ->
    Vsns = split(Str, "."),
    lists:all(fun is_numstr/1, Vsns).

is_numstr(Cs) ->
    lists:all(fun (C) when $0 =< C, C =< $9 -> true; 
		  (_)                       -> false
	      end, Cs).

split(Cs, S) ->
    split1(Cs, S, []).

split1([C|S], Seps, Toks) ->
    case lists:member(C, Seps) of
	true -> split1(S, Seps, Toks);
	false -> split2(S, Seps, Toks, [C])
    end;
split1([], _Seps, Toks) ->
    lists:reverse(Toks).

split2([C|S], Seps, Toks, Cs) ->
    case lists:member(C, Seps) of
	true -> split1(S, Seps, [lists:reverse(Cs)|Toks]);
	false -> split2(S, Seps, Toks, [C|Cs])
    end;
split2([], _Seps, Toks, Cs) ->
    lists:reverse([lists:reverse(Cs)|Toks]).
   
join([H1, H2| T], S) ->
    H1 ++ S ++ join([H2| T], S);
join([H], _) ->
    H;
join([], _) ->
    [].

choose([{Name,NumVsn,NewFullName}=New|Bs], Acc, ArchiveExt) ->
    case lists:keyfind(Name, 1, Acc) of
	{_, NV, OldFullName} when NV =:= NumVsn ->
	    case filename:extension(OldFullName) =:= ArchiveExt of
		false ->
		    choose(Bs,Acc, ArchiveExt);
		true ->
		    Acc2 = lists:keystore(Name, 1, Acc, New),
		    choose(Bs,Acc2, ArchiveExt)
	    end;
	{_, _, _} ->
	    choose(Bs,Acc, ArchiveExt);
	false ->
	    choose(Bs,[{Name,NumVsn,NewFullName}|Acc], ArchiveExt)
    end;
choose([],Acc, _ArchiveExt) ->
    Acc.

make_path(_, [], Res) ->
    Res;
make_path(BundleDir, [Bundle|Tail], Res) ->
    Dir = filename:append(BundleDir, Bundle),
    Ebin = filename:append(Dir, "ebin"),
    %% First try with /ebin
    case is_dir(Ebin) of
	true ->
	    make_path(BundleDir, Tail, [Ebin|Res]);
	false ->
	    %% Second try with archive
	    Ext = archive_extension(),
	    Base = filename:basename(Bundle, Ext),
	    Ebin2 = filename:join([BundleDir, Base ++ Ext, Base, "ebin"]),
	    Ebins = 
		case split_base(Base) of
		    {AppName,_} ->
			Ebin3 = filename:join([BundleDir, Base ++ Ext,
					       AppName, "ebin"]),
			[Ebin3, Ebin2, Dir];
		    _ ->
			[Ebin2, Dir]
		end,
	    case try_ebin_dirs(Ebins) of
		{ok,FoundEbin} ->
		    make_path(BundleDir, Tail, [FoundEbin|Res]);
		error ->
		    make_path(BundleDir, Tail, Res)
	    end
    end.

try_ebin_dirs([Ebin|Ebins]) ->
    case is_dir(Ebin) of
	true -> {ok,Ebin};
	false -> try_ebin_dirs(Ebins)
    end;
try_ebin_dirs([]) ->
    error.


%%
%% Add the erl_prim_loader path.
%% 
%%
add_loader_path(IPath0,Mode) ->
    {ok,PrimP0} = erl_prim_loader:get_path(),
    case Mode of
        embedded ->
            strip_path(PrimP0, Mode);  % i.e. only normalize
        _ ->
            Pa0 = get_arg(pa),
            Pz0 = get_arg(pz),

            Pa = patch_path(Pa0),
            Pz = patch_path(Pz0),
	    PrimP = patch_path(PrimP0),
	    IPath = patch_path(IPath0),

            P = exclude_pa_pz(PrimP,Pa,Pz),
            Path0 = strip_path(P, Mode),
            Path = add(Path0, IPath, []),
            add_pa_pz(Path,Pa,Pz)
    end.

patch_path(Path) ->
    case check_path(Path) of
	{ok, NewPath} -> NewPath;
	{error, _Reason} -> Path
    end.	    

%% As the erl_prim_loader path includes the -pa and -pz
%% directories they have to be removed first !!
exclude_pa_pz(P0,Pa,Pz) ->
    P1 = excl(Pa, P0),
    P = excl(Pz, lists:reverse(P1)),
    lists:reverse(P).

excl([], P) -> 
    P;
excl([D|Ds], P) ->
    excl(Ds, lists:delete(D, P)).

%%
%% Keep only 'valid' paths in code server.
%% Only if mode is interactive, in an embedded
%% system we can't rely on file.
%%

strip_path([P0|Ps], Mode) ->
    P = filename:join([P0]), % Normalize
    case check_path([P]) of
	{ok, [NewP]} ->
	    [NewP|strip_path(Ps, Mode)];
	_ when Mode =:= embedded ->
	    [P|strip_path(Ps, Mode)];
	_ ->
	    strip_path(Ps, Mode)
    end;
strip_path(_, _) ->
    [].
    
%%
%% Add only non-existing paths.
%% Also delete other versions of directories,
%% e.g. .../test-3.2/ebin should exclude .../test-*/ebin (and .../test/ebin).
%% Put the Path directories first in resulting path.
%%
add(Path,["."|IPath],Acc) ->
    RPath = add1(Path,IPath,Acc),
    ["."|lists:delete(".",RPath)];
add(Path,IPath,Acc) ->
    add1(Path,IPath,Acc).

add1([P|Path],IPath,Acc) ->
    case lists:member(P,Acc) of
	true ->
	    add1(Path,IPath,Acc); % Already added
	false ->
	    IPath1 = exclude(P,IPath),
	    add1(Path,IPath1,[P|Acc])
    end;
add1(_,IPath,Acc) ->
    lists:reverse(Acc) ++ IPath.

add_pa_pz(Path0, Patha, Pathz) ->
    {_,Path1} = add_paths(first,Patha,Path0,false),
    {_,Path2} = add_paths(first,Pathz,lists:reverse(Path1),false),
    lists:reverse(Path2).

get_arg(Arg) ->
    case init:get_argument(Arg) of
	{ok, Values} ->
	    lists:append(Values);
	_ ->
	    []
    end.

%%
%% Exclude other versions of Dir or duplicates.
%% Return a new Path.
%%
exclude(Dir,Path) ->
    Name = get_name(Dir),
    [D || D <- Path, 
	  D =/= Dir, 
	  get_name(D) =/= Name].

%%
%% Get the "Name" of a directory. A directory in the code server path
%% have the following form: .../Name-Vsn or .../Name
%% where Vsn is any sortable term (the newest directory is sorted as
%% the greatest term).
%%
%%
get_name(Dir) ->
    get_name_from_splitted(filename:split(Dir)).

get_name_from_splitted([DirName,"ebin"]) ->
    discard_after_hyphen(DirName);
get_name_from_splitted([DirName]) ->
    discard_after_hyphen(DirName);
get_name_from_splitted([_|T]) ->
    get_name_from_splitted(T);
get_name_from_splitted([]) ->
    "".						%No name.

discard_after_hyphen("-"++_) ->
    [];
discard_after_hyphen([H|T]) ->
    [H|discard_after_hyphen(T)];
discard_after_hyphen([]) ->
    [].

split_base(BaseName) ->
    case split(BaseName, "-") of
	[_, _|_] = Toks ->
	    Vsn = lists:last(Toks),
	    AllButLast = lists:droplast(Toks),
	    {join(AllButLast, "-"),Vsn};
	[_|_] ->
	    BaseName
    end.

check_path(Path) ->
    PathChoice = init:code_path_choice(),
    ArchiveExt = archive_extension(),
    do_check_path(Path, PathChoice, ArchiveExt, []).
    
do_check_path([], _PathChoice, _ArchiveExt, Acc) -> 
    {ok, lists:reverse(Acc)};
do_check_path([Dir | Tail], PathChoice, ArchiveExt, Acc) ->
    case is_dir(Dir) of
	true ->
	    do_check_path(Tail, PathChoice, ArchiveExt, [Dir | Acc]);
	false when PathChoice =:= strict ->
	    %% Be strict. Only use dir as explicitly stated
	    {error, bad_directory};
	false when PathChoice =:= relaxed ->
	    %% Be relaxed
	    case catch lists:reverse(filename:split(Dir)) of
		{'EXIT', _} ->
		    {error, bad_directory};
		["ebin", App] ->
		    Dir2 = filename:join([App ++ ArchiveExt, App, "ebin"]),
		    case is_dir(Dir2) of
			true ->
			    do_check_path(Tail, PathChoice, ArchiveExt, [Dir2 | Acc]);
			false ->
			    {error, bad_directory}
		    end;    
		["ebin", App, OptArchive | RevTop] ->
		    Ext = filename:extension(OptArchive),
		    Base = filename:basename(OptArchive, Ext),
		    Dir2 = 
			if
			    Ext =:= ArchiveExt, Base =:= App ->
				%% .../app-vsn.ez/app-vsn/ebin
				Top = lists:reverse(RevTop),
				filename:join(Top ++ [App, "ebin"]);
			    Ext =:= ArchiveExt ->
				%% .../app-vsn.ez/xxx/ebin
				{error, bad_directory};
			    true ->
				%% .../app-vsn/ebin
				Top = lists:reverse([OptArchive | RevTop]),
				filename:join(Top ++ [App ++ ArchiveExt, App, "ebin"])
			end,
		    case is_dir(Dir2) of
			true ->
			    do_check_path(Tail, PathChoice, ArchiveExt, [Dir2 | Acc]);
			false ->
			    {error, bad_directory}
		    end;    
		_ ->
		    {error, bad_directory}
	    end
    end.

%%
%% Add new path(s).
%%
add_path(Where,Dir,Path,NameDb) when is_atom(Dir) ->
    add_path(Where,atom_to_list(Dir),Path,NameDb);
add_path(Where,Dir0,Path,NameDb) when is_list(Dir0) ->
    case int_list(Dir0) of
	true ->
	    Dir = filename:join([Dir0]), % Normalize
	    case check_path([Dir]) of
		{ok, [NewDir]} ->
		    {true, do_add(Where,NewDir,Path,NameDb)};
		Error ->
		    {Error, Path}
	    end;
	false ->
	    {{error, bad_directory}, Path}
    end;
add_path(_,_,Path,_) ->
    {{error, bad_directory}, Path}.


%%
%% If the new directory is added first or if the directory didn't exist
%% the name-directory table must be updated.
%% If NameDb is false we should NOT update NameDb as it is done later
%% then the table is created :-)
%%
do_add(first,Dir,Path,NameDb) ->
    update(Dir, NameDb),
    [Dir|lists:delete(Dir,Path)];
do_add(last,Dir,Path,NameDb) ->
    case lists:member(Dir,Path) of
	true ->
	    Path;
	false ->
	    maybe_update(Dir, NameDb),
	    Path ++ [Dir]
    end.

%% Do not update if the same name already exists !
maybe_update(Dir, NameDb) ->
    (lookup_name(get_name(Dir), NameDb) =:= false) andalso update(Dir, NameDb).

update(_Dir, false) ->
    true;
update(Dir, NameDb) ->
    replace_name(Dir, NameDb).

%%
%% Set a completely new path.
%%
set_path(NewPath0, OldPath, NameDb) ->
    NewPath = normalize(NewPath0),
    case check_path(NewPath) of
	{ok, NewPath2} ->
	    ets:delete(NameDb),
	    NewDb = init_namedb(NewPath2),
	    {true, NewPath2, NewDb};
	Error ->
	    {Error, OldPath, NameDb}
    end.

%%
%% Normalize the given path.
%% The check_path function catches erroneous path,
%% thus it is ignored here.
%%
normalize([P|Path]) when is_atom(P) ->
    normalize([atom_to_list(P)|Path]);
normalize([P|Path]) when is_list(P) ->
    case int_list(P) of
	true  -> [filename:join([P])|normalize(Path)];
	false -> [P|normalize(Path)]
    end;
normalize([P|Path]) ->
    [P|normalize(Path)];
normalize([]) ->
    [];
normalize(Other) ->
    Other.

%% Handle a table of name-directory pairs.
%% The priv_dir/1 and lib_dir/1 functions will have
%% an O(1) lookup.
init_namedb(Path) ->
    Db = ets:new(code_names,[private]),
    init_namedb(lists:reverse(Path), Db),
    Db.
    
init_namedb([P|Path], Db) ->
    insert_dir(P, Db),
    init_namedb(Path, Db);
init_namedb([], _) ->
    ok.

-ifdef(NOTUSED).
clear_namedb([P|Path], Db) ->
    delete_name_dir(P, Db),
    clear_namedb(Path, Db);
clear_namedb([], _) ->
    ok.
-endif.

%% Dir must be a complete pathname (not only a name).
insert_dir(Dir, Db) ->
    Splitted = filename:split(Dir),
    Name = get_name_from_splitted(Splitted),
    AppDir = filename:join(del_ebin_1(Splitted)),
    do_insert_name(Name, AppDir, Db).

insert_name(Name, Dir, Db) ->
    AppDir = del_ebin(Dir),
    do_insert_name(Name, AppDir, Db).

do_insert_name(Name, AppDir, Db) ->
    {Base, SubDirs} = archive_subdirs(AppDir),
    ets:insert(Db, {Name, AppDir, Base, SubDirs}),
    true.

archive_subdirs(AppDir) ->
    Base = filename:basename(AppDir),
    Dirs = case split_base(Base) of
	       {Name, _} -> [Name, Base];
	    _ -> [Base]
	end,
    Ext = archive_extension(),
    try_archive_subdirs(AppDir ++ Ext, Base, Dirs).

try_archive_subdirs(Archive, Base, [Dir | Dirs]) ->
    ArchiveDir = filename:append(Archive, Dir),
    case erl_prim_loader:list_dir(ArchiveDir) of
	{ok, Files} ->
	    IsDir = fun(RelFile) ->
			    File = filename:append(ArchiveDir, RelFile),
			    is_dir(File)
		    end,
	    {Dir, lists:filter(IsDir, Files)};
	_ ->
	    try_archive_subdirs(Archive, Base, Dirs)
    end;
try_archive_subdirs(_Archive, Base, []) ->
    {Base, []}.

%%
%% Delete a directory from Path.
%% Name can be either the the name in .../Name[-*] or
%% the complete directory name.
%%
del_path(Name0,Path,NameDb) ->
    case catch filename:join([to_list(Name0)]) of
	{'EXIT',_} ->
	    {{error,bad_name},Path};
	Name ->
	    case del_path1(Name,Path,NameDb) of
		Path -> % Nothing has changed
		    {false,Path};
		NewPath ->
		    {true,NewPath}
	    end
    end.

del_path1(Name,[P|Path],NameDb) ->
    case get_name(P) of
	Name ->
	    delete_name(Name, NameDb),
	    insert_old_shadowed(Name, Path, NameDb),
	    Path;
	_ when Name =:= P ->
	    case delete_name_dir(Name, NameDb) of
		true -> insert_old_shadowed(get_name(Name), Path, NameDb);
		false -> ok
	    end,
	    Path;
	_ ->
	    [P|del_path1(Name,Path,NameDb)]
    end;
del_path1(_,[],_) ->
    [].

insert_old_shadowed(Name, [P|Path], NameDb) ->
    case get_name(P) of
	Name -> insert_name(Name, P, NameDb);
	_    -> insert_old_shadowed(Name, Path, NameDb)
    end;
insert_old_shadowed(_, [], _) ->
    ok.

%%
%% Replace an old occurrence of an directory with name .../Name[-*].
%% If it does not exist, put the new directory last in Path.
%%
replace_path(Name,Dir,Path,NameDb) ->
    case catch check_pars(Name,Dir) of
	{ok,N,D} ->
	    {true,replace_path1(N,D,Path,NameDb)};
	{'EXIT',_} ->
	    {{error,{badarg,[Name,Dir]}},Path};
	Error ->
	    {Error,Path}
    end.

replace_path1(Name,Dir,[P|Path],NameDb) ->
    case get_name(P) of
	Name ->
	    insert_name(Name, Dir, NameDb),
	    [Dir|Path];
	_ ->
	    [P|replace_path1(Name,Dir,Path,NameDb)]
    end;
replace_path1(Name, Dir, [], NameDb) ->
    insert_name(Name, Dir, NameDb),
    [Dir].

check_pars(Name,Dir) ->
    N = to_list(Name),
    D = filename:join([to_list(Dir)]), % Normalize
    case get_name(Dir) of
	N ->
	    case check_path([D]) of
		{ok, [NewD]} ->
		    {ok,N,NewD};
		Error ->
		    Error
	    end;
	_ ->
	    {error,bad_name}
    end.

del_ebin(Dir) ->
    filename:join(del_ebin_1(filename:split(Dir))).

del_ebin_1([Parent,App,"ebin"]) ->
    Ext = archive_extension(),
    case filename:basename(Parent, Ext) of
	Parent ->
	    %% Plain directory.
	    [Parent,App];
	Archive ->
	    %% Archive.
	    [Archive]
    end;
del_ebin_1([H|T]) ->
    [H|del_ebin_1(T)];
del_ebin_1([]) ->
    [].

replace_name(Dir, Db) ->
    case get_name(Dir) of
	Dir ->
	    false;
	Name ->
	    delete_name(Name, Db),
	    insert_name(Name, Dir, Db)
    end.

delete_name(Name, Db) ->
    ets:delete(Db, Name).

delete_name_dir(Dir, Db) ->
    case get_name(Dir) of
	Dir  -> false;
	Name ->
	    Dir0 = del_ebin(Dir),
	    case lookup_name(Name, Db) of
		{ok, Dir0, _Base, _SubDirs} ->
		    ets:delete(Db, Name), 
		    true;
		_ -> false
	    end
    end.

lookup_name(Name, Db) ->
    case ets:lookup(Db, Name) of
	[{Name, Dir, Base, SubDirs}] -> {ok, Dir, Base, SubDirs};
	_ -> false
    end.


%%
%% Fetch a directory.
%%
do_dir(Root,lib_dir,_) ->
    filename:append(Root, "lib");
do_dir(Root,root_dir,_) ->
    Root;
do_dir(_Root,compiler_dir,NameDb) ->
    case lookup_name("compiler", NameDb) of
	{ok, Dir, _Base, _SubDirs} -> Dir;
	_  -> ""
    end;
do_dir(_Root,{lib_dir,Name},NameDb) ->
    case catch lookup_name(to_list(Name), NameDb) of
	{ok, Dir, _Base, _SubDirs} -> Dir;
	_         -> {error, bad_name}
    end;
do_dir(_Root,{lib_dir,Name,SubDir0},NameDb) ->
    SubDir = atom_to_list(SubDir0),
    case catch lookup_name(to_list(Name), NameDb) of
	{ok, Dir, Base, SubDirs} ->
	    case lists:member(SubDir, SubDirs) of
		true ->
		    %% Subdir is in archive
		    filename:join([Dir ++ archive_extension(),
				   Base,
				   SubDir]);
		false ->
		    %% Subdir is regular directory
		    filename:join([Dir, SubDir])
	    end;
	_  -> 
	    {error, bad_name}
    end;
do_dir(_Root,{priv_dir,Name},NameDb) ->
    do_dir(_Root,{lib_dir,Name,priv},NameDb);
do_dir(_, _, _) ->
    'bad request to code'.

stick_dir(Dir, Stick, St) ->
    case erl_prim_loader:list_dir(Dir) of
	{ok,Listing} ->
	    Mods = get_mods(Listing, objfile_extension()),
	    Db = St#state.moddb,
	    case Stick of
		true ->
		    foreach(fun (M) -> ets:insert(Db, {{sticky,M},true}) end, Mods);
		false ->
		    foreach(fun (M) -> ets:delete(Db, {sticky,M}) end, Mods)
	    end;
	Error -> 
	    Error
    end.

stick_mod(M, Stick, St) ->
    Db = St#state.moddb,
    case Stick of
	true ->
	    ets:insert(Db, {{sticky,M},true});
	false ->
	    ets:delete(Db, {sticky,M})
    end.

get_mods([File|Tail], Extension) ->
    case filename:extension(File) of
	Extension ->
	    [list_to_atom(filename:basename(File, Extension)) |
	     get_mods(Tail, Extension)];
	_ ->
	    get_mods(Tail, Extension)
    end;
get_mods([], _) -> [].

is_sticky(Mod, Db) ->
    erlang:module_loaded(Mod) andalso (ets:lookup(Db, {sticky, Mod}) =/= []).

add_paths(Where,[Dir|Tail],Path,NameDb) ->
    {_,NPath} = add_path(Where,Dir,Path,NameDb),
    add_paths(Where,Tail,NPath,NameDb);
add_paths(_,_,Path,_) ->
    {ok,Path}.

do_load_binary(Module, File, Binary, From, St) ->
    case modp(File) andalso is_binary(Binary) of
	true ->
	    case erlang:module_loaded(Module) of
		true -> do_purge(Module);
		false -> ok
	    end,
	    try_load_module(File, Module, Binary, From, St);
	false ->
	    {reply,{error,badarg},St}
    end.

modp(Atom) when is_atom(Atom) -> true;
modp(List) when is_list(List) -> int_list(List);
modp(_)                       -> false.

load_abs(File, Mod, From, St) ->
    Ext = objfile_extension(),
    FileName0 = lists:concat([File, Ext]),
    FileName = absname(FileName0),
    case erl_prim_loader:get_file(FileName) of
	{ok,Bin,_} ->
	    try_load_module(FileName, Mod, Bin, From, St);
	error ->
	    {reply,{error,nofile},St}
    end.

try_load_module(File, Mod, Bin, From, St0) ->
    case pending_on_load(Mod, From, St0) of
	no ->
	    try_load_module_1(File, Mod, Bin, From, St0);
	{yes,St} ->
	    {noreply,St}
    end.

try_load_module_1(File, Mod, Bin, From, #state{moddb=Db}=St) ->
    case is_sticky(Mod, Db) of
	true ->                         %% Sticky file reject the load
	    error_msg("Can't load module '~w' that resides in sticky dir\n",[Mod]),
	    {reply,{error,sticky_directory},St};
	false ->
            Architecture = erlang:system_info(hipe_architecture),
            try_load_module_2(File, Mod, Bin, From, Architecture, St)
    end.

try_load_module_2(File, Mod, Bin, From, undefined, St) ->
    try_load_module_3(File, Mod, Bin, From, undefined, St);
try_load_module_2(File, Mod, Bin, From, Architecture,
                  #state{moddb=Db}=St) ->
    case catch hipe_unified_loader:load_native_code(Mod, Bin, Architecture) of
        {module,Mod} = Module ->
	    ets:insert(Db, [{{native,Mod},true},{Mod,File}]),
            {reply,Module,St};
        no_native ->
            try_load_module_3(File, Mod, Bin, From, Architecture, St);
        Error ->
            error_msg("Native loading of ~ts failed: ~p\n", [File,Error]),
            {reply,ok,St}
    end.

try_load_module_3(File, Mod, Bin, From, Architecture,
                  #state{moddb=Db}=St) ->
    case erlang:load_module(Mod, Bin) of
        {module,Mod} = Module ->
            ets:insert(Db, {Mod,File}),
            post_beam_load([Mod], Architecture, St),
            {reply,Module,St};
        {error,on_load} ->
            handle_on_load(Mod, File, From, St);
        {error,What} = Error ->
            error_msg("Loading of ~ts failed: ~p\n", [File, What]),
            {reply,Error,St}
    end.

hipe_result_to_status(Result, #state{moddb=Db}) ->
    case Result of
	{module,Mod} ->
	    ets:insert(Db, [{{native,Mod},true}]),
	    Result;
	_ ->
	    {error,Result}
    end.

post_beam_load(_, undefined, _) ->
    %% HiPE is disabled.
    ok;
post_beam_load(Mods0, _Architecture, #state{moddb=Db}) ->
    %% post_beam_load/2 can potentially be very expensive because it
    %% blocks multi-scheduling. Therefore, we only want to call
    %% it with modules that are known to have native code loaded.
    Mods = [M || M <- Mods0, ets:member(Db, {native,M})],
    hipe_unified_loader:post_beam_load(Mods).

int_list([H|T]) when is_integer(H) -> int_list(T);
int_list([_|_])                    -> false;
int_list([])                       -> true.

load_file(Mod, From, St0) ->
    case pending_on_load(Mod, From, St0) of
	no -> load_file_1(Mod, From, St0);
	{yes,St} -> {noreply,St}
    end.

load_file_1(Mod, From, #state{path=Path}=St) ->
    case mod_to_bin(Path, Mod) of
	error ->
	    {reply,{error,nofile},St};
	{Mod,Binary,File} ->
	    try_load_module_1(File, Mod, Binary, From, St)
    end.

mod_to_bin([Dir|Tail], Mod) ->
    File = filename:append(Dir, atom_to_list(Mod) ++ objfile_extension()),
    case erl_prim_loader:get_file(File) of
	error -> 
	    mod_to_bin(Tail, Mod);
	{ok,Bin,_} ->
	    case filename:pathtype(File) of
		absolute ->
		    {Mod,Bin,File};
		_ ->
		    {Mod,Bin,absname(File)}
	    end
    end;
mod_to_bin([], Mod) ->
    %% At last, try also erl_prim_loader's own method
    File = to_list(Mod) ++ objfile_extension(),
    case erl_prim_loader:get_file(File) of
	error -> 
	    error;     % No more alternatives !
	{ok,Bin,FName} ->
	    {Mod,Bin,absname(FName)}
    end.

absname(File) ->
    case erl_prim_loader:get_cwd() of
	{ok,Cwd} -> absname(File, Cwd);
	_Error -> File
    end.

absname(Name, AbsBase) ->
    case filename:pathtype(Name) of
	relative ->
	    filename:absname_join(AbsBase, Name);
	absolute ->
	    %% We must flatten the filename before passing it into join/1,
	    %% or we will get slashes inserted into the wrong places.
	    filename:join([filename:flatten(Name)]);
	volumerelative ->
	    absname_vr(filename:split(Name), filename:split(AbsBase), AbsBase)
    end.

%% Handles volumerelative names (on Windows only).

absname_vr(["/"|Rest1], [Volume|_], _AbsBase) ->
    %% Absolute path on current drive.
    filename:join([Volume|Rest1]);
absname_vr([[X, $:]|Rest1], [[X|_]|_], AbsBase) ->
    %% Relative to current directory on current drive.
    absname(filename:join(Rest1), AbsBase);
absname_vr([[X, $:]|Name], _, _AbsBase) ->
    %% Relative to current directory on another drive.
    Dcwd =
	case erl_prim_loader:get_cwd([X, $:]) of
	    {ok, Dir}  -> Dir;
	    error -> [X, $:, $/]
    end,
    absname(filename:join(Name), Dcwd).


is_loaded(M, Db) ->
    case ets:lookup(Db, M) of
	[{M,File}] -> {file,File};
	[] -> false
    end.

do_purge(Mod) ->
    {_WasOld, DidKill} = erts_code_purger:purge(Mod),
    DidKill.

do_soft_purge(Mod) ->
    erts_code_purger:soft_purge(Mod).

is_dir(Path) ->
    case erl_prim_loader:read_file_info(Path) of
	{ok,#file_info{type=directory}} -> true;
	_ -> false
    end.

%%%
%%% Loading of multiple modules in parallel.
%%%

finish_loading(Prepared, EnsureLoaded, #state{moddb=Db}=St) ->
    Ps = [fun(L) -> finish_loading_ensure(L, EnsureLoaded) end,
	  fun(L) -> abort_if_pending_on_load(L, St) end,
	  fun(L) -> abort_if_sticky(L, Db) end,
	  fun(L) -> do_finish_loading(L, St) end],
    run(Ps, Prepared).

finish_loading_ensure(Prepared, true) ->
    {ok,[P || {M,_}=P <- Prepared, not erlang:module_loaded(M)]};
finish_loading_ensure(Prepared, false) ->
    {ok,Prepared}.

abort_if_pending_on_load(L, #state{on_load=[]}) ->
    {ok,L};
abort_if_pending_on_load(L, #state{on_load=OnLoad}) ->
    Pending = [{M,pending_on_load} ||
		  {M,_} <- L,
		  lists:keymember(M, 2, OnLoad)],
    case Pending of
	[] -> {ok,L};
	[_|_] -> {error,Pending}
    end.

abort_if_sticky(L, Db) ->
    Sticky = [{M,sticky_directory} || {M,_} <- L, is_sticky(M, Db)],
    case Sticky of
	[] -> {ok,L};
	[_|_] -> {error,Sticky}
    end.

do_finish_loading(Prepared, #state{moddb=Db}=St) ->
    MagicBins = [B || {_,{B,_}} <- Prepared],
    case erlang:finish_loading(MagicBins) of
	ok ->
	    MFs = [{M,F} || {M,{_,F}} <- Prepared],
	    true = ets:insert(Db, MFs),
	    Ms = [M || {M,_} <- MFs],
	    Architecture = erlang:system_info(hipe_architecture),
	    post_beam_load(Ms, Architecture, St),
	    ok;
	{Reason,Ms} ->
	    {error,[{M,Reason} || M <- Ms]}
    end.

run([F], Data) ->
    F(Data);
run([F|Fs], Data0) ->
    case F(Data0) of
	{ok,Data} ->
	    run(Fs, Data);
	{error,_}=Error ->
	    Error
    end.

%% -------------------------------------------------------
%% The on_load functionality.
%% -------------------------------------------------------

handle_on_load(Mod, File, From, #state{on_load=OnLoad0}=St0) ->
    Fun = fun() ->
		  Res = erlang:call_on_load_function(Mod),
		  exit(Res)
	  end,
    {_,Ref} = spawn_monitor(Fun),
    OnLoad = [{Ref,Mod,File,[From]}|OnLoad0],
    St = St0#state{on_load=OnLoad},
    {noreply,St}.

pending_on_load(_, _, #state{on_load=[]}) ->
    no;
pending_on_load(Mod, From, #state{on_load=OnLoad0}=St) ->
    case lists:keymember(Mod, 2, OnLoad0) of
	false ->
	    no;
	true ->
	    OnLoad = pending_on_load_1(Mod, From, OnLoad0),
	    {yes,St#state{on_load=OnLoad}}
    end.

pending_on_load_1(Mod, From, [{Ref,Mod,File,Pids}|T]) ->
    [{Ref,Mod,File,[From|Pids]}|T];
pending_on_load_1(Mod, From, [H|T]) ->
    [H|pending_on_load_1(Mod, From, T)];
pending_on_load_1(_, _, []) -> [].

finish_on_load(Ref, OnLoadRes, #state{on_load=OnLoad0,moddb=Db}=State) ->
    case lists:keyfind(Ref, 1, OnLoad0) of
	false ->
	    %% Since this process in general silently ignores messages
	    %% it doesn't understand, it should also ignore a 'DOWN'
	    %% message with an unknown reference.
	    State;
	{Ref,Mod,File,WaitingPids} ->
	    finish_on_load_1(Mod, File, OnLoadRes, WaitingPids, Db),
	    OnLoad = [E || {R,_,_,_}=E <- OnLoad0, R =/= Ref],
	    State#state{on_load=OnLoad}
    end.

finish_on_load_1(Mod, File, OnLoadRes, WaitingPids, Db) ->
    Keep = OnLoadRes =:= ok,
    erlang:finish_after_on_load(Mod, Keep),
    Res = case Keep of
	      false ->
		  _ = finish_on_load_report(Mod, OnLoadRes),
		  _ = erts_code_purger:purge(Mod),
		  {error,on_load_failure};
	      true ->
		  ets:insert(Db, {Mod,File}),
		  {module,Mod}
	  end,
    _ = [reply(Pid, Res) || Pid <- WaitingPids],
    ok.

finish_on_load_report(_Mod, Atom) when is_atom(Atom) ->
    %% No error reports for atoms.
    ok;
finish_on_load_report(Mod, Term) ->
    %% Play it very safe here. The error_logger module and
    %% modules it depend on may not be loaded yet and there
    %% would be a dead-lock if we called it directly
    %% from the code_server process.
    spawn(fun() ->
		  F = "The on_load function for module "
		      "~s returned ~P\n",

		  %% Express the call as an apply to simplify
		  %% the ext_mod_dep/1 test case.
		  E = error_logger,
		  E:warning_msg(F, [Mod,Term,10])
	  end).

%% -------------------------------------------------------
%% Internal functions.
%% -------------------------------------------------------

all_loaded(Db) ->
    Ms = ets:fun2ms(fun({M,_}=T) when is_atom(M) -> T end),
    ets:select(Db, Ms).

-spec error_msg(io:format(), [term()]) -> 'ok'.
error_msg(Format, Args) ->
    Msg = {notify,{error, group_leader(), {self(), Format, Args}}},
    error_logger ! Msg,
    ok.

-spec info_msg(io:format(), [term()]) -> 'ok'.
info_msg(Format, Args) ->
    Msg = {notify,{info_msg, group_leader(), {self(), Format, Args}}},
    error_logger ! Msg,
    ok.

objfile_extension() ->
    init:objfile_extension().

archive_extension() ->
    init:archive_extension().

to_list(X) when is_list(X) -> X;
to_list(X) when is_atom(X) -> atom_to_list(X).