aboutsummaryrefslogtreecommitdiffstats
path: root/lib/gs/src/gstk.erl
diff options
context:
space:
mode:
Diffstat (limited to 'lib/gs/src/gstk.erl')
-rw-r--r--lib/gs/src/gstk.erl386
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.