gstk.erl

来自「OTP是开放电信平台的简称」· ERL 代码 · 共 384 行

%% ``The contents of this file are subject to the Erlang Public License,
%% Version 1.1, (the "License"); you may not use this file except in
%% compliance with the License. You should have received a copy of the
%% Erlang Public License along with this software. If not, it can be
%% retrieved via the world wide web at http://www.erlang.org/.
%% 
%% Software distributed under the License is distributed on an "AS IS"
%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See
%% the License for the specific language governing rights and limitations
%% under the License.
%% 
%% The Initial Developer of the Original Code is Ericsson Utvecklings AB.
%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings
%% AB. All Rights Reserved.''
%% 
%%     $Id$
%%

-module(gstk).

-export([start_link/4,
	 stop/1,
	 create/2,
	 config/2,
	 read/2,
	 destroy/2,
	 pid_died/2,
	 event/2,
	 request/2,
	 init/1,
	 create_impl/2,
	 config_impl/3,
	 read_impl/3,
	 destroy_impl/2,
	 worker_init/1,
	 worker_do/1,
	 make_extern_id/2,
	 to_color/1,
	 to_ascii/1,
	 exec/1,
	 call/1]).

-include("gstk.hrl").

start_link(GsId,FrontendNode,Owner,Options) ->
    case gs:assq(node,Options) of
	false ->
	    Gstk = spawn_link(gstk, init,[{GsId, FrontendNode, Owner, Options}]),
	    receive
		{ok, _PortHandler} ->
		    {ok, Gstk};
		{error, Reason} ->
		    {error, Reason}
	    end;
	{value, Node} ->
	    rpc:call(Node,gen_server,start_link,[gstk, {Owner,Options},[]])
    end.

stop(BackendServ) -> 
    request(BackendServ,stop).

create(BackendServ,Args) ->
    request(BackendServ,{create,Args}).

config(BackendServ,Args) ->
    request(BackendServ,{config,Args}).

read(BackendServ,Args) ->
    request(BackendServ,{read,Args}).

destroy(BackendServ,Args) ->
    request(BackendServ,{destroy,Args}).

pid_died(BackendServ,Pid) ->
    request(BackendServ,{pid_died,Pid}).

call(Cmd) ->
    %%io:format("Call:~p~n",[Cmd]),
    gstk_port_handler:call(get(port_handler),Cmd).

exec(Cmd) ->
    gstk_port_handler:exec(Cmd). 

make_extern_id(IntId, DB) ->
    [{_,Node}] = ets:lookup(DB,frontend_node),
    {IntId,Node}.

event(BackendServ,Event) ->
    BackendServ!{event,Event}.

%% -----------------------------------------------------------------------------

request(Who,Msg) ->
    Who ! {self(),Msg},
    receive
	{gstk_reply,R} -> R;
	{'EXIT',Who,Reason} ->
	    self() ! {'EXIT',Who,Reason},
	    {error,Reason}
    end.


-record(state,{db,frontendnode,port_handler}).

