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.erl389
1 files changed, 0 insertions, 389 deletions
diff --git a/lib/gs/src/gstk.erl b/lib/gs/src/gstk.erl
deleted file mode 100644
index 3119245db7..0000000000
--- a/lib/gs/src/gstk.erl
+++ /dev/null
@@ -1,389 +0,0 @@
-%%
-%% %CopyrightBegin%
-%%
-%% Copyright Ericsson AB 1996-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(gstk).
--compile([{nowarn_deprecated_function,{gs,assq,2}},
- {nowarn_deprecated_function,{gs,creation_error,2}}]).
-
--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.
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-01 20:45:46 +0000