%%
%% %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.