%% ------------------------------------------------------------
%% Initialize
%%
init({GsId,FrontendNode,Owner,Opts}) ->
    put(gs_frontend,Owner),
    case gstk_port_handler:start_link(self()) of
	{error, Reason} ->
	    FrontendNode ! {error, Reason},
	    exit(normal);
	{ok, PortHandler} ->
	    FrontendNode ! {ok, PortHandler},
	    put(port_handler,PortHandler),
	    {ok,Port} = gstk_port_handler:ping(PortHandler),
	    put(port,Port),
	    exec("wm withdraw ."),
	    DB = gstk_db:init(Opts),
	    ets:insert(DB,{frontend_node,FrontendNode}),
	    put(worker,spawn_link(gstk,worker_init,[0])),
	    Gstkid = #gstkid{id=GsId,widget="",owner=Owner,objtype=gs},
	    gstk_db:insert_gs(DB,Gstkid),
	    gstk_font:init(),
	    loop(#state{db=DB,frontendnode=FrontendNode})
    end.

loop(State) ->
    receive
	X ->
	    case (doit(X,State)) of
		done -> loop(State);
		stop -> bye
	    end
    end.

reply(To,Msg) ->
    To ! {gstk_reply,Msg},
    done.

doit({From,{config, {Id, Opts}}},#state{db=DB}) ->
    reply(From,config_impl(DB,Id,Opts));
doit({From,{create, Args}}, #state{db=DB}) ->
    reply(From,create_impl(DB,Args));
doit({From,{read,{Id,Opt}}},#state{db=DB}) ->
    reply(From,read_impl(DB,Id,Opt));
doit({From,{pid_died, Pid}}, #state{db=DB}) ->
    pid_died_impl(DB, Pid),
    reply(From,gstk_db:get_deleted(DB));
doit({From,{destroy, Id}}, #state{db=DB}) ->
    destroy_impl(DB, gstk_db:lookup_gstkid(DB,Id)),
    reply(From,gstk_db:get_deleted(DB));

doit({From,dump_db},State) ->
    io:format("gstk_db:~p~n",[lists:sort(ets:tab2list(State#state.db))]),
    io:format("events:~p~n",[lists:sort(ets:tab2list(get(events)))]),
    io:format("options:~p~n",[lists:sort(ets:tab2list(get(options)))]),
    io:format("defaults:~p~n",[lists:sort(ets:tab2list(get(defaults)))]),
    io:format("kids:~p~n",[lists:sort(ets:tab2list(get(kids)))]),
    reply(From,State);

doit({From,stop},_State) ->
    gstk_port_handler:stop(get(port_handler)),
    exit(get(worker),kill),
    reply(From,stopped),
    stop;

doit({event,{Id, Etag, Args}},#state{db=DB}) ->
    case gstk_db:lookup_event(DB, Id, Etag) of
        {Etype, Edata} ->
            Gstkid = gstk_db:lookup_gstkid(DB, Id),
            apply(gstk_widgets:objmod(Gstkid),event,[DB,Gstkid,Etype,Edata,Args]);
        _ -> true
    end,
    done.


%%----------------------------------------------------------------------
%% Implementation of create,config,read,destroy
%% Comment: In the gstk process there is not concept call 'name', only
%%          pure oids. Names are stripped of by 'gs' and this simplifies
%%          gstk a lot.
%% Comment: For performance reasons gstk.erl ans gs.erl communicats through
%%          tuples. This is unfortunate but we don't want to pack the same
%%          thing too many times.
%% Pre (for all functions): GS guarantees that the object (and parent if
%%          necessary) exists.
%%----------------------------------------------------------------------


create_impl(DB, {Owner, {Objtype, Id, Parent, Opts}}) ->
    Pgstkid = gstk_db:lookup_gstkid(DB, Parent),
    GstkId=#gstkid{id=Id,owner=Owner,parent=Parent,objtype=Objtype},
    gstk_db:insert_opt(DB,Id,{data,[]}),
    RealOpts=apply(gstk_widgets:objmod(Pgstkid),
		   mk_create_opts_for_child,[DB,GstkId,Pgstkid,Opts]),
    case gstk_widgets:type2mod(Objtype) of
	{error,Reason} -> {error,Reason};
	ObjMod ->
	    case apply(ObjMod, create, [DB, GstkId, RealOpts]) of
		{bad_result, BR} ->
		    gstk_db:delete_gstkid(DB,GstkId),
		    gs:creation_error(GstkId,{bad_result, BR});
		Ngstkid when is_record(Ngstkid,gstkid) ->
		    gstk_db:insert_widget(DB, Ngstkid),
		    ok;
		{error,Reason} -> {error,Reason};
		ok -> ok
	    end
    end.

config_impl(DB,Id,Opts) ->
    Gstkid = gstk_db:lookup_gstkid(DB, Id), 
    case apply(gstk_widgets:objmod(Gstkid), config, [DB, Gstkid, Opts]) of
	ok -> ok;
	{bad_result,R} -> {error,R};
	{error,Reason} -> {error,Reason};
	Q -> {error,Q}
    end.


read_impl(DB,Id,Opt) ->
    Gstkid = gstk_db:lookup_gstkid(DB, Id), 
    case apply(gstk_widgets:objmod(Gstkid), read, [DB, Gstkid, Opt]) of
	{bad_result,R} -> {error,R};
	{error,R} -> {error,R};
	Res -> Res
    end.



%%-----------------------------------------------------------------------------
%%			DESTROYING A WIDGET
%%-----------------------------------------------------------------------------

destroy_impl(DB, Gstkid) ->
    worker_do({delay_is,50}),
    Widget = delete_only_this_widget(DB,Gstkid),
    destroy_widgets([Widget], DB),
    worker_do({delay_is,5}),
    true.

delete_only_this_widget(DB,Gstkid) ->
    #gstkid{id=ID,objtype=OT,parent=P} = Gstkid,
    delete_widgets(gstk_db:lookup_kids(DB, ID), DB),
    Widget = apply(gstk_widgets:type2mod(OT), delete, [DB, Gstkid]),
    gstk_db:delete_kid(DB, P, ID),
    Widget.


pid_died_impl(DB, Pid) ->
    case lists:sort(gstk_db:lookup_ids(DB, Pid)) of
	[ID | IDs] ->
	    Gstkid = gstk_db:lookup_gstkid(DB, ID),
	    destroy_impl(DB, Gstkid),
	    Tops = get_tops(IDs, DB),
	    destroy_widgets(Tops, DB);
	_ ->
	    true
    end.


get_tops([ID | IDs], DB) ->
    case gstk_db:lookup_gstkid(DB, ID) of
	undefined ->
	    get_tops(IDs, DB);
	Gstkid -> 
	    Parent = Gstkid#gstkid.parent,
	    case lists:member(Parent, IDs) of
		true  ->
		    delete_widgets([ID], DB),
		    get_tops(IDs, DB);
		false ->
		    Widget = delete_only_this_widget(DB,Gstkid),
		    [Widget | get_tops(IDs, DB)]
	    end
    end;
get_tops([], _DB) -> [].


delete_widgets([ID | Rest], DB) ->
    delete_widgets(gstk_db:lookup_kids(DB, ID), DB),
    case gstk_db:lookup_gstkid(DB, ID) of
	undefined ->
	    delete_widgets(Rest, DB);
	Gstkid ->
	    apply(gstk_widgets:objmod(Gstkid), delete, [DB, Gstkid]),
	    delete_widgets(Rest, DB)
    end;
delete_widgets([], _) -> true.



destroy_widgets(Widgets, DB) ->
    case destroy_wids(Widgets, DB) of
	[]       -> true;
	Destroys -> exec(["destroy ", Destroys])
    end.


destroy_wids([{Parent, ID, Objmod, Args} | Rest], DB) ->
    gstk_db:delete_kid(DB, Parent, ID),
    apply(Objmod, destroy, [DB | Args]),
    destroy_wids(Rest, DB);

destroy_wids([W | Rest], DB) ->
    [W, " "| destroy_wids(Rest, DB)];

destroy_wids([], _DB) -> [].


%% ----- The Color Model -----

to_color({R,G,B}) ->
    [$#,dec2hex(2,R),dec2hex(2,G),dec2hex(2,B)];
to_color(Color) when is_atom(Color) -> atom_to_list(Color).

%% ------------------------------------------------------------
%% Decimal to Hex converter
%% M is number of digits we want
%% N is the decimal to be converted

dec2hex(M,N) -> dec2hex(M,N,[]).

dec2hex(0,_N,Ack) -> Ack;
dec2hex(M,N,Ack) -> dec2hex(M-1,N bsr 4,[d2h(N band 15)|Ack]).

d2h(N) when N<10 -> N+$0;
d2h(N) -> N+$a-10.


%% ----- Value to String -----

to_ascii(V) when is_list(V)    -> [$",to_ascii(V,[],[]),$"];  %% it's a string
to_ascii(V) when is_integer(V) -> integer_to_list(V);
to_ascii(V) when is_float(V)   -> float_to_list(V);
to_ascii(V) when is_atom(V)    -> to_ascii( atom_to_list(V));
to_ascii(V) when is_tuple(V)   -> to_ascii(lists:flatten(io_lib:format("~w",[V])));
to_ascii(V) when is_pid(V)     -> pid_to_list(V).

						% FIXME: Currently we accept newlines in strings and handle this at
						% the Tcl side. Is this the best way or should we translate to "\n"
						% here?
to_ascii([$[|R], Y, X) ->  to_ascii(R, Y, [$[, $\\ | X]);
				    to_ascii([$]|R], Y, X) ->  to_ascii(R, Y, [$], $\\ | X]);
to_ascii([${|R], Y, X) ->  to_ascii(R, Y, [${, $\\ | X]);
				    to_ascii([$}|R], Y, X) ->  to_ascii(R, Y, [$}, $\\ | X]);
to_ascii([$"|R], Y, X) ->  to_ascii(R, Y, [$", $\\ | X]);
to_ascii([$$|R], Y, X) ->  to_ascii(R, Y, [$$, $\\ | X]);
to_ascii([$\\|R], Y, X) ->  to_ascii(R, Y, [$\\, $\\ | X]);
to_ascii([C|R], Y, X) when is_list(C) -> to_ascii(C, [R|Y], X);
to_ascii([C|R], Y, X) -> to_ascii(R, Y, [C|X]);
to_ascii([], [Y1|Y], X) -> to_ascii(Y1, Y, X);
to_ascii([], [], X) -> lists:reverse(X).

worker_do(Msg) ->
    get(worker) ! Msg.

worker_init(Delay) ->
    receive
	{delay_is,D} ->
	    worker_init(D);
	{match_delete,DBExprs} ->
	    worker_match(DBExprs),
	    if Delay > 0 ->
		    receive
			{delay_is,D} ->
			    worker_init(D)
		    after Delay ->
			    worker_init(Delay)
		    end;
	       true -> 
		    worker_init(Delay)
	    end
    end.

worker_match([{DB,[Expr|Exprs]}|DbExprs]) ->
    ets:match_delete(DB,Expr),
    worker_match([{DB,Exprs}|DbExprs]);
worker_match([{_DB,[]}|DbExprs]) ->
    worker_match(DbExprs);
worker_match([]) -> done.