diff options
Diffstat (limited to 'lib/gs/src/gstk.erl')
| -rw-r--r-- | lib/gs/src/gstk.erl | 386 |
1 files changed, 386 insertions, 0 deletions
diff --git a/lib/gs/src/gstk.erl b/lib/gs/src/gstk.erl new file mode 100644 index 0000000000..6f83cf8be4 --- /dev/null +++ b/lib/gs/src/gstk.erl @@ -0,0 +1,386 @@ +%% +%% %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% +%% + +%% + +-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. |