diff options
Diffstat (limited to 'lib/gs/src')
44 files changed, 0 insertions, 13247 deletions
diff --git a/lib/gs/src/Makefile b/lib/gs/src/Makefile deleted file mode 100644 index e19ce822b9..0000000000 --- a/lib/gs/src/Makefile +++ /dev/null @@ -1,121 +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% -# - -# -include $(ERL_TOP)/make/target.mk -include $(ERL_TOP)/make/$(TARGET)/otp.mk - -# ---------------------------------------------------- -# Application version -# ---------------------------------------------------- -include ../vsn.mk -VSN=$(GS_VSN) - -# ---------------------------------------------------- -# Release directory specification -# ---------------------------------------------------- -RELSYSDIR = $(RELEASE_PATH)/lib/gs-$(VSN) - -ERL = erl - -# ---------------------------------------------------- -# Target Specs -# ---------------------------------------------------- -MODULES= gs gs_frontend gs_make gs_widgets gstk gstk_arc gstk_button\ - gstk_canvas gstk_checkbutton gstk_db gstk_editor gstk_entry \ - gstk_font gstk_frame gstk_grid gstk_gridline gs_packer \ - gstk_gs gstk_image gstk_label gstk_line gstk_listbox gstk_menu\ - gstk_menubar gstk_menubutton gstk_menuitem gstk_oval gstk_polygon \ - gstk_port_handler gstk_radiobutton gstk_rectangle gstk_scale \ - gstk_text gstk_widgets gstk_window tcl2erl tool_utils \ - tool_file_dialog gse - -GSTK_GENERIC = gstk_generic.erl - -HRL_FILES = gstk.hrl -GEN_HRL_FILES = gstk_generic.hrl -GSTK_GENERIC_TARGET = $(EBIN)/gstk_generic.$(EMULATOR) - -ERL_FILES= $(MODULES:%=%.erl) - -TARGET_FILES= $(MODULES:%=../ebin/%.$(EMULATOR)) $(GEN_HRL_FILES) \ - $(GSTK_GENERIC_TARGET) $(APP_TARGET) $(APPUP_TARGET) - -APP_FILE= gs.app -APPUP_FILE= gs.appup - -APP_SRC= $(APP_FILE).src -APPUP_SRC= $(APPUP_FILE).src - -APP_TARGET= ../ebin/$(APP_FILE) -APPUP_TARGET= ../ebin/$(APPUP_FILE) - -IMAGES=../priv/bitmap/fup.bm - - -# ---------------------------------------------------- -# FLAGS -# ---------------------------------------------------- -ERL_COMPILE_FLAGS += +warn_obsolete_guard -Werror - -# ---------------------------------------------------- -# Targets -# ---------------------------------------------------- - -debug opt: $(TARGET_FILES) - -docs: - -clean: - rm -f $(TARGET_FILES) - rm -f core *~ - -# ---------------------------------------------------- -# Special Build Targets -# ---------------------------------------------------- - -gstk_generic.hrl: gs_make.erl ../ebin/gs_make.$(EMULATOR) ../ebin/gs.$(EMULATOR) - $(gen_verbose)$(ERL) -pa $(EBIN) -s gs_make -s erlang halt -noshell - -$(APP_TARGET): $(APP_SRC) ../vsn.mk - $(vsn_verbose)sed -e 's;%VSN%;$(VSN);' $< > $@ - -$(APPUP_TARGET): $(APPUP_SRC) ../vsn.mk - $(vsn_verbose)sed -e 's;%VSN%;$(VSN);' $< > $@ - -$(GSTK_GENERIC_TARGET): gstk_generic.hrl - -# ---------------------------------------------------- -# Release Target -# ---------------------------------------------------- -include $(ERL_TOP)/make/otp_release_targets.mk - -release_spec: opt - $(INSTALL_DIR) "$(RELSYSDIR)/src" - $(INSTALL_DATA) $(APP_SRC) $(ERL_FILES) $(HRL_FILES) $(GEN_HRL_FILES) \ - $(GSTK_GENERIC) "$(RELSYSDIR)/src" - $(INSTALL_DIR) "$(RELSYSDIR)/ebin" - $(INSTALL_DATA) $(TARGET_FILES) "$(RELSYSDIR)/ebin" - $(INSTALL_DIR) "$(RELSYSDIR)/priv/bitmap" - $(INSTALL_DATA) $(IMAGES) "$(RELSYSDIR)/priv/bitmap" - - -release_docs_spec: - diff --git a/lib/gs/src/gs.app.src b/lib/gs/src/gs.app.src deleted file mode 100644 index c6f88e5144..0000000000 --- a/lib/gs/src/gs.app.src +++ /dev/null @@ -1,14 +0,0 @@ -{application, gs, - [{description, "GS The Graphics System"}, - {vsn, "%VSN%"}, - {modules, [gs,gs_frontend,gs_make,gs_widgets,gstk,gstk_arc,gstk_button, - gstk_canvas,gstk_checkbutton,gstk_db,gstk_editor,gstk_entry, - gstk_font,gstk_frame,gstk_generic,gstk_grid,gstk_gridline,gstk_gs, - gstk_image,gstk_label,gstk_line,gstk_listbox,gstk_menu,gstk_menubar, - gstk_menubutton,gstk_menuitem,gstk_oval,gstk_polygon,gstk_port_handler, - gstk_radiobutton,gstk_rectangle,gstk_scale,gstk_text,gstk_widgets, - gstk_window,tcl2erl,tool_file_dialog,tool_utils, - gs_packer,gse]}, - {registered, [gs_frontend]}, - {applications, [kernel, stdlib]}, - {runtime_dependencies, ["stdlib-2.0","kernel-3.0","erts-6.0"]}]}. diff --git a/lib/gs/src/gs.appup.src b/lib/gs/src/gs.appup.src deleted file mode 100644 index 6cc21676e8..0000000000 --- a/lib/gs/src/gs.appup.src +++ /dev/null @@ -1,22 +0,0 @@ -%% -*- erlang -*- -%% %CopyrightBegin% -%% -%% Copyright Ericsson AB 2014-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% -{"%VSN%", - [{<<".*">>,[{restart_application, gs}]}], - [{<<".*">>,[{restart_application, gs}]}] -}. diff --git a/lib/gs/src/gs.erl b/lib/gs/src/gs.erl deleted file mode 100644 index 23012da75d..0000000000 --- a/lib/gs/src/gs.erl +++ /dev/null @@ -1,410 +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% -%% - -%% -%% ------------------------------------------------------------ -%% Erlang Graphics Interface and front end server -%% ------------------------------------------------------------ -%% - --module(gs). --deprecated(module). --compile([{nowarn_deprecated_function,{gs,create,3}}, - {nowarn_deprecated_function,{gs,create,4}}, - {nowarn_deprecated_function,{gs,create_tree,2}}, - {nowarn_deprecated_function,{gs,foreach,3}}, - {nowarn_deprecated_function,{gs,read,2}}, - {nowarn_deprecated_function,{gs,start,1}}]). - -%% ----- Exports ----- --export([start/0, stop/0, start/1]). --export([create/3, create/4, is_id/1]). --export([info/1,create_tree/2]). --export([config/2, read/2, destroy/1]). --export([get_id/1]). - -%% ----- Not standard but convenient ----- --export([error/2,creation_error/2,assq/2,pair/2,val/2,val/3,foreach/3]). --export([create/2]). --export([window/1,window/2,window/3,button/1,button/2,button/3]). --export([radiobutton/1,radiobutton/2,radiobutton/3]). --export([checkbutton/1,checkbutton/2,checkbutton/3]). --export([frame/1,frame/2,frame/3,label/1,label/2,label/3]). --export([message/1,message/2,message/3]). --export([listbox/1,listbox/2,listbox/3,entry/1,entry/2,entry/3]). --export([scrollbar/1,scrollbar/2,scrollbar/3]). --export([scale/1,scale/2,scale/3]). --export([canvas/1,canvas/2,canvas/3,editor/1,editor/2,editor/3]). --export([prompter/1,prompter/2,prompter/3]). --export([line/1,line/2,line/3,oval/1,oval/2,oval/3]). --export([rectangle/1,rectangle/2,rectangle/3]). --export([polygon/1,polygon/2,polygon/3]). --export([text/1,text/2,text/3,image/1,image/2,image/3,arc/1,arc/2,arc/3]). --export([menu/1,menu/2,menu/3,menubutton/1,menubutton/2,menubutton/3]). --export([menubar/1,menubar/2,menubar/3]). --export([grid/1,grid/2,grid/3]). --export([gridline/1,gridline/2,gridline/3]). --export([menuitem/1,menuitem/2,menuitem/3]). - --include("gstk.hrl"). - -%% ----- Start/Stop ----- - -start() -> - start([]). - -start(Opts) -> - Opts2 = gstk_generic:merge_default_options(gs_widgets:default_options(gs), - lists:sort(Opts)), - gs_frontend:start(Opts2). - -stop() -> - gs_frontend:stop(). - -%% ----- Widget Commands ----- - -create(Objtype, Parent) -> - GsPid = frontend(Parent), - tag_if_ok(gs_frontend:create(GsPid,{Objtype, undefined, obj_id(Parent),[]}) - ,GsPid). - -create(Objtype, Parent, Opts) when is_list(Opts) -> - GsPid = frontend(Parent), - tag_if_ok(gs_frontend:create(GsPid,{Objtype,undefined,obj_id(Parent),Opts}), - GsPid); -create(Objtype, Parent, Opt) -> - GsPid = frontend(Parent), - tag_if_ok(gs_frontend:create(GsPid, - {Objtype,undefined,obj_id(Parent),[Opt]}), - GsPid). - -create(Objtype, Name, Parent, Opts) when is_list(Opts) -> - GsPid = frontend(Parent), - tag_if_ok(gs_frontend:create(GsPid,{Objtype, Name, obj_id(Parent),Opts}), - GsPid); -create(Objtype, Name, Parent, Opt) -> - GsPid = frontend(Parent), - tag_if_ok(gs_frontend:create(GsPid,{Objtype,Name,obj_id(Parent),[Opt]}), - GsPid). - -tag_if_ok(Int,Pid) when is_integer(Int) -> - {Int,Pid}; -tag_if_ok(Err,_) -> - Err. - -config(IdOrName, Options) when is_list(Options) -> - gs_frontend:config(frontend(IdOrName),{obj_id(IdOrName),Options}); -config(IdOrName, Option) -> - gs_frontend:config(frontend(IdOrName),{obj_id(IdOrName),[Option]}). - -read(IdOrName, Option) -> - gs_frontend:read(frontend(IdOrName),{obj_id(IdOrName),Option}). - -destroy(IdOrName) -> - gs_frontend:destroy(frontend(IdOrName),obj_id(IdOrName)). - -get_id(Name) -> - read(Name,id). - -info(version) -> "1.3.2"; -info(Option) -> - gs_frontend:info(Option). - -is_id({Int,Pid}) when is_integer(Int), is_pid(Pid) -> true; -is_id(_) -> false. - -frontend({_,Pid}) when is_pid(Pid) -> Pid; -frontend({AtomName,Node}) when is_atom(AtomName),is_atom(Node) -> - rpc:call(Node,erlang,whereis,[gs_frontend]); -frontend(Atom) when is_atom(Atom) -> whereis(gs_frontend). - -obj_id({Id,_}) -> Id; -obj_id(Atom) when is_atom(Atom) -> Atom. - -error(Format, Data) -> - io:format("gs error: "), - ok = io:format(Format, Data), % don't be quiet when Format is malformed - io:format("~n"). - -creation_error(#gstkid{objtype=Ot}, {bad_result, BadResult}) -> - {error, {creation_error,Ot,BadResult}}; -creation_error(#gstkid{objtype=Ot}, BadResult) -> - {error, {creation_error,Ot,BadResult}}. - - -create_tree(ParentId,[{Type,Name,Options,Children}|R]) -> - case create(Type,Name,ParentId,Options) of - {error,_Reason} -> {error,{create_tree,aborted_at,Type,Name}}; - Id -> - case create_tree(Id,Children) of - ok -> create_tree(ParentId,R); - Err -> Err - end - end; -create_tree(ParentId,[{Type,Name,Options}|R]) when is_atom(Name) -> - create_tree(ParentId,[{Type,Name,Options,[]}|R]); -create_tree(ParentId,[{Type,Options,Children}|R]) -> - case create(Type,ParentId,Options) of - {error,_Reason} -> {error,{create_tree,aborted_at,Type,Options}}; - Id -> - case create_tree(Id,Children) of - ok -> create_tree(ParentId,R); - Err -> Err - end - end; -create_tree(ParentId,[{Type,Options}|R]) -> - create_tree(ParentId,[{Type,Options,[]}|R]); -create_tree(ParentId,Tuple) when is_tuple(Tuple) -> - create_tree(ParentId,[Tuple]); -create_tree(_,[]) -> - ok. - - -window(ParentId) -> - create(window,ParentId,[]). -window(ParentId,Options) -> - create(window,ParentId,Options). -window(Name,ParentId,Options) -> - create(window,Name,ParentId,Options). - -button(ParentId) -> - create(button,ParentId,[]). -button(ParentId,Options) -> - create(button,ParentId,Options). -button(Name,ParentId,Options) -> - create(button,Name,ParentId,Options). - -checkbutton(ParentId) -> - create(checkbutton,ParentId,[]). -checkbutton(ParentId,Options) -> - create(checkbutton,ParentId,Options). - -checkbutton(Name,ParentId,Options) -> - create(checkbutton,Name,ParentId,Options). - -radiobutton(ParentId) -> - create(radiobutton,ParentId,[]). -radiobutton(ParentId,Options) -> - create(radiobutton,ParentId,Options). -radiobutton(Name,ParentId,Options) -> - create(radiobutton,Name,ParentId,Options). - -frame(ParentId) -> - create(frame,ParentId,[]). -frame(ParentId,Options) -> - create(frame,ParentId,Options). -frame(Name,ParentId,Options) -> - create(frame,Name,ParentId,Options). - -canvas(ParentId) -> - create(canvas,ParentId,[]). -canvas(ParentId,Options) -> - create(canvas,ParentId,Options). -canvas(Name,ParentId,Options) -> - create(canvas,Name,ParentId,Options). - -label(ParentId) -> - create(label,ParentId,[]). -label(ParentId,Options) -> - create(label,ParentId,Options). -label(Name,ParentId,Options) -> - create(label,Name,ParentId,Options). - -message(ParentId) -> - create(message,ParentId,[]). -message(ParentId,Options) -> - create(message,ParentId,Options). -message(Name,ParentId,Options) -> - create(message,Name,ParentId,Options). - -listbox(ParentId) -> - create(listbox,ParentId,[]). -listbox(ParentId,Options) -> - create(listbox,ParentId,Options). -listbox(Name,ParentId,Options) -> - create(listbox,Name,ParentId,Options). - -entry(ParentId) -> - create(entry,ParentId,[]). -entry(ParentId,Options) -> - create(entry,ParentId,Options). -entry(Name,ParentId,Options) -> - create(entry,Name,ParentId,Options). - -scrollbar(ParentId) -> - create(scrollbar,ParentId,[]). -scrollbar(ParentId,Options) -> - create(scrollbar,ParentId,Options). -scrollbar(Name,ParentId,Options) -> - create(scrollbar,Name,ParentId,Options). - -scale(ParentId) -> - create(scale,ParentId,[]). -scale(ParentId,Options) -> - create(scale,ParentId,Options). -scale(Name,ParentId,Options) -> - create(scale,Name,ParentId,Options). - -editor(ParentId) -> - create(editor,ParentId,[]). -editor(ParentId,Options) -> - create(editor,ParentId,Options). -editor(Name,ParentId,Options) -> - create(editor,Name,ParentId,Options). - -prompter(ParentId) -> - create(prompter,ParentId,[]). -prompter(ParentId,Options) -> - create(prompter,ParentId,Options). -prompter(Name,ParentId,Options) -> - create(prompter,Name,ParentId,Options). - -line(ParentId) -> - create(line,ParentId,[]). -line(ParentId,Options) -> - create(line,ParentId,Options). -line(Name,ParentId,Options) -> - create(line,Name,ParentId,Options). - -oval(ParentId) -> - create(oval,ParentId,[]). -oval(ParentId,Options) -> - create(oval,ParentId,Options). -oval(Name,ParentId,Options) -> - create(oval,Name,ParentId,Options). - -rectangle(ParentId) -> - create(rectangle,ParentId,[]). -rectangle(ParentId,Options) -> - create(rectangle,ParentId,Options). -rectangle(Name,ParentId,Options) -> - create(rectangle,Name,ParentId,Options). - -polygon(ParentId) -> - create(polygon,ParentId,[]). -polygon(ParentId,Options) -> - create(polygon,ParentId,Options). -polygon(Name,ParentId,Options) -> - create(polygon,Name,ParentId,Options). - -text(ParentId) -> - create(text,ParentId,[]). -text(ParentId,Options) -> - create(text,ParentId,Options). -text(Name,ParentId,Options) -> - create(text,Name,ParentId,Options). - -image(ParentId) -> - create(image,ParentId,[]). -image(ParentId,Options) -> - create(image,ParentId,Options). -image(Name,ParentId,Options) -> - create(image,Name,ParentId,Options). - -arc(ParentId) -> - create(arc,ParentId,[]). -arc(ParentId,Options) -> - create(arc,ParentId,Options). -arc(Name,ParentId,Options) -> - create(arc,Name,ParentId,Options). - -menu(ParentId) -> - create(menu,ParentId,[]). -menu(ParentId, Options) -> - create(menu,ParentId,Options). -menu(Name,ParentId,Options) -> - create(menu,Name,ParentId,Options). - -menubutton(ParentId) -> - create(menubutton,ParentId,[]). -menubutton(ParentId,Options) -> - create(menubutton,ParentId,Options). -menubutton(Name,ParentId,Options) -> - create(menubutton,Name,ParentId,Options). - -menubar(ParentId) -> - create(menubar,ParentId,[]). -menubar(ParentId,Options) -> - create(menubar,ParentId,Options). -menubar(Name,ParentId,Options) -> - create(menubar,Name,ParentId,Options). - -menuitem(ParentId) -> - create(menuitem,ParentId,[]). -menuitem(ParentId,Options) -> - create(menuitem,ParentId,Options). -menuitem(Name,ParentId,Options) -> - create(menuitem,Name,ParentId,Options). - -grid(ParentId) -> - create(grid,ParentId,[]). -grid(ParentId,Options) -> - create(grid,ParentId,Options). -grid(Name,ParentId,Options) -> - create(grid,Name,ParentId,Options). - -gridline(ParentId) -> - create(gridline,ParentId,[]). -gridline(ParentId,Options) -> - create(gridline,ParentId,Options). -gridline(Name,ParentId,Options) -> - create(gridline,Name,ParentId,Options). - -%%---------------------------------------------------------------------- -%% Waiting for erl44 -%%---------------------------------------------------------------------- -foreach(F, ExtraArgs, [H | T]) -> - apply(F, [H | ExtraArgs]), - foreach(F, ExtraArgs, T); -foreach(_F, _ExtraArgs, []) -> ok. - -%%---------------------------------------------------------------------- -%% ASSociation with eQual key (scheme standard) -%%---------------------------------------------------------------------- -assq(Key, List) -> - case lists:keysearch(Key, 1, List) of - {value, {_, Val}} -> {value, Val}; - _ -> false - end. - -%%---------------------------------------------------------------------- -%% When we need the whole pair. -%%---------------------------------------------------------------------- -pair(Key, List) -> - case lists:keysearch(Key, 1, List) of - {value, Pair} -> Pair; - _ -> false - end. - -%%---------------------------------------------------------------------- -%% When we know there is a value -%%---------------------------------------------------------------------- -val(Key, List) when is_list(List) -> - {value, {_,Val}} = lists:keysearch(Key, 1, List), - Val. - -val(Key,List,ElseVal) when is_list(List) -> - case lists:keysearch(Key, 1, List) of - {value, {_, Val}} -> Val; - _ -> ElseVal - end. - -%% ---------------------------------------- -%% done diff --git a/lib/gs/src/gs_frontend.erl b/lib/gs/src/gs_frontend.erl deleted file mode 100644 index f46fdb36bb..0000000000 --- a/lib/gs/src/gs_frontend.erl +++ /dev/null @@ -1,371 +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% -%% - -%% -%% ------------------------------------------------------------ -%% Erlang Graphics Interface front-end server -%% ------------------------------------------------------------ -%% - --module(gs_frontend). --compile([{nowarn_deprecated_function,{gs,assq,2}}, - {nowarn_deprecated_function,{gs,error,2}}]). - --export([create/2, - config/2, - read/2, - destroy/2, - info/1, - start/1, - stop/0, - init/1, - event/3]). - - --include("gstk.hrl"). - - -%%---------------------------------------------------------------------- -%% The ets contains: {Obj,lives}|{Obj,{Name,Pid}} -%% new obj is {Int,Node} -%% {{Name,Pid},Obj} -%%---------------------------------------------------------------------- --record(state, {db,user,user_count,kernel,kernel_count,self}). - -%%---------------------------------------------------------------------- -%% The interface. -%%---------------------------------------------------------------------- -create(GsPid,Args) -> - request(GsPid,{create,Args}). - -config(GsPid,Args) -> - request(GsPid,{config, Args}). - -read(GsPid,Args) -> - request(GsPid,{read, Args}). - -destroy(GsPid,IdOrName) -> - request(GsPid,{destroy, IdOrName}). - -info(Option) -> - request(gs_frontend,{info,Option}). - - -%%---------------------------------------------------------------------- -%% Comment: Frontend is only locally registered. These functions are called -%% by any backend. -%%---------------------------------------------------------------------- -event(FrontEnd,ToOwner,EventMsg) -> - FrontEnd ! {event, ToOwner,EventMsg}. - - -request(GsPid,Msg) -> - GsPid ! {self(),Msg}, - receive - {gs_reply,R} -> R - end. - -%%---------------------------------------------------------------------- -%% The server -%%---------------------------------------------------------------------- - -start(Opts) -> - case whereis(gs_frontend) of - undefined -> - P = spawn_link(gs_frontend,init,[Opts]), - case catch register(gs_frontend, P) of - true -> - request(gs_frontend,{instance, backend_name(Opts), Opts}); - {'EXIT', _} -> - exit(P,kill), % a raise... and I lost this time - start(Opts) - end; - P -> - request(P,{instance,backend_name(Opts),Opts}) - end. - -backend_name(Opts) -> - case gs:assq(kernel,Opts) of - {value,true} -> kernel; - _ -> user - end. - - -stop() -> - request(gs_frontend,stop). - -%% ------------------------------------------------------------ -%% THE FRONT END SERVER -%% ------------------------------------------------------------ -%% Initialize -%% -init(_Opts) -> - process_flag(trap_exit, true), - DB=ets:new(gs_names,[set,public]), - loop(#state{db=DB,self=self()}). - -loop(State) -> - receive - X -> - % io:format("frontend received: ~p~n",[X]), - case catch (doit(X,State)) of - done -> loop(State); - NewState when is_record(NewState,state) -> - loop(NewState); - stop -> stop; - Reason -> - io:format("GS frontend. Last mgs in was:~p~n",[X]), - io:format("exit:~p~n",[X]), - io:format("Reason: ~p~n", [Reason]), - terminate(Reason,State), - exit(Reason) - end - end. - -reply(To,Msg) -> - To ! {gs_reply,Msg}, - done. - -doit({FromOwner,{config, Args}},State) -> - {IdOrName, Opts} = Args, - #state{db=DB} = State, - case idOrName_to_id(DB,IdOrName,FromOwner) of - undefined -> - reply(FromOwner,{error,{no_such_object,IdOrName}}); - Obj -> - reply(FromOwner,gstk:config(backend(State,Obj),{Obj,Opts})) - end; - -doit({event,ToOwner,{gs,Obj,Etype,Data,Args}}, #state{db=DB,self=Self}) -> - case ets:lookup(DB,Obj) of - [{_,{Name,ToOwner}}] -> ToOwner ! {gs,Name,Etype,Data,Args}; - _ -> ToOwner ! {gs,{Obj,Self},Etype,Data,Args} - end, - done; - -doit({FromOwner,{create,Args}}, State) -> - {Objtype, Name, Parent, Opts} = Args, - #state{db=DB} = State, - NameOccupied = case {Name, ets:lookup(DB,{Name,FromOwner})} of - {undefined,_} -> false; - {_, []} -> false; - _ -> true - end, - if NameOccupied == true -> - reply(FromOwner, {error,{name_occupied,Name}}); - true -> - case idOrName_to_id(DB,Parent,FromOwner) of - undefined -> - reply(FromOwner, {error,{no_such_parent,Parent}}); - ParentObj -> - {Id,NewState} = inc(ParentObj,State), - case gstk:create(backend(State,ParentObj), - {FromOwner,{Objtype,Id,ParentObj,Opts}}) of - ok -> - link(FromOwner), - if Name == undefined -> - ets:insert(DB,{Id,lives}), - reply(FromOwner, Id), - NewState; - true -> % it's a real name, register it - NamePid = {Name,FromOwner}, - ets:insert(DB,{NamePid,Id}), - ets:insert(DB,{Id,NamePid}), - reply(FromOwner,Id), - NewState - end; - Err -> reply(FromOwner,Err) - end - end - end; - -doit({FromOwner,{read, Args}}, State) -> - #state{db=DB} = State, - {IdOrName, Opt} = Args, - case idOrName_to_id(DB,IdOrName,FromOwner) of - undefined -> - reply(FromOwner,{error,{no_such_object,IdOrName}}); - Obj -> - reply(FromOwner,gstk:read(backend(State,Obj),{Obj,Opt})) - end; - -doit({'EXIT', UserBackend, Reason}, State) - when State#state.user == UserBackend -> - gs:error("user backend died reason ~w~n", [Reason]), - remove_user_objects(State#state.db), - State#state{user=undefined}; - -doit({'EXIT', KernelBackend, Reason}, State) - when State#state.kernel == KernelBackend -> - gs:error("kernel backend died reason ~w~n", [Reason]), - exit({gs_kernel_died,Reason}); - -doit({'EXIT', Pid, _Reason}, #state{kernel=K,user=U,db=DB}) -> - %% io:format("Pid ~w died reason ~w~n", [Pid, _Reason]), - if is_pid(U) -> - DeadObjU = gstk:pid_died(U,Pid), - remove_objs(DB,DeadObjU); - true -> ok - end, - if is_pid(K) -> - DeadObjK = gstk:pid_died(K,Pid), - remove_objs(DB,DeadObjK); - true -> true end, - done; - -doit({FromOwner,{destroy, IdOrName}}, State) -> - #state{db=DB} = State, - case idOrName_to_id(DB,IdOrName,FromOwner) of - undefined -> - reply(FromOwner, {error,{no_such_object,IdOrName}}); - Obj -> - DeadObj = gstk:destroy(backend(State,Obj),Obj), - remove_objs(DB,DeadObj), - reply(FromOwner,done) - end; - -doit({From,{instance,user,Opts}},State) -> - #state{db=DB, self=Self, user_count=UC} = State, - case ets:lookup(DB,1) of - [_] -> reply(From, {1,Self}); - [] -> - ets:insert(DB,{1,lives}), % parent of all user gs objs - case gstk:start_link(1, Self, Self, Opts) of - {ok, UserBackend} -> - reply(From, {1, Self}), - case UC of - undefined -> - State#state{user_count=1, user=UserBackend}; - _N -> - State#state{user_count=UC+2, user=UserBackend} - end; - {error, Reason} -> - reply(From, {error, Reason}), - stop - end - end; - -doit({From,{instance,kernel,Opts}},State) -> - #state{db=DB,self=Self} = State, - case ets:lookup(DB,0) of - [_] -> reply(From, {0,Self}); - [] -> - ets:insert(DB,{0,lives}), % parent of all user gs objs - case gstk:start_link(0,Self,Self,Opts) of - {ok, KernelBackend} -> - reply(From, {0,Self}), - State#state{kernel_count=0,kernel=KernelBackend}; - {error, Reason} -> - reply(From, {error,Reason}), - stop - end - end; - - -doit({From,stop}, State) -> - #state{kernel=K,user=U} = State, - if is_pid(U) -> gstk:stop(U); - true -> true end, - if is_pid(K) -> gstk:stop(K); - true -> true end, - reply(From,stopped), - stop; - -doit({From,{gstk,user,Msg}},State) -> - reply(From,gstk:request(State#state.user,Msg)); -doit({From,{gstk,kernel,Msg}},State) -> - reply(From,gstk:request(State#state.kernel,Msg)); - -doit({From,{info,gs_db}},State) -> - io:format("gs_db:~p~n",[ets:tab2list(State#state.db)]), - reply(From,State); -doit({From,{info,kernel_db}},State) -> - reply(From,gstk:request(State#state.kernel,dump_db)); -doit({From,{info,user_db}},State) -> - reply(From,gstk:request(State#state.user,dump_db)); -doit({From,{info,Unknown}},_State) -> - io:format("gs: unknown info option '~w', use one of 'gs_db', 'kernel_db' or 'user_db'~n",[Unknown]), - reply(From,ok). - -terminate(_Reason,#state{db=DB}) -> - if DB==undefined -> ok; - true -> - % io:format("frontend db:~p~n",[ets:tab2list(DB)]) - ok - end. - - -backend(#state{user=Upid,kernel=Kpid},Obj) -> - if Obj rem 2 == 0 -> Kpid; - true -> Upid - end. - -%%---------------------------------------------------------------------- -%% Returns: {NewId,NewState} -%%---------------------------------------------------------------------- -inc(ParInt,State) when ParInt rem 2 == 1 -> - X=State#state.user_count+2, - {X,State#state{user_count=X}}; -inc(ParInt,State) when ParInt rem 2 == 0 -> - X=State#state.kernel_count+2, - {X,State#state{kernel_count=X}}. - -remove_user_objects(DB) -> - DeadObj = find_user_obj(ets:first(DB),DB), - remove_objs(DB,DeadObj). - -find_user_obj(Int,DB) when is_integer(Int) -> - if Int rem 2 == 0 -> %% a kernel obj - find_user_obj(ets:next(DB,Int),DB); - true -> %% a user obj - [Int|find_user_obj(ets:next(DB,Int),DB)] - end; -find_user_obj('$end_of_table',_DB) -> - []; -find_user_obj(OtherKey,DB) -> - find_user_obj(ets:next(DB,OtherKey),DB). - -remove_objs(DB,[Obj|Objs]) -> - case ets:lookup(DB, Obj) of - [{_,NamePid}] -> - ets:delete(DB,Obj), - ets:delete(DB,NamePid); - [] -> backend_only - end, - remove_objs(DB,Objs); -remove_objs(_DB,[]) -> done. - -idOrName_to_id(DB,IdOrName,Pid) when is_atom(IdOrName) -> - case ets:lookup(DB,{IdOrName,Pid}) of - [{_,Obj}] -> Obj; - _ -> undefined - end; -idOrName_to_id(DB,Obj,_Pid) -> - case ets:lookup(DB,Obj) of - [_] -> Obj; - _ -> undefined - end. - - - - -%% ---------------------------------------- -%% done - diff --git a/lib/gs/src/gs_make.erl b/lib/gs/src/gs_make.erl deleted file mode 100644 index 061b1944d1..0000000000 --- a/lib/gs/src/gs_make.erl +++ /dev/null @@ -1,266 +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(gs_make). --compile([{nowarn_deprecated_function,{gs,assq,2}}]). - --export([start/0]). - -start() -> - Terms = the_config(), - DB=fill_ets(Terms), - {ok,OutFd} = file:open("gstk_generic.hrl", [write]), - put(stdout,OutFd), -% io:format("terms: ~p ~n ets:~p~n",[Terms,ets:tab2list(DB)]), - p("% Don't edit this file. It was generated by gs_make:start/0 "), - p("at ~p-~p-~p, ~p:~p:~p.\n\n", - lists:append(tuple_to_list(date()),tuple_to_list(time()))), - gen_out_opts(DB), - gen_read(DB), - file:close(OutFd), - {ok,"gstk_generic.hrl",DB}. - -fill_ets(Terms) -> - DB = ets:new(gs_mapping,[bag,public]), - fill_ets(DB,Terms). - -fill_ets(DB,[]) -> DB; -fill_ets(DB,[{Objs,Opt,Fun,Access}|Terms]) -> - fill_ets(DB,lists:flatten(Objs),Opt,Fun,Access), - fill_ets(DB,Terms). - -fill_ets(_DB,[],_,_,_) -> done; -fill_ets(DB,[Obj|Objs],Opt,Fun,rw) -> - ets:insert(DB,{Obj,Opt,Fun,read}), - ets:insert(DB,{Obj,Opt,Fun,write}), - fill_ets(DB,Objs,Opt,Fun,rw); -fill_ets(DB,[Obj|Objs],Opt,Fun,r) -> - ets:insert(DB,{Obj,Opt,Fun,read}), - fill_ets(DB,Objs,Opt,Fun,r); -fill_ets(DB,[Obj|Objs],Opt,Fun,w) -> - ets:insert(DB,{Obj,Opt,Fun,write}), - fill_ets(DB,Objs,Opt,Fun,w). - - - -gen_out_opts(DB) -> - ObjTypes = lists:flatten(ordsets:from_list(ets:match(DB,{'$1','_','_',write}))), - p("out_opts([Option|Options],Gstkid,TkW,DB,ExtraArg,S,P,C) ->\n"), - p(" {Opt,Val} =\n"), - p(" case Option of \n"), - p(" {{default,Cat,Key},V} -> {default,{Cat,{Key,V}}};\n"), - p(" {_Key,_V} -> Option;\n"), - p(" {default,Cat,Opti} -> {default,{Cat,Opti}};\n"), - p(" Atom when is_atom(Atom) -> {Atom,undefined};\n"), - p(" _ -> {error, {invalid_option,Option}}\n"), - p(" end,\n"), - p(" case Gstkid#gstkid.objtype of\n"), - gen_out_type_case_clauses(merge_types(ObjTypes),DB), - p(" Q -> exit({internal_error,unknown_objtype,Q})\n"), - p(" end;\n"), - p("out_opts([],_Gstkid,_TkW,_DB,_ExtraArg,S,P,C) -> \n"), - p(" {S,P,C}.\n"). - - -gen_out_type_case_clauses([],_DB) -> done; -gen_out_type_case_clauses([Objtype|Objtypes],DB) -> - OptsFuns = lists:map(fun(L) -> list_to_tuple(L) end, - ets:match(DB,{Objtype,'$1','$2',write})), - p(" ~p -> \ncase Opt of\n",[Objtype]), - gen_opt_case_clauses(merge_opts(opt_prio(),OptsFuns)), - p(" _ -> \n"), - p(" handle_external_opt_call([Option|Options],Gstkid,TkW,DB,ExtraArg," - " gstk_~p:option(Option,Gstkid,TkW,DB,ExtraArg),S,P,C)\n", - [Objtype]), - p(" end;\n"), - gen_out_type_case_clauses(Objtypes,DB). - -gen_opt_case_clauses([]) -> - done; -gen_opt_case_clauses([{Opt,Fun}|OptFuncs]) -> - p(" ~p ->\n",[Opt]), - p(" ~p(Val,Options,Gstkid,TkW,DB,ExtraArg,S,P,C);\n",[Fun]), - gen_opt_case_clauses(OptFuncs). - -gen_read(DB) -> - ObjTypes = lists:flatten(ordsets:from_list(ets:match(DB,{'$1','_','_',read}))), - p("read_option(DB,Gstkid,TkW,Option,ExtraArg) ->\n"), - p(" Key = case Option of\n"), - p(" Atom when is_atom(Atom) -> Atom;\n"), - p(" Opt when is_tuple(Opt) -> element(1,Opt)\n"), - p(" end,\n"), - p(" case Gstkid#gstkid.objtype of\n"), - gen_read_type_clauses(merge_types(ObjTypes),DB), - p(" Q -> exit({internal_error,unknown_objtype,Q})\n"), - p(" end.\n"). - - -gen_read_type_clauses([],_) -> done; -gen_read_type_clauses([Objtype|Objtypes],DB) -> - OptsFuns = lists:map(fun(L) -> list_to_tuple(L) end, - ets:match(DB,{Objtype,'$1','$2',read})), - p(" ~p -> \ncase Key of\n",[Objtype]), - gen_readopt_case_clauses(merge_opts(opt_prio(),OptsFuns)), - p(" _ -> \nhandle_external_read(gstk_~p:read_option(Option,Gstkid,TkW,DB,ExtraArg))\n",[Objtype]), - p(" end;\n"), - gen_read_type_clauses(Objtypes,DB). - -gen_readopt_case_clauses([]) -> - done; -gen_readopt_case_clauses([{Opt,Fun}|OptFuncs]) -> - p(" ~p -> \n~p(Option,Gstkid,TkW,DB,ExtraArg);\n",[Opt,Fun]), - gen_readopt_case_clauses(OptFuncs). - - -p(Str) -> - ok = io:format(get(stdout),Str,[]). - -p(Format,Data) -> - ok = io:format(get(stdout),Format,Data). - -%%---------------------------------------------------------------------- -%% There items should be placed early in a case statement. -%%---------------------------------------------------------------------- -obj_prio() -> [rectangle,line,gridline,image,button,canvas,checkbutton,radiobutton]. -opt_prio() -> [x,y,width,height,move,coords,data]. - -merge_types(Types) -> - T2 = ordsets:from_list(Types), - P2 = ordsets:from_list(obj_prio()), - obj_prio() ++ ordsets:subtract(T2, P2). - -merge_opts([],L) -> L; -merge_opts([Opt|Opts],Dict) -> - case gs:assq(Opt,Dict) of - {value,V} -> [{Opt,V}|merge_opts(Opts,lists:keydelete(Opt,1,Dict))]; - false -> merge_opts(Opts,Dict) - end. - -the_config() -> - Buttons=[button,checkbutton,radiobutton], - AllPureTk = [Buttons,canvas,editor,entry,frame,label,listbox, - menubar,menubutton,scale,window], - CanvasObj = [arc,image,line,oval,polygon,rectangle,text], - All = [AllPureTk,CanvasObj,grid,gridline,menu,menuitem,gs], - Containers = [canvas,frame,grid,menu,menubar,menubutton,menuitem,window], - Ob1 = [Buttons,canvas,grid,frame,label,entry,editor,listbox,scale], - Ob2 = [button,checkbutton,radiobutton,label,menubutton], - Ob3 = [Buttons,frame,label,entry,editor,listbox,scale,menubutton, - menubar,menu], - Ob4 = [canvas,editor,listbox], - [{[Buttons,entry,scale,menubutton],enable,gen_enable,rw}, - {[Buttons,label,entry,scale,menubutton,menu],fg,gen_fg,rw}, - {[Buttons,label,entry,scale,menubutton,menu],bg,gen_bg,rw}, - {Ob1,anchor,gen_anchor,rw}, - {Ob1,height,gen_height,r}, - {Ob1--[frame],height,gen_height,w}, - {Ob1,width,gen_width,r}, - {Ob1--[frame],width,gen_width,w}, - {Ob1,pack_x,gen_pack_x,rw}, - {Ob1,pack_y,gen_pack_y,rw}, - {Ob1,pack_xy,gen_pack_xy,w}, - {Ob1,x,gen_x,rw}, - {Ob1,y,gen_y,rw}, - {Ob1,raise,gen_raise,w}, - {Ob1,lower,gen_lower,w}, - {Ob2,align,gen_align,rw}, - {Ob2,font,gen_font,rw}, - {Ob2,justify,gen_justify,rw}, - {Ob2,padx,gen_padx,rw}, - {Ob2,pady,gen_pady,rw}, - {Containers,default,gen_default,w}, - {[AllPureTk,menu],relief,gen_relief,rw}, - {[AllPureTk,menu],bw,gen_bw,rw}, - {[Buttons,canvas,frame,label,entry,scale,menubutton,menu,menubar], - setfocus,gen_setfocus,rw}, - {Ob3,buttonpress,gen_buttonpress,rw}, - {Ob3,buttonrelease,gen_buttonrelease,rw}, - {Ob3,configure,gen_configure,rw}, - {[Ob3,window],destroy,gen_destroy,rw}, - {[Ob3,window],enter,gen_enter,rw}, - {[Ob3,window],leave,gen_leave,rw}, - {[Ob3,window],focus,gen_focus_ev,rw}, - {[Ob3,window],keypress,gen_keypress,rw}, - {[Ob3,window],keyrelease,gen_keyrelease,rw}, - {Ob3,motion,gen_motion,rw}, - %% events containing x,y are special - {[window],buttonpress,gen_buttonpress,r}, - {[window],buttonrelease,gen_buttonrelease,r}, - {[window],motion,gen_motion,r}, - {All,font_wh,gen_font_wh,r}, - {All,choose_font,gen_choose_font,r}, - {All,data,gen_data,rw}, - {All,children,gen_children,r}, - {All,id,gen_id,r}, - {All,parent,gen_parent,r}, - {All,type,gen_type,r}, - {All,beep,gen_beep,w}, - {All,keep_opt,gen_keep_opt,w}, - {All,flush,gen_flush,rw}, - {AllPureTk,highlightbw,gen_highlightbw,rw}, - {AllPureTk,highlightbg,gen_highlightbg,rw}, - {AllPureTk,highlightfg,gen_highlightfg,rw}, - {AllPureTk,cursor,gen_cursor,rw}, % bug - {[Buttons,label,menubutton],label,gen_label,rw}, - {[Buttons,menubutton,menu],activebg,gen_activebg,rw}, - {[Buttons,menubutton,menu],activefg,gen_activefg,rw}, - {[entry],selectbg,gen_selectbg,rw}, - {[entry],selectbw,gen_selectbw,rw}, - {[entry],selectfg,gen_selectfg,rw}, - {Ob4,activebg,gen_so_activebg,rw}, - {Ob4,bc,gen_so_bc,rw}, - {Ob4,bg,gen_so_bg,rw}, - {Ob4,hscroll,gen_so_hscroll,r}, - {Ob4,scrollbg,gen_so_scrollbg,rw}, - {Ob4,scrollfg,gen_so_scrollfg,rw}, - {Ob4,scrolls,gen_so_scrolls,w}, - {Ob4,selectbg,gen_so_selectbg,rw}, - {Ob4,selectbg,gen_so_selectbg,rw}, - {Ob4,selectbw,gen_so_selectbw,rw}, - {Ob4,selectbw,gen_so_selectbw,rw}, - {Ob4,selectfg,gen_so_selectfg,rw}, - {Ob4,selectfg,gen_so_selectfg,rw}, - {Ob4,vscroll,gen_so_vscroll,r}, - {CanvasObj,coords,gen_citem_coords,rw}, - {CanvasObj,lower,gen_citem_lower,w}, - {CanvasObj,raise,gen_citem_raise,w}, - {CanvasObj,move,gen_citem_move,w}, - {CanvasObj,setfocus,gen_citem_setfocus,rw}, - {CanvasObj,buttonpress,gen_citem_buttonpress,w}, % should be rw - {CanvasObj,buttonrelease,gen_citem_buttonrelease,w}, - {CanvasObj,enter,gen_citem_enter,w}, - {CanvasObj,focus,gen_citem_setfocus,w}, - {CanvasObj,keypress,gen_citem_keypress,w}, - {CanvasObj,keyrelease,gen_citem_keyrelease,w}, - {CanvasObj,leave,gen_citem_leave,w}, - {CanvasObj,motion,gen_citem_motion,w}, - {CanvasObj,buttonpress,gen_buttonpress,r}, - {CanvasObj,buttonrelease,gen_buttonrelease,r}, - {CanvasObj,configure,gen_configure,r}, - {CanvasObj,destroy,gen_destroy,r}, - {CanvasObj,enter,gen_enter,r}, - {CanvasObj,leave,gen_leave,r}, - {CanvasObj,focus,gen_focus_ev,r}, - {CanvasObj,keypress,gen_keypress,r}, - {CanvasObj,keyrelease,gen_keyrelease,r}, - {CanvasObj,motion,gen_motion,r}, - {[arc,oval,polygon,rectangle],fill,gen_citem_fill,rw}]. - diff --git a/lib/gs/src/gs_packer.erl b/lib/gs/src/gs_packer.erl deleted file mode 100644 index d16849e4e9..0000000000 --- a/lib/gs/src/gs_packer.erl +++ /dev/null @@ -1,276 +0,0 @@ -%% -%% %CopyrightBegin% -%% -%% Copyright Ericsson AB 1997-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% -%% - -%% -%% ------------------------------------------------------------ -%% Erlang Graphics Interface geometry manager caclulator -%% ------------------------------------------------------------ - - --module(gs_packer). - --export([pack/2]). -%-compile(export_all). - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%%%% -%%%% This is a simple packer that take a specification in the format -%%%% -%%%% Spec -> [WidthSpec, WidthSpec....] -%%%% WidthSpec -> {fixed,Size} | {stretch,Weight} | -%%%% {stretch,Weight,Min} | {stretch,Weight,Min,Max} -%%%% -%%%% and a given total size it produces a list of sizes of the -%%%% individual elements. Simple heuristics are used to make the code -%%%% fast and simple. -%%%% -%%%% The Weight is simply a number that is the relative size to the -%%%% other elements that has weights. If for example the weights -%%%% for a frame that has three columns are 40 20 100 it means that -%%%% column 1 has 40/160'th of the space, column 2 20/160'th of -%%%% the space and column 3 100/160'th of the space. -%%%% -%%%% The program try to solve the equation with the constraints given. -%%%% We have tree cases -%%%% -%%%% o We can fullfil the request in the space given -%%%% o We have less space than needed -%%%% o We have more space than allowed -%%%% -%%%% The algorithm is as follows: -%%%% -%%%% 1. Subtract the fixed size, nothing to do about that. -%%%% -%%%% 2. Calculate the Unit (or whatever it should be called), the -%%%% given space minus the fixed sise divided by the Weights. -%%%% -%%%% 3. If we in total can fullfill the request we try to -%%%% fullfill the individual constraints. See remove_failure/2. -%%%% -%%%% 4. If we have too little or too much pixels we take our -%%%% specification and create a new more relaxed one. See -%%%% cnvt_to_min/1 and cnvt_to_max/1. -%%%% -%%%% In general we adjust the specification and redo the whole process -%%%% until we have a specification that meet the total constraints -%%%% and individual constraints. When we know that the constraints -%%%% are satisfied we finally call distribute_space/2 to set the -%%%% resulting size values for the individual elements. -%%%% -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - - -pack(Size, SpecSizes) when Size < 0 -> - pack(0, SpecSizes); -pack(Size, SpecSizes) -> - {Weights,_Stretched,Fixed,Min,Max} = get_size_info(SpecSizes), - Left = Size - Fixed, - Unit = if Weights == 0 -> 0; true -> Left / Weights end, - if - Left < Min -> - NewSpecs = cnvt_to_min(SpecSizes), - pack(Size,NewSpecs); - is_integer(Max), Max =/= 0, Left > Max -> - NewSpecs = cnvt_to_max(SpecSizes), - pack(Size,NewSpecs); - true -> - case remove_failure(SpecSizes, Unit) of - {no,NewSpecs} -> - distribute_space(NewSpecs,Unit); - {yes,NewSpecs} -> - pack(Size, NewSpecs) - end - end. - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%%%% -%%%% remove_failure(Specs, Unit) -%%%% -%%%% We know that we in total have enough space to fit within the total -%%%% maximum and minimum requirements. But we have to take care of -%%%% individual minimum and maximum requirements. -%%%% -%%%% This is done with a simple heuristic. We pick the element that -%%%% has the largest diff from the required min or max, change this -%%%% {stretch,W,Mi,Ma} to a {fixed,Mi} or {fixed,Ma} and redo the -%%%% whole process again. -%%%% -%%%% **** BUGS **** -%%%% No known. But try to understand this function and you get a medal ;-) -%%%% -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - - -remove_failure(Specs, Unit) -> - case remove_failure(Specs, Unit, 0) of - {done,NewSpecs} -> - {yes,NewSpecs}; - {_,_NewSpecs} -> - {no,Specs} % NewSpecs == Specs but - end. % we choose the old one - -remove_failure([], _Unit, MaxFailure) -> - {MaxFailure,[]}; -remove_failure([{stretch,W,Mi} | Specs], Unit, MaxFailure) -> - {MinMax,NewMaxFailure} = max_failure(MaxFailure, Mi-W*Unit, 0), - case {MinMax,remove_failure(Specs, Unit, NewMaxFailure)} of - {min,{NewMaxFailure,Rest}} -> - {done,[{fixed,Mi} | Rest]}; - {_,{OtherMaxFailure, Rest}} -> - {OtherMaxFailure,[{stretch,W,Mi} | Rest]} - end; -remove_failure([{stretch,W,Mi,Ma} | Specs], Unit, MaxFailure) -> - {MinMax,NewMaxFailure} = max_failure(MaxFailure, Mi-W*Unit, W*Unit-Ma), - case {MinMax,remove_failure(Specs, Unit, NewMaxFailure)} of - {min,{NewMaxFailure,Rest}} -> - {done,[{fixed,Mi} | Rest]}; - {max,{NewMaxFailure,Rest}} -> - {done,[{fixed,Ma} | Rest]}; - {_,{OtherMaxFailure, Rest}} -> - {OtherMaxFailure,[{stretch,W,Mi,Ma} | Rest]} - end; -remove_failure([Spec | Specs], Unit, MaxFailure) -> - {NewMaxFailure,NewSpecs} = remove_failure(Specs, Unit, MaxFailure), - {NewMaxFailure, [Spec | NewSpecs]}. - -max_failure(LastDiff, DMi, DMa) - when DMi > LastDiff, DMi > DMa -> - {min,DMi}; -max_failure(LastDiff, _DMi, DMa) - when DMa > LastDiff -> - {max,DMa}; -max_failure(MaxFailure, _DMi, _DMa) -> - {other,MaxFailure}. - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%%%% -%%%% distribute_space(Spec,Unit) -%%%% -%%%% We now know that we can distribute the space to the elements in -%%%% the list. -%%%% -%%%% **** BUGS **** -%%%% No known bugs. It try hard to distribute the pixels so that -%%%% there should eb no pixels left when done but there is no proof -%%%% that this is the case. The distribution of pixels may also -%%%% not be optimal. The rounding error from giving one element some -%%%% pixels is added to the next even if it would be better to add -%%%% it to an element later in the list (for example the weights -%%%% 1000, 2, 1000). But this should be good enough. -%%%% -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - - -distribute_space(Specs, Unit) -> - distribute_space(Specs, Unit, 0.0). - -distribute_space([], _Unit, _Err) -> - []; -distribute_space([Spec | Specs], Unit, Err) -> - distribute_space(Spec, Specs, Unit, Err). - -distribute_space({fixed,P}, Specs, Unit, Err) -> - [P | distribute_space(Specs, Unit, Err)]; -distribute_space({stretch,Weight}, Specs, Unit, Err) -> - Size = Weight * Unit + Err, - Pixels = round(Size), - NewErr = Size - Pixels, - [Pixels | distribute_space(Specs, Unit, NewErr)]; -distribute_space({stretch,W,_Mi}, Specs, Unit, Err) -> - distribute_space({stretch,W}, Specs, Unit, Err); -distribute_space({stretch,W,_Mi,_Ma}, Specs, Unit, Err) -> - distribute_space({stretch,W}, Specs, Unit, Err). - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%%%% -%%%% cnvt_to_min(Spec) -%%%% cnvt_to_max(Spec) -%%%% -%%%% If the space we got isn't enough for the total minimal or maximal -%%%% requirements then we convert the specification to a more relaxed -%%%% one that we always can satisfy. -%%%% -%%%% This is fun! We do a simple transformation from one specification -%%%% to a new one. The min, max and fixed size are our new weights! -%%%% This way the step from a specification we can satisfy and one -%%%% close that we can't is only a few pixels away, i.e. the transition -%%%% from within the constraints and outside will be smooth. -%%%% -%%%% **** BUGS **** -%%%% No known bugs. -%%%% -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - - -cnvt_to_min([]) -> - []; -cnvt_to_min([Spec | Specs]) -> - cnvt_to_min(Spec, Specs). - -cnvt_to_max([]) -> - []; -cnvt_to_max([Spec | Specs]) -> - cnvt_to_max(Spec, Specs). - -cnvt_to_min({fixed,P}, Specs) -> - [{stretch,P} | cnvt_to_min(Specs)]; -cnvt_to_min({stretch,_W}, Specs) -> - [{fixed,0} | cnvt_to_min(Specs)]; -cnvt_to_min({stretch,_W,Mi}, Specs) -> - [{stretch,Mi} | cnvt_to_min(Specs)]; -cnvt_to_min({stretch,_W,Mi,_Ma}, Specs) -> - [{stretch,Mi} | cnvt_to_min(Specs)]. - -%% We know that there can only be {fixed,P} and {stretch,W,Mi,Ma} -%% in this list. - -cnvt_to_max({fixed,P}, Specs) -> - [{stretch,P} | cnvt_to_max(Specs)]; -cnvt_to_max({stretch,_W,_Mi,Ma}, Specs) -> - [{stretch,Ma} | cnvt_to_max(Specs)]. - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%%%% -%%%% Sum the Weights, Min and Max etc -%%%% -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -get_size_info(Specs) -> - get_size_info(Specs, 0, 0, 0, 0, 0). - -get_size_info([], TotW, NumW, TotFixed, TotMin, TotMax) -> - {TotW, NumW, TotFixed, TotMin, TotMax}; -get_size_info([Spec | Specs], TotW, NumW, TotFixed, TotMin, TotMax) -> - get_size_info(Spec, TotW, NumW, TotFixed, TotMin, TotMax, Specs). - -get_size_info({fixed,P}, TotW, NumW, TotFixed, TotMin, TotMax, Specs) -> - get_size_info(Specs, TotW, NumW, TotFixed+P, TotMin, TotMax); -get_size_info({stretch,W}, TotW, NumW, TotFixed, TotMin, _TotMax, Specs) -> - get_size_info(Specs, TotW+W, NumW+1, TotFixed, TotMin, infinity); -get_size_info({stretch,W,Mi}, TotW, NumW, TotFixed, TotMin, _TotMax, Specs) -> - get_size_info(Specs, TotW+W, NumW+1, TotFixed, TotMin+Mi, infinity); -get_size_info({stretch,W,Mi,_Ma}, TotW, NumW, TotFixed, TotMin, infinity, Specs) -> - get_size_info(Specs, TotW+W, NumW+1, TotFixed, TotMin+Mi, infinity); -get_size_info({stretch,W,Mi,Ma}, TotW, NumW, TotFixed, TotMin, TotMax, Specs) -> - get_size_info(Specs, TotW+W, NumW+1, TotFixed, TotMin+Mi, TotMax+Ma). diff --git a/lib/gs/src/gs_widgets.erl b/lib/gs/src/gs_widgets.erl deleted file mode 100644 index f0351049f9..0000000000 --- a/lib/gs/src/gs_widgets.erl +++ /dev/null @@ -1,99 +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% -%% - -%% -%% ------------------------------------------------------------ -%% Widget specific data -%% ------------------------------------------------------------ -%% - --module(gs_widgets). - - -%% ----- Exports ----- --export([default_options/1, - container/1]). - - -%% ------------------------------------------------------------ -%% default_options for widgets -%% Keep the options in the list sorted! -%% ------------------------------------------------------------ - -default_options(arc) -> [{coords, [{0,0}, {0,0}]}]; -default_options(button) -> [{click,true}, {height,30}, {width,100}, {x,0}, - {y,0}]; -default_options(canvas) -> [{height,200}, {scrollregion,{0,0,300,200}}, - {width,300}, {x,0}, {y,0}]; -default_options(checkbutton) -> [{click,true}, {height,30}, {width,100}, {x,0}, - {y,0}]; -default_options(editor) -> [{height,200}, {width,300}, {x,0}, {y,0}]; -default_options(entry) -> [{height,30}, {width,100}, {x,0}, {y,0}]; -default_options(frame) -> [{height,100}, {width,150}, {x,0}, {y,0}]; -default_options(grid) -> [{bg,grey}, {cellheight,20}, - {columnwidths, [80,80,80,80]}, - {fg,black}, {font,{screen, 12}}, - {height,100}, - {hscroll,bottom}, - {rows,{1,10}}, - {vscroll,right}, - {width,300}, - {x,0}, {y,0}]; - % Keep the options in the list sorted! -default_options(gridline) -> [{click,true}, {doubleclick,false}, {row,undefined}]; -default_options(gs) -> [{kernel,false}, - {{default,all,font}, {screen,12}}]; -default_options(image) -> [{anchor,nw}, {coords,[{0,0}]}]; -default_options(label) -> [{height,30}, {width,100}, {x,0}, {y,0}]; -default_options(line) -> [{coords, [{-1,-1},{-1,-1}]}]; -default_options(listbox) -> [{height,130}, {hscroll,true}, - {selectmode,single}, {vscroll,true}, - {width,125}, {x,0}, {y,0}]; -default_options(menu) -> []; - % Keep the options in the list sorted! -default_options(menubar) -> [{bw,2}, {height,25}, {highlightbw,0}, - {relief,raised}]; -default_options(menubutton) -> [{anchor,nw}, {side,left}]; -default_options(menuitem) -> [{click,true}, {index,last}, {itemtype,normal}]; -default_options(message) -> [{height,75}, {width,100}]; -default_options(oval) -> [{coords, [{0,0},{0,0}]}]; -default_options(polygon) -> [{coords, [{0,0},{0,0}]}, {fg,black}, {fill,none}]; -default_options(prompter) -> [{height,200}, {prompt,[]}, {width,300}]; -default_options(radiobutton) -> [{click,true}, {height,30}, {width,100}, - {x,0}, {y,0}]; -default_options(rectangle) -> [{coords, [{0,0},{0,0}]}]; -default_options(scale) -> [{click,true}, {height,50}, {width,100}, - {x,0}, {y,0}]; - % Keep the options in the list sorted! -default_options(scrollbar) -> []; -default_options(text) -> [{anchor,nw}, {coords,[{0,0}]}, {justify,left}]; -default_options(window) -> [{configure,false}, {cursor,arrow}, {destroy,true}, - {height,200}, {map,false}, {width,300}]; -default_options(_) -> []. - -container(canvas) -> true; -container(frame) -> true; -container(grid) -> true; -container(menu) -> true; -container(menubar) -> true; -container(menubutton) -> true; -container(menuitem) -> true; -container(window) -> true; -container(_) -> false. diff --git a/lib/gs/src/gse.erl b/lib/gs/src/gse.erl deleted file mode 100644 index 10fb341894..0000000000 --- a/lib/gs/src/gse.erl +++ /dev/null @@ -1,788 +0,0 @@ -%% -%% %CopyrightBegin% -%% -%% Copyright Ericsson AB 1997-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% -%% - -%% -%%%---------------------------------------------------------------------- -%%% Purpose : Wrapper library for GS to provide proper error handling -%%%---------------------------------------------------------------------- - --module(gse). --compile([{nowarn_deprecated_function,{gs,arc,2}}, - {nowarn_deprecated_function,{gs,arc,3}}, - {nowarn_deprecated_function,{gs,button,2}}, - {nowarn_deprecated_function,{gs,button,3}}, - {nowarn_deprecated_function,{gs,canvas,2}}, - {nowarn_deprecated_function,{gs,canvas,3}}, - {nowarn_deprecated_function,{gs,checkbutton,2}}, - {nowarn_deprecated_function,{gs,checkbutton,3}}, - {nowarn_deprecated_function,{gs,config,2}}, - {nowarn_deprecated_function,{gs,create,3}}, - {nowarn_deprecated_function,{gs,create,4}}, - {nowarn_deprecated_function,{gs,create_tree,2}}, - {nowarn_deprecated_function,{gs,destroy,1}}, - {nowarn_deprecated_function,{gs,editor,2}}, - {nowarn_deprecated_function,{gs,editor,3}}, - {nowarn_deprecated_function,{gs,entry,2}}, - {nowarn_deprecated_function,{gs,entry,3}}, - {nowarn_deprecated_function,{gs,frame,2}}, - {nowarn_deprecated_function,{gs,frame,3}}, - {nowarn_deprecated_function,{gs,grid,2}}, - {nowarn_deprecated_function,{gs,grid,3}}, - {nowarn_deprecated_function,{gs,gridline,2}}, - {nowarn_deprecated_function,{gs,gridline,3}}, - {nowarn_deprecated_function,{gs,image,2}}, - {nowarn_deprecated_function,{gs,image,3}}, - {nowarn_deprecated_function,{gs,label,2}}, - {nowarn_deprecated_function,{gs,label,3}}, - {nowarn_deprecated_function,{gs,line,2}}, - {nowarn_deprecated_function,{gs,line,3}}, - {nowarn_deprecated_function,{gs,listbox,2}}, - {nowarn_deprecated_function,{gs,listbox,3}}, - {nowarn_deprecated_function,{gs,menu,2}}, - {nowarn_deprecated_function,{gs,menu,3}}, - {nowarn_deprecated_function,{gs,menubar,2}}, - {nowarn_deprecated_function,{gs,menubar,3}}, - {nowarn_deprecated_function,{gs,menubutton,2}}, - {nowarn_deprecated_function,{gs,menubutton,3}}, - {nowarn_deprecated_function,{gs,menuitem,2}}, - {nowarn_deprecated_function,{gs,menuitem,3}}, - {nowarn_deprecated_function,{gs,message,2}}, - {nowarn_deprecated_function,{gs,message,3}}, - {nowarn_deprecated_function,{gs,oval,2}}, - {nowarn_deprecated_function,{gs,oval,3}}, - {nowarn_deprecated_function,{gs,polygon,2}}, - {nowarn_deprecated_function,{gs,polygon,3}}, - {nowarn_deprecated_function,{gs,prompter,2}}, - {nowarn_deprecated_function,{gs,prompter,3}}, - {nowarn_deprecated_function,{gs,radiobutton,2}}, - {nowarn_deprecated_function,{gs,radiobutton,3}}, - {nowarn_deprecated_function,{gs,read,2}}, - {nowarn_deprecated_function,{gs,rectangle,2}}, - {nowarn_deprecated_function,{gs,rectangle,3}}, - {nowarn_deprecated_function,{gs,scale,2}}, - {nowarn_deprecated_function,{gs,scale,3}}, - {nowarn_deprecated_function,{gs,scrollbar,2}}, - {nowarn_deprecated_function,{gs,scrollbar,3}}, - {nowarn_deprecated_function,{gs,start,0}}, - {nowarn_deprecated_function,{gs,start,1}}, - {nowarn_deprecated_function,{gs,text,2}}, - {nowarn_deprecated_function,{gs,text,3}}, - {nowarn_deprecated_function,{gs,window,2}}, - {nowarn_deprecated_function,{gs,window,3}}]). - -%%-compile(export_all). --export([ - start/0, - start/1, - create/3, - create_named/4, - config/2, - read/2, - destroy/1, - create_tree/2, - window/2, - named_window/3, - button/2, - named_button/3, - checkbutton/2, - named_checkbutton/3, - radiobutton/2, - named_radiobutton/3, - frame/2, - named_frame/3, - canvas/2, - named_canvas/3, - label/2, - named_label/3, - message/2, - named_message/3, - listbox/2, - named_listbox/3, - entry/2, - named_entry/3, - scrollbar/2, - named_scrollbar/3, - scale/2, - named_scale/3, - editor/2, - named_editor/3, - prompter/2, - named_prompter/3, - line/2, - named_line/3, - oval/2, - named_oval/3, - rectangle/2, - named_rectangle/3, - polygon/2, - named_polygon/3, - text/2, - named_text/3, - image/2, - named_image/3, - arc/2, - named_arc/3, - menu/2, - named_menu/3, - menubutton/2, - named_menubutton/3, - menubar/2, - named_menubar/3, - menuitem/2, - named_menuitem/3, - grid/2, - named_grid/3, - gridline/2, - named_gridline/3, - %% Convenience functions - enable/1, - disable/1, - select/1, - deselect/1, - map/1, - unmap/1, - resize/3, - name_occupied/1 - - ]). - - -%% -%% gse:start() -%% Returns: -%% An identifier to a top object for the graphic system -%% -%% Errors: -%% Exits with a {?MODULE,start,Reason} if there is a problem -%% creating the top level graphic object. -%% - - -start() -> - case gs:start() of - {error,Reason} -> - exit({?MODULE, start,Reason}); - Return -> Return - end. - -%% -%% gse:start(Opts) -%% Returns: -%% An identifier to a top object for the graphic system -%% -%% Errors: -%% Exits with a {?MODULE,start,Reason} if there is a problem -%% creating the top level graphic object. -%% - - -start(Opts) -> - case gs:start(Opts) of - {error,Reason} -> - exit({?MODULE, start,Reason}); - Return -> Return - end. - -%% -%% gse:create(Objtype,Parent,Opts) replaces -%% the unnecessary functions: -%% gs:create(Obj,Parent) -%% gs:create(Obj,Parent,Opt) -%% gs:create(Obj,Parent) -%% gs:create(Obj,Parent) -%% -%% Returns: -%% An identifier for the created object -%% -%% Errors: {?MODULE, create, Reason}, where Reason is one of: -%% {no_such_parent, Parent} -%% {unknown_type, Type} -%% {incvalid_option, Type, {Option,Value}} -%% -%% -create(Objtype,Parent,Opts) when is_list(Opts) -> - case gs:create(Objtype,Parent,Opts) of - {error,Reason} -> - exit({?MODULE, create,Reason}); - Return -> Return - end. - - -%% -%% gse:create_named(Name, Objtype,Parent, Opts) replaces -%% the confusing -%% gs:create(Name,Objtype, Parent, Opts) -%% -%% Returns: -%% An identifier for the created object -%% -%% Errors: {?MODULE, create, Reason}, where Reason is one of: -%% {no_such_parent, Parent} -%% {unknown_type, Type} -%% {incvalid_option, Type, {Option,Value}} -%% {name_occupied,Name} -%% - -create_named(Name,Objtype,Parent,Opts) when is_list(Opts) -> - case gs:create(Objtype,Name,Parent,Opts) of - {error,Reason} -> - exit({?MODULE, create_named,Reason}); - Return -> Return - end. - - - -%% -%% gse:config(Object, Options) replaces -%% the unnecessary -%% gs:config(Object, Opt) -%% - -config(Object,Opts) when is_list(Opts) -> - case gs:config(Object,Opts) of - {error,Reason} -> - exit({?MODULE, config,Reason}); - Return -> Return - end. - -%% -%% gs:read(Object, OptionKey) -%% -read(Object,OptionKey) -> - case gs:read(Object,OptionKey) of - {error,Reason} -> - exit({?MODULE, read,Reason}); - Return -> Return - end. - -%% -%% gs:destroy(Object) -%% - -destroy(Object)-> - case gs:destroy(Object) of - {error,Reason} -> - exit({?MODULE, destroy,Reason}); - Return -> Return - end. - -%% -%% gs:create_tree -%% - -create_tree(Parent, Tree)-> - case gs:create_tree(Parent,Tree) of - {error,Reason} -> - exit({?MODULE, create_tree,Reason}); - Return -> Return - end. - - -window(Parent,Options) when is_list(Options) -> - case gs:window(Parent,Options) of - {error, Reason} -> - exit({?MODULE,window,Reason}); - Return -> Return - end. - -named_window(Name,Parent,Options) when is_list(Options) -> - case gs:window(Name, Parent,Options) of - {error, Reason} -> - exit({?MODULE,named_window,Reason}); - Return -> Return - end. - - -button(Parent,Options) when is_list(Options) -> - case gs:button(Parent,Options) of - {error, Reason} -> - exit({?MODULE,button,Reason}); - Return -> Return - end. - - -named_button(Name,Parent,Options) when is_list(Options) -> - case gs:button(Name, Parent,Options) of - {error, Reason} -> - exit({?MODULE,named_button,Reason}); - Return -> Return - end. - - -checkbutton(Parent,Options) when is_list(Options) -> - case gs:checkbutton(Parent,Options) of - {error, Reason} -> - exit({?MODULE,checkbutton,Reason}); - Return -> Return - end. - - -named_checkbutton(Name,Parent,Options) when is_list(Options) -> - case gs:checkbutton(Name, Parent,Options) of - {error, Reason} -> - exit({?MODULE,named_checkbutton,Reason}); - Return -> Return - end. - - -radiobutton(Parent,Options) when is_list(Options) -> - case gs:radiobutton(Parent,Options) of - {error, Reason} -> - exit({?MODULE,radiobutton,Reason}); - Return -> Return - end. - - -named_radiobutton(Name,Parent,Options) when is_list(Options) -> - case gs:radiobutton(Name, Parent,Options) of - {error, Reason} -> - exit({?MODULE,named_radiobutton,Reason}); - Return -> Return - end. - - -frame(Parent,Options) when is_list(Options) -> - case gs:frame(Parent,Options) of - {error, Reason} -> - exit({?MODULE,frame,Reason}); - Return -> Return - end. - - -named_frame(Name,Parent,Options) when is_list(Options) -> - case gs:frame(Name, Parent,Options) of - {error, Reason} -> - exit({?MODULE,named_frame,Reason}); - Return -> Return - end. - - -canvas(Parent,Options) when is_list(Options) -> - case gs:canvas(Parent,Options) of - {error, Reason} -> - exit({?MODULE,canvas,Reason}); - Return -> Return - end. - - -named_canvas(Name,Parent,Options) when is_list(Options) -> - case gs:canvas(Name, Parent,Options) of - {error, Reason} -> - exit({?MODULE,named_canvas,Reason}); - Return -> Return - end. - - -label(Parent,Options) when is_list(Options) -> - case gs:label(Parent,Options) of - {error, Reason} -> - exit({?MODULE,label,Reason}); - Return -> Return - end. - - -named_label(Name,Parent,Options) when is_list(Options) -> - case gs:label(Name, Parent,Options) of - {error, Reason} -> - exit({?MODULE,named_label,Reason}); - Return -> Return - end. - - -message(Parent,Options) when is_list(Options) -> - case gs:message(Parent,Options) of - {error, Reason} -> - exit({?MODULE,message,Reason}); - Return -> Return - end. - - -named_message(Name,Parent,Options) when is_list(Options) -> - case gs:message(Name, Parent,Options) of - {error, Reason} -> - exit({?MODULE,named_message,Reason}); - Return -> Return - end. - - -listbox(Parent,Options) when is_list(Options) -> - case gs:listbox(Parent,Options) of - {error, Reason} -> - exit({?MODULE,listbox,Reason}); - Return -> Return - end. - - -named_listbox(Name,Parent,Options) when is_list(Options) -> - case gs:listbox(Name, Parent,Options) of - {error, Reason} -> - exit({?MODULE,named_listbox,Reason}); - Return -> Return - end. - - -entry(Parent,Options) when is_list(Options) -> - case gs:entry(Parent,Options) of - {error, Reason} -> - exit({?MODULE,entry,Reason}); - Return -> Return - end. - - -named_entry(Name,Parent,Options) when is_list(Options) -> - case gs:entry(Name, Parent,Options) of - {error, Reason} -> - exit({?MODULE,named_entry,Reason}); - Return -> Return - end. - - -scrollbar(Parent,Options) when is_list(Options) -> - case gs:scrollbar(Parent,Options) of - {error, Reason} -> - exit({?MODULE,scrollbar,Reason}); - Return -> Return - end. - - -named_scrollbar(Name,Parent,Options) when is_list(Options) -> - case gs:scrollbar(Name, Parent,Options) of - {error, Reason} -> - exit({?MODULE,named_scrollbar,Reason}); - Return -> Return - end. - - -scale(Parent,Options) when is_list(Options) -> - case gs:scale(Parent,Options) of - {error, Reason} -> - exit({?MODULE,scale,Reason}); - Return -> Return - end. - - -named_scale(Name,Parent,Options) when is_list(Options) -> - case gs:scale(Name, Parent,Options) of - {error, Reason} -> - exit({?MODULE,named_scale,Reason}); - Return -> Return - end. - - -editor(Parent,Options) when is_list(Options) -> - case gs:editor(Parent,Options) of - {error, Reason} -> - exit({?MODULE,editor,Reason}); - Return -> Return - end. - - -named_editor(Name,Parent,Options) when is_list(Options) -> - case gs:editor(Name, Parent,Options) of - {error, Reason} -> - exit({?MODULE,named_editor,Reason}); - Return -> Return - end. - - -prompter(Parent,Options) when is_list(Options) -> - case gs:prompter(Parent,Options) of - {error, Reason} -> - exit({?MODULE,prompter,Reason}); - Return -> Return - end. - - -named_prompter(Name,Parent,Options) when is_list(Options) -> - case gs:prompter(Name, Parent,Options) of - {error, Reason} -> - exit({?MODULE,named_prompter,Reason}); - Return -> Return - end. - - -line(Parent,Options) when is_list(Options) -> - case gs:line(Parent,Options) of - {error, Reason} -> - exit({?MODULE,line,Reason}); - Return -> Return - end. - - -named_line(Name,Parent,Options) when is_list(Options) -> - case gs:line(Name, Parent,Options) of - {error, Reason} -> - exit({?MODULE,named_line,Reason}); - Return -> Return - end. - - -oval(Parent,Options) when is_list(Options) -> - case gs:oval(Parent,Options) of - {error, Reason} -> - exit({?MODULE,oval,Reason}); - Return -> Return - end. - - -named_oval(Name,Parent,Options) when is_list(Options) -> - case gs:oval(Name, Parent,Options) of - {error, Reason} -> - exit({?MODULE,named_oval,Reason}); - Return -> Return - end. - - -rectangle(Parent,Options) when is_list(Options) -> - case gs:rectangle(Parent,Options) of - {error, Reason} -> - exit({?MODULE,rectangle,Reason}); - Return -> Return - end. - - -named_rectangle(Name,Parent,Options) when is_list(Options) -> - case gs:rectangle(Name, Parent,Options) of - {error, Reason} -> - exit({?MODULE,named_rectangle,Reason}); - Return -> Return - end. - - -polygon(Parent,Options) when is_list(Options) -> - case gs:polygon(Parent,Options) of - {error, Reason} -> - exit({?MODULE,polygon,Reason}); - Return -> Return - end. - - -named_polygon(Name,Parent,Options) when is_list(Options) -> - case gs:polygon(Name, Parent,Options) of - {error, Reason} -> - exit({?MODULE,named_polygon,Reason}); - Return -> Return - end. - - -text(Parent,Options) when is_list(Options) -> - case gs:text(Parent,Options) of - {error, Reason} -> - exit({?MODULE,text,Reason}); - Return -> Return - end. - - -named_text(Name,Parent,Options) when is_list(Options) -> - case gs:text(Name, Parent,Options) of - {error, Reason} -> - exit({?MODULE,named_text,Reason}); - Return -> Return - end. - - -image(Parent,Options) when is_list(Options) -> - case gs:image(Parent,Options) of - {error, Reason} -> - exit({?MODULE,image,Reason}); - Return -> Return - end. - - -named_image(Name,Parent,Options) when is_list(Options) -> - case gs:image(Name, Parent,Options) of - {error, Reason} -> - exit({?MODULE,named_image,Reason}); - Return -> Return - end. - - -arc(Parent,Options) when is_list(Options) -> - case gs:arc(Parent,Options) of - {error, Reason} -> - exit({?MODULE,arc,Reason}); - Return -> Return - end. - - -named_arc(Name,Parent,Options) when is_list(Options) -> - case gs:arc(Name, Parent,Options) of - {error, Reason} -> - exit({?MODULE,named_arc,Reason}); - Return -> Return - end. - - -menu(Parent,Options) when is_list(Options) -> - case gs:menu(Parent,Options) of - {error, Reason} -> - exit({?MODULE,menu,Reason}); - Return -> Return - end. - - -named_menu(Name,Parent,Options) when is_list(Options) -> - case gs:menu(Name, Parent,Options) of - {error, Reason} -> - exit({?MODULE,named_menu,Reason}); - Return -> Return - end. - - -menubutton(Parent,Options) when is_list(Options) -> - case gs:menubutton(Parent,Options) of - {error, Reason} -> - exit({?MODULE,menubutton,Reason}); - Return -> Return - end. - - -named_menubutton(Name,Parent,Options) when is_list(Options) -> - case gs:menubutton(Name, Parent,Options) of - {error, Reason} -> - exit({?MODULE,named_menubutton,Reason}); - Return -> Return - end. - - -menubar(Parent,Options) when is_list(Options) -> - case gs:menubar(Parent,Options) of - {error, Reason} -> - exit({?MODULE,menubar,Reason}); - Return -> Return - end. - - -named_menubar(Name,Parent,Options) when is_list(Options) -> - case gs:menubar(Name, Parent,Options) of - {error, Reason} -> - exit({?MODULE,named_menubar,Reason}); - Return -> Return - end. - - -menuitem(Parent,Options) when is_list(Options) -> - case gs:menuitem(Parent,Options) of - {error, Reason} -> - exit({?MODULE,menuitem,Reason}); - Return -> Return - end. - - -named_menuitem(Name,Parent,Options) when is_list(Options) -> - case gs:menuitem(Name, Parent,Options) of - {error, Reason} -> - exit({?MODULE,named_menuitem,Reason}); - Return -> Return - end. - - -grid(Parent,Options) when is_list(Options) -> - case gs:grid(Parent,Options) of - {error, Reason} -> - exit({?MODULE,grid,Reason}); - Return -> Return - end. - - -named_grid(Name,Parent,Options) when is_list(Options) -> - case gs:grid(Name, Parent,Options) of - {error, Reason} -> - exit({?MODULE,named_grid,Reason}); - Return -> Return - end. - - -gridline(Parent,Options) when is_list(Options) -> - case gs:gridline(Parent,Options) of - {error, Reason} -> - exit({?MODULE,gridline,Reason}); - Return -> Return - end. - - -named_gridline(Name,Parent,Options) when is_list(Options) -> - case gs:gridline(Name, Parent,Options) of - {error, Reason} -> - exit({?MODULE,named_gridline,Reason}); - Return -> Return - end. - - - -%% gs:config - Utility functions - - -%% -%% enable/disable -%% - -enable(Object) -> - gse:config(Object,[{enable,true}]). - -disable(Object) -> - gse:config(Object,[{enable,false}]). - - - -%% -%% select/deselect -%% - -deselect(Object) -> - gse:config(Object,[{select,false}]). - -select(Object) -> - gse:config(Object,[{select,true}]). - - -%% -%% map/unmap -%% - -map(Object) -> - gse:config(Object,[{map,true}]). - -unmap(Object) -> - gse:config(Object,[{map,false}]). - - - -%% -%% resize -%% - -resize(Object, Width, Height) -> - gse:config(Object,[{width,Width}, {height, Height}]). - - - -%% -%% Misc utility functions -%% - -name_occupied(Name) -> - case gs:read(Name,id) of - {error,_Reason} -> - false; - _Id -> true - end. - - 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. diff --git a/lib/gs/src/gstk.hrl b/lib/gs/src/gstk.hrl deleted file mode 100644 index 931057573f..0000000000 --- a/lib/gs/src/gstk.hrl +++ /dev/null @@ -1,29 +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% -%% - -%% - -%% *NOTE*: if you change here, change ets:match in gstk_db too! --record(gstkid, {id=undefined, widget, widget_data, owner, parent, - objtype}). - --record(so, {main, object, hscroll, vscroll, misc}). - - diff --git a/lib/gs/src/gstk_arc.erl b/lib/gs/src/gstk_arc.erl deleted file mode 100644 index c38bbf4756..0000000000 --- a/lib/gs/src/gstk_arc.erl +++ /dev/null @@ -1,192 +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% -%% - -%% -%% ------------------------------------------------------------ -%% Basic Arc Type -%% ------------------------------------------------------------ - --module(gstk_arc). --compile([{nowarn_deprecated_function,{gs,creation_error,2}}]). - -%%----------------------------------------------------------------------------- -%% ARC OPTIONS -%% -%% Attributes: -%% bw Int -%% coords [{X1,Y1}, {X2,Y2}] -%% data Data -%% extent Degrees -%% fg Color -%% fill Color -%% start Degrees -%% stipple Bool -%% style pieslice, chord, arc -%% -%% Commands: -%% lower -%% move {Dx, Dy} -%% raise -%% scale {Xo, Yo, Sx, Sy} -%% setfocus Bool -%% -%% Events: -%% buttonpress [Bool | {Bool, Data}] -%% buttonrelease [Bool | {Bool, Data}] -%% enter [Bool | {Bool, Data}] -%% keypress [Bool | {Bool, Data}] -%% keyrelease [Bool | {Bool, Data}] -%% leave [Bool | {Bool, Data}] -%% motion [Bool | {Bool, Data}] -%% -%% Read Options: -%% children -%% id -%% parent -%% type -%% - --export([create/3, config/3, read/3, delete/2, destroy/3, event/5, - option/5,read_option/5]). - --include("gstk.hrl"). - -%%----------------------------------------------------------------------------- -%% MANDATORY INTERFACE FUNCTIONS -%%----------------------------------------------------------------------------- -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : create/7 -%% Purpose : Create a widget of the type defined in this module. -%% Args : DB - The Database -%% Objmod - An atom, this module -%% Objtype - An atom, the logical widget type -%% Owner - Pid of the creator -%% Name - An atom naming the widget -%% Parent - Gsid of the parent -%% Opts - A list of options for configuring the widget -%% -%% Return : [Gsid_of_new_widget | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -create(DB, GstkId, Opts) -> - case gstk_canvas:pickout_coords(Opts, [],GstkId#gstkid.objtype,2) of - {error, Error} -> - gs:creation_error(GstkId,Error); - {Coords, NewOpts} -> - Ngstkid=gstk_canvas:upd_gstkid(DB, GstkId, Opts), - #gstkid{widget=CanvasTkW}=Ngstkid, - MCmd = [CanvasTkW, " create ar ", Coords], - gstk_canvas:mk_cmd_and_call(NewOpts,Ngstkid,CanvasTkW,MCmd,DB) - end. - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : config/3 -%% Purpose : Configure a widget of the type defined in this module. -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% Opts - A list of options for configuring the widget -%% -%% Return : [true | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -config(DB, Gstkid, Opts) -> - gstk_canvas:item_config(DB, Gstkid, Opts). - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : read/3 -%% Purpose : Read one option from a widget -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% Opt - An option to read -%% -%% Return : [OptionValue | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -read(DB, Gstkid, Opt) -> - Item = Gstkid#gstkid.widget_data, - gstk_generic:read_option(DB,Gstkid,Opt,[gstk:to_ascii(Item)]). - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : delete/2 -%% Purpose : Delete widget from databas and return tkwidget to destroy -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% -%% Return : TkWidget to destroy | {Parent, Objmod, Args}. -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -delete(DB, Gstkid) -> - gstk_canvas:item_delete_impl(DB,Gstkid). - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : destroy/3 -%% Purpose : Destroy a widget -%% Args : DB - The Database -%% Canvas - The canvas tk widget -%% Item - The item number to destroy -%% -%% Return : [true | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -destroy(_DB, Canvas, Item) -> - gstk:exec([Canvas, " delete ", gstk:to_ascii(Item)]). - - -event(DB, Gstkid, Etype, Edata, Args) -> - gstk_generic:event(DB, Gstkid, Etype, Edata, Args). - -%%------------------------------------------------------------------------------ -%% MANDATORY FUNCTIONS -%%------------------------------------------------------------------------------ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : option/5 -%% Purpose : Take care of options -%% Args : MainW - The main tk-widget -%% Canvas - The canvas tk-widget -%% Return : A tuple {OptionType, OptionCmd} -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -option(Option, _Gstkid, _Canvas, _DB, _AItem) -> - case Option of - {bw, Int} -> {s, [" -w ", gstk:to_ascii(Int)]}; - {extent, Degrees} -> {s, [" -e ", gstk:to_ascii(Degrees)]}; - {fg, Color} -> {s, [" -outline ", gstk:to_color(Color)]}; - {start, Degrees} -> {s, [" -start ", gstk:to_ascii(Degrees)]}; - {style, Style} -> {s, [" -sty ", gstk:to_ascii(Style)]}; - _ -> invalid_option - end. - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : read_option/5 -%% Purpose : Take care of a read option -%% Return : The value of the option or invalid_option -%% [OptionValue | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -read_option(Option, Gstkid, Canvas, _DB, AItem) -> - case Option of - bw -> tcl2erl:ret_int([Canvas, " itemcg ", AItem, " -w"]); - extent -> tcl2erl:ret_int([Canvas, " itemcg ", AItem, " -e"]); - fg -> tcl2erl:ret_color([Canvas, " itemcg ", AItem, " -outline"]); - start -> tcl2erl:ret_int([Canvas, " itemcg ", AItem, " -start"]); - stipple -> tcl2erl:ret_stipple([Canvas, " itemcg ", AItem, " -sti"]); - style -> tcl2erl:ret_atom([Canvas, " itemcg ", AItem, " -sty"]); - - _ -> {bad_result, {Gstkid#gstkid.objtype, invalid_option, Option}} - end. - -%% ----- Done ----- diff --git a/lib/gs/src/gstk_button.erl b/lib/gs/src/gstk_button.erl deleted file mode 100644 index 2b466c30c3..0000000000 --- a/lib/gs/src/gstk_button.erl +++ /dev/null @@ -1,221 +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% -%% - -%% -%% ------------------------------------------------------------ -%% Basic Button Type -%% ------------------------------------------------------------ - --module(gstk_button). - -%%------------------------------------------------------------------------------ -%% BUTTON OPTIONS -%% -%% Attributes: -%% activebg Color -%% activefg Color -%% align n,w,s,e,nw,se,ne,sw,center -%% anchor n,w,s,e,nw,se,ne,sw,center -%% bg Color -%% bw Int -%% data Data -%% disabledfg Color -%% fg Color -%% font Font -%% height Int -%% highlightbg Color -%% highlightbw Int -%% highlightfg Color -%% justify left|right|center -%% label {text, String} | {image, BitmapFile} -%% padx Int (Pixels) -%% pady Int (Pixels) -%% relief Relief [flat|raised|sunken|ridge|groove] -%% underline Int -%% width Int -%% wraplength Int -%% x Int -%% y Int -%% -%% Commands: -%% enable Bool -%% flash -%% invoke -%% setfocus Bool -%% -%% Events: -%% buttonpress [Bool | {Bool, Data}] -%% buttonrelease [Bool | {Bool, Data}] -%% click [Bool | {Bool, Data}] -%% configure [Bool | {Bool, Data}] -%% destroy [Bool | {Bool, Data}] -%% enter [Bool | {Bool, Data}] -%% focus [Bool | {Bool, Data}] -%% keypress [Bool | {Bool, Data}] -%% keyrelease [Bool | {Bool, Data}] -%% leave [Bool | {Bool, Data}] -%% motion [Bool | {Bool, Data}] -%% -%% Read Options: -%% children -%% id -%% parent -%% type -%% -%% Not Implemented: -%% cursor ?????? -%% font ?????? -%% - --export([create/3,config/3,read/3,delete/2,event/5,option/5,read_option/5]). - --include("gstk.hrl"). - -%%--------------------------------------------------------------------------- -%% MANDATORY INTERFACE FUNCTIONS -%%--------------------------------------------------------------------------- -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : create/3 -%% Purpose : Create a widget of the type defined in this module. -%% Return : [Gsid_of_new_widget | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -create(DB, GstkId, Opts) -> - TkW = gstk_generic:mk_tkw_child(DB,GstkId), - NGstkId=GstkId#gstkid{widget=TkW}, - PlacePreCmd = [";place ", TkW], - case gstk_generic:make_command(Opts,NGstkId,TkW,"",PlacePreCmd,DB) of - {error,Reason} -> {error,Reason}; - Cmd when is_list(Cmd) -> - gstk:exec(["button ", TkW," -rel raised -bo 2 ",Cmd]), - NGstkId - end. - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : config/3 -%% Purpose : Configure a widget of the type defined in this module. -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% Opts - A list of options for configuring the widget -%% -%% Return : [true | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -config(DB, Gstkid, Opts) -> - TkW = Gstkid#gstkid.widget, - SimplePreCmd = [TkW, " conf"], - gstk_generic:mk_cmd_and_exec(Opts,Gstkid,SimplePreCmd,DB). - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : read/3 -%% Purpose : Read one option from a widget -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% Opt - An option to read -%% -%% Return : [OptionValue | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -read(DB, Gstkid, Opt) -> - gstk_generic:read_option(DB, Gstkid, Opt). - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : delete/2 -%% Purpose : Delete widget from databas and return tkwidget to destroy -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% -%% Return : TkWidget to destroy -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -delete(DB, Gstkid) -> - gstk_db:delete_widget(DB, Gstkid), - Gstkid#gstkid.widget. - -event(DB, Gstkid, Etype, Edata, Args) -> - gstk_generic:event(DB, Gstkid, Etype, Edata, Args). - -%%------------------------------------------------------------------------------ -%% MANDATORY FUNCTIONS -%%------------------------------------------------------------------------------ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : option/4 -%% Purpose : Take care of options -%% Args : Option - An option tuple -%% Gstkid - The gstkid of the widget -%% TkW - The tk-widget -%% DB - The Database -%% -%% Return : A tuple {OptionType, OptionCmd} -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -option(Option, Gstkid, TkW, DB,_) -> - case Option of - {bitmap, Bitmap} -> {s, [" -bi @", Bitmap]}; - {disabledfg, Color} -> {s, [" -disabledf ", gstk:to_color(Color)]}; - {underline, Int} -> {s, [" -un ", gstk:to_ascii(Int)]}; - {wraplength, Int} -> {s, [" -wr ", gstk:to_ascii(Int)]}; - invoke -> {c, [TkW, " i;"]}; - flash -> {c, [TkW, " f;"]}; - {click, On} -> cbind(DB, Gstkid, click, On); - _ -> invalid_option - end. - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : read_option/4 -%% Purpose : Take care of a read option -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% Option - An option -%% -%% Return : The value of the option or invalid_option -%% [OptionValue | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -read_option(Option,Gstkid, TkW,DB,_) -> - case Option of - disabledfg -> tcl2erl:ret_color([TkW, " cg -disabledf"]); - underline -> tcl2erl:ret_int([TkW, " cg -un"]); - wraplength -> tcl2erl:ret_int([TkW, " cg -wr"]); - - click -> gstk_db:is_inserted(DB, Gstkid, click); - - _ -> {bad_result, {Gstkid#gstkid.objtype, invalid_option, Option}} - end. - -%%------------------------------------------------------------------------------ -%% PRIMITIVES -%%------------------------------------------------------------------------------ - -%% -%% Config bind -%% -cbind(DB, Gstkid, Etype, On) -> - TkW = Gstkid#gstkid.widget, - Cmd = case On of - {true, Edata} -> - Eref = gstk_db:insert_event(DB, Gstkid, Etype, Edata), - [" -command {erlsend ", Eref, " \\\"[", TkW, " cg -text]\\\"}"]; - true -> - Eref = gstk_db:insert_event(DB, Gstkid, Etype, ""), - [" -command {erlsend ", Eref, " \\\"[", TkW, " cg -text]\\\"}"]; - _Other -> - gstk_db:delete_event(DB, Gstkid, Etype), - " -command {}" - end, - {s, Cmd}. - -%% ----- Done ----- - diff --git a/lib/gs/src/gstk_canvas.erl b/lib/gs/src/gstk_canvas.erl deleted file mode 100644 index 102b81df7a..0000000000 --- a/lib/gs/src/gstk_canvas.erl +++ /dev/null @@ -1,516 +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% -%% - -%% -%% ------------------------------------------------------------ -%% Basic Canvas Type -%% ------------------------------------------------------------ - --module(gstk_canvas). --compile([{nowarn_deprecated_function,{gs,pair,2}}, - {nowarn_deprecated_function,{gs,val,2}}]). - -%%----------------------------------------------------------------------------- -%% CANVAS OPTIONS -%% -%% Attributes: -%% activebg Color -%% anchor n,w,s,e,nw,se,ne,sw,center -%% bc Color -%% bg Color -%% bw Wth -%% data Data -%% height Int -%% highlightbg Color -%% highlightbw Wth -%% highlightfg Color -%% hscroll Bool | top | bottom -%% relief Relief -%% scrollbg Color -%% scrollfg Color -%% scrollregion {X1, Y1, X2, Y2} -%% selectbg Color -%% selectbw Width -%% selectfg Color -%% vscroll Bool | left | right -%% width Int -%% x Int -%% y Int -%% -%% -%% Commands: -%% find {X, Y} => Item at pos X,Y or false -%% setfocus Bool -%% -%% Events: -%% buttonpress [Bool | {Bool, Data}] -%% buttonrelease [Bool | {Bool, Data}] -%% configure [Bool | {Bool, Data}] -%% destroy [Bool | {Bool, Data}] -%% enter [Bool | {Bool, Data}] -%% focus [Bool | {Bool, Data}] -%% keypress [Bool | {Bool, Data}] -%% keyrelease [Bool | {Bool, Data}] -%% leave [Bool | {Bool, Data}] -%% motion [Bool | {Bool, Data}] -%% -%% Read Options: -%% children -%% id -%% parent -%% type -%% -%% Not Implemented: -%% fg Color -%% - --export([create/3,config/3,read/3,delete/2,event/5,option/5,read_option/5]). --export([make_command/5,make_command/6,pickout_coords/4, coords/1, - item_config/3,mk_create_opts_for_child/4, - upd_gstkid/3,item_delete_impl/2,mk_cmd_and_exec/6,mk_cmd_and_call/5]). - --include("gstk.hrl"). - -%%----------------------------------------------------------------------------- -%% MANDATORY INTERFACE FUNCTIONS -%%----------------------------------------------------------------------------- -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : create/3 -%% Return : [Gsid_of_new_widget | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -create(DB, Gstkid, Opts) -> - MainW = gstk_generic:mk_tkw_child(DB,Gstkid), - Canvas = lists:append(MainW,".z"), - {Vscroll, Hscroll, NewOpts} = gstk_generic:parse_scrolls(Opts), - WidgetD = #so{main=MainW, object=Canvas, - hscroll=Hscroll, vscroll=Vscroll}, - NGstkid=Gstkid#gstkid{widget=MainW, widget_data=WidgetD}, - MandatoryCmd = ["so_create canvas ", MainW], - case gstk:call(MandatoryCmd) of - {result, _} -> - SimplePreCmd = [MainW, " conf"], - PlacePreCmd = [";place ", MainW], - gstk_db:insert_opt(DB,Gstkid,gs:pair(scrollregion,Opts)), - case gstk_generic:make_command(NewOpts, NGstkid, MainW, - SimplePreCmd, PlacePreCmd, DB,Canvas) of - {error,Reason} -> {error,Reason}; - Cmd when is_list(Cmd) -> - gstk:exec(Cmd), - gstk:exec([MainW,".sy conf -rel sunken -bo 2;", - MainW,".pad.sx conf -rel sunken -bo 2;"]), - NGstkid - end; - Bad_Result -> - {bad_result, Bad_Result} - end. - -mk_create_opts_for_child(DB,Cgstkid, Pgstkid, Opts) -> - gstk_generic:mk_create_opts_for_child(DB,Cgstkid,Pgstkid,Opts). - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : config/3 -%% Purpose : Configure a widget of the type defined in this module. -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% Opts - A list of options for configuring the widget -%% -%% Return : [true | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -config(DB, Gstkid, Options) -> - SO = Gstkid#gstkid.widget_data, - MainW = Gstkid#gstkid.widget, - Canvas = SO#so.object, - NewOpts = gstk_generic:parse_scrolls(Gstkid, Options), - SimplePreCmd = [MainW, " conf"], - PlacePreCmd = [";place ", MainW], - gstk_generic:mk_cmd_and_exec(NewOpts, Gstkid, MainW, - SimplePreCmd, PlacePreCmd, DB,Canvas). - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : read/3 -%% Purpose : Read one option from a widget -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% Opt - An option to read -%% -%% Return : [OptionValue | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -read(DB, Gstkid, Opt) -> - SO = Gstkid#gstkid.widget_data, - gstk_generic:read_option(DB, Gstkid, Opt,SO#so.object). - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : delete/2 -%% Purpose : Delete widget from databas and return tkwidget to destroy -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% -%% Return : TkWidget to destroy -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -delete(DB, Gstkid) -> - gstk_db:delete_widget(DB, Gstkid), - Gstkid#gstkid.widget. - -event(DB, Gstkid, Etype, Edata, Args) -> - gstk_generic:event(DB, Gstkid, Etype, Edata, Args). - - -%%----------------------------------------------------------------------------- -%% MANDATORY FUNCTIONS -%%----------------------------------------------------------------------------- -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : option/5 -%% Purpose : Take care of options -%% Args : Option - An option tuple -%% Gstkid - The gstkid of the widget -%% MainW - The main tk-widget -%% Canvas - The canvas tk-widget -%% DB - The Database -%% -%% Return : A tuple {OptionType, OptionCmd} -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -option(Option,Gstkid,_MainW,DB,Canvas) -> - case Option of - {scrollregion, {X1, Y1, X2, Y2}} -> - gstk_db:insert_opt(DB,Gstkid,Option), - {c, [Canvas, " conf -scrollr {", - gstk:to_ascii(X1), " ", gstk:to_ascii(Y1), " ", - gstk:to_ascii(X2), " ", gstk:to_ascii(Y2),"}"]}; - {yscrollpos, Y} -> - {_,Ymin,_,Ymax} = gstk_db:opt(DB,Gstkid,scrollregion), - K = 1/(Ymax-Ymin), - M = -K*Ymin, - PercentOffViewTop = K*Y+M, - {c, [Canvas," yvi mo ",gstk:to_ascii(PercentOffViewTop)]}; - {xscrollpos, X} -> - {Xmin,_,Xmax,_} = gstk_db:opt(DB,Gstkid,scrollregion), - K = 1/(Xmax-Xmin), - M = -K*Xmin, - PercentOffViewLeft = K*X+M, - {c, [Canvas," xvi mo ",gstk:to_ascii(PercentOffViewLeft)]}; - {buttonpress, On} -> bind(DB, Gstkid, Canvas, buttonpress, On); - {buttonrelease, On} -> bind(DB, Gstkid, Canvas, buttonrelease, On); - {configure, On} -> bind(DB, Gstkid, Canvas, configure, On); - {destroy, On} -> bind(DB, Gstkid, Canvas, destroy, On); - {enter, On} -> bind(DB, Gstkid, Canvas, enter, On); - {focus, On} -> bind(DB, Gstkid, Canvas, focus, On); - {keypress, On} -> bind(DB, Gstkid, Canvas, keypress, On); - {keyrelease, On} -> bind(DB, Gstkid, Canvas, keyrelease, On); - {leave, On} -> bind(DB, Gstkid, Canvas, leave, On); - {motion, On} -> bind(DB, Gstkid, Canvas, motion, On); - - {secret_hack_gridit, GridGstkid} -> - CRef = gstk_db:insert_event(DB, GridGstkid, click, []), - ClickCmd = [Canvas, " bind all <ButtonRelease-1> {erlsend ", CRef, - " [",Canvas, " find withtag current]};"], - DRef = gstk_db:insert_event(DB, GridGstkid, doubleclick, []), - DclickCmd = [Canvas," bind all <Double-ButtonRelease-1> {erlsend ", - DRef," [",Canvas, " find withtag current]}"], - %% bind all at once for preformance reasons. - {c, [ClickCmd,DclickCmd]}; - {secret_forwarded_grid_event, {Event,On},GridGstkid} -> - bind(DB,GridGstkid,Canvas,Event,On); - _ -> invalid_option - end. - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : read_option/5 -%% Purpose : Take care of a read option -%% Return : The value of the option or invalid_option -%% [OptionValue | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -read_option(Option,Gstkid,_MainW,DB,Canvas) -> - case Option of - scrollregion -> gstk_db:opt(DB,Gstkid,scrollregion); - {hit, {X,Y}} -> - hit(DB,Canvas,X,Y,X,Y); - {hit, [{X1,Y1},{X2,Y2}]} -> - hit(DB,Canvas,X1,Y1,X2,Y2); - % {% hidden above, % of total area that is visible + % hidden above} - yscrollpos -> - {PercentOffViewTop,_} = tcl2erl:ret_tuple([Canvas," yvi"]), - {_,Ymin,_,Ymax} = gstk_db:opt(DB,Gstkid,scrollregion), - K = 1/(Ymax-Ymin), - M = -K*Ymin, - _Y = round((PercentOffViewTop - M)/K); - xscrollpos -> - {PercentOffViewLeft,_} = tcl2erl:ret_tuple([Canvas," xvi"]), - {Xmin,_,Xmax,_} = gstk_db:opt(DB,Gstkid,scrollregion), - K = 1/(Xmax-Xmin), - M = -K*Xmin, - _X = round((PercentOffViewLeft-M)/K); - buttonpress -> gstk_db:is_inserted(DB, Gstkid, buttonpress); - buttonrelease -> gstk_db:is_inserted(DB, Gstkid, buttonrelease); - configure -> gstk_db:is_inserted(DB, Gstkid, configure); - destroy -> gstk_db:is_inserted(DB, Gstkid, destroy); - enter -> gstk_db:is_inserted(DB, Gstkid, enter); - focus -> gstk_db:is_inserted(DB, Gstkid, focus); - keypress -> gstk_db:is_inserted(DB, Gstkid, keypress); - keyrelease -> gstk_db:is_inserted(DB, Gstkid, keyrelease); - leave -> gstk_db:is_inserted(DB, Gstkid, leave); - motion -> gstk_db:is_inserted(DB, Gstkid, motion); - - _ -> {bad_result, {Gstkid#gstkid.objtype, invalid_option, Option}} - end. - -hit(DB,Canvas,X1,Y1,X2,Y2) -> - Ax1 = gstk:to_ascii(X1), - Ay1 = gstk:to_ascii(Y1), - Ax2 = gstk:to_ascii(X2), - Ay2 = gstk:to_ascii(Y2), - case tcl2erl:ret_list([Canvas," find overlapping ", - Ax1,$ ,Ay1,$ ,Ax2,$ ,Ay2]) of - Items when is_list(Items) -> - [{_,Node}] = ets:lookup(DB,frontend_node), - fix_ids(Items,DB,Canvas,Node); - Other -> - {bad_result, Other} - end. - -fix_ids([Item|Items],DB,Canvas,Node) -> - [{gstk_db:lookup_item(DB,Canvas,Item),Node}|fix_ids(Items,DB,Canvas,Node)]; -fix_ids([],_,_,_) -> []. - -%%----------------------------------------------------------------------------- -%% PRIMITIVES -%%----------------------------------------------------------------------------- - -%% -%% Event bind main function -%% -%% Should return a list of tcl commands or invalid_option -%% -%% WS = Widget suffix for c widgets -%% -bind(DB, Gstkid, TkW, Etype, On) -> - case bind(DB, Gstkid, TkW, Etype, On, "") of - invalid_option -> invalid_option; - Cmd -> {c, Cmd} - end. - -bind(DB, Gstkid, TkW, Etype, On, WS) -> - case On of - true -> ebind(DB, Gstkid, TkW, Etype, WS, ""); - false -> eunbind(DB, Gstkid, TkW, Etype, WS, ""); - {true, Edata} -> ebind(DB, Gstkid, TkW, Etype, WS, Edata); - {false, Edata} -> eunbind(DB, Gstkid, TkW, Etype, WS, Edata); - _ -> invalid_option - end. - - -%% -%% Event bind on -%% -%% Should return a list of tcl commands or invalid_option -%% -%% WS = Widget suffix for complex widgets -%% -ebind(DB, Gstkid, TkW, Etype, WS, Edata) -> - Eref = gstk_db:insert_event(DB, Gstkid, Etype, Edata), - P = ["bind ", TkW, WS], - Cmd = case Etype of - motion -> [P, " <Motion> {erlsend ", Eref, " [", - TkW, " canvasx %x] [", TkW, " canvasy %y] %x %y}"]; - keypress -> - [P, " <Key> {erlsend ", Eref," %K %N 0 0 [", - TkW, " canvasx %x] [", TkW, " canvasy %y]};", - P, " <Shift-Key> {erlsend ", Eref, " %K %N 1 0 [", - TkW, " canvasx %x] [", TkW, " canvasy %y]};", - P, " <Control-Key> {erlsend ", Eref, " %K %N 0 1 [", - TkW, " canvasx %x] [", TkW, " canvasy %y]};", - P, " <Control-Shift-Key> {erlsend ", Eref," %K %N 1 1 [", - TkW, " canvasx %x] [", TkW, " canvasy %y]}"]; - keyrelease -> - [P, " <KeyRelease> {erlsend ", Eref," %K %N 0 0 [", - TkW, " canvasx %x] [", TkW, " canvasy %y]};", - P, " <Shift-KeyRelease> {erlsend ", Eref, " %K %N 1 0 [", - TkW, " canvasx %x] [", TkW, " canvasy %y]};", - P, " <Control-KeyRelease> {erlsend ", Eref, " %K %N 0 1 [", - TkW, " canvasx %x] [", TkW, " canvasy %y]};", - P," <Control-Shift-KeyRelease> {erlsend ",Eref," %K %N 1 1[", - TkW, " canvasx %x] [", TkW, " canvasy %y]}"]; - buttonpress -> - [P, " <Button> {erlsend ", Eref, " %b [", - TkW, " canvasx %x] [", TkW, " canvasy %y] %x %y}"]; - buttonrelease -> - [P, " <ButtonRelease> {erlsend ", Eref, " %b [", - TkW, " canvasx %x] [", TkW, " canvasy %y] %x %y}"]; - leave -> [P, " <Leave> {erlsend ", Eref, "}"]; - enter -> [P, " <Enter> {erlsend ", Eref, "}"]; - destroy -> - [P, " <Destroy> {if {\"%W\"==\"", [TkW, WS], - "\"} {erlsend ", Eref, "}}"]; - focus -> - [P, " <FocusIn> {erlsend ", Eref, " true};" , - P, " <FocusOut> {erlsend ", Eref, " false}"]; - configure -> - [P, " <Configure> {if {\"%W\"==\"", [TkW, WS], - "\"} {erlsend ", Eref, " %w %h %x %y}}"] - end, - Cmd. - - -%% -%% Unbind event -%% -%% Should return a list of tcl commands -%% Already checked for validation in bind/5 -%% -%% WS = Widget suffix for complex widgets -%% -eunbind(DB, Gstkid, TkW, Etype, WS, _Edata) -> - gstk_db:delete_event(DB, Gstkid, Etype), - P = ["bind ", TkW, WS], - Cmd = case Etype of - motion -> - [P, " <Motion> {}"]; - keypress -> - [P, " <KeyRelease> {};", - P, " <Shift-KeyRelease> {};", - P, " <Control-KeyRelease> {};", - P, " <Control-Shift-KeyRelease> {}"]; - keyrelease -> - [P, " <KeyRelease> {};", - P, " <Shift-KeyRelease> {};", - P, " <Control-KeyRelease> {};", - P, " <Control-Shift-KeyRelease> {}"]; - buttonpress -> - [P, " <ButtonPress> {}"]; - buttonrelease -> - [P, " <ButtonRelease> {}"]; - leave -> - [P, " <Leave> {}"]; - enter -> - [P, " <Enter> {}"]; - destroy -> - [P, " <Destroy> {}"]; - focus -> - [P, " <FocusIn> {};", - P, " <FocusOut> {}"]; - configure -> - [P, " <Configure> {}"] - end, - Cmd. - -%%====================================================================== -%% Item library -%%====================================================================== - -mk_cmd_and_exec(Options, Gstkid, Canvas, AItem, SCmd, DB) -> - case make_command(Options, Gstkid, Canvas, AItem, SCmd, DB) of - {error,Reason} -> {error,Reason}; - Cmd when is_list(Cmd) -> - gstk:exec(Cmd) - end. - -mk_cmd_and_call(Opts,Gstkid, CanvasTkW, MCmd, DB) -> - case make_command(Opts,Gstkid, CanvasTkW, MCmd, DB) of - {error,Reason} -> {error,Reason}; - Cmd when is_list(Cmd) -> - case tcl2erl:ret_int(Cmd) of - Item when is_integer(Item) -> - G2 = gstk_db:lookup_gstkid(DB,Gstkid#gstkid.id), % buu, not nice - NewGstkid = G2#gstkid{widget_data=Item}, - NewGstkid; - Bad_result -> - {error,Bad_result} - end - end. - - -%%---------------------------------------------------------------------- -%% MCmd = Mandatory command -%% Comment: The problem: Create everything in one async command and -%% get the canvas obj integer id no back then. -%% The trick is to do: -%% set w [canvas create rectangle x1 y1 x2 y2 -Option Value ...]; -%% canvas Action $w ;$w -%% Comment: no placer options (we don't have to consider all permutations) -%%---------------------------------------------------------------------- -make_command(Options, Gstkid, Canvas, AItem, SCmd, DB) -> - case gstk_generic:out_opts(Options,Gstkid,Canvas,DB,AItem, [],[],[]) of - {[], [], []} -> []; - {Si, [], []} -> [SCmd, Si]; - {[], [], Co} -> Co; - {Si, [], Co} -> [SCmd, Si, $;, Co]; - {error,Reason} -> {error,Reason} - end. - -make_command(Options, Gstkid, Canvas, MCmd, DB) -> - case gstk_generic:out_opts(Options,Gstkid,Canvas,DB,"$w",[],[],[]) of - {[], [], []} -> MCmd; - {Si, [], []} -> [MCmd, Si]; - {[], [], Co} -> ["set w [", MCmd, "];", Co, "set d $w"]; - {Si, [], Co} -> ["set w [", MCmd, Si, "];", Co, "set d $w"]; - {error,Reason} -> {error,Reason} - end. - -item_config(DB, Gstkid, Opts) -> - #gstkid{widget=Canvas,widget_data=Item}=Gstkid, - AItem = gstk:to_ascii(Item), - SCmd = [Canvas, " itemconf ", AItem], - case make_command(Opts, Gstkid, Canvas, AItem, SCmd, DB) of - {error,Reason} -> {error,Reason}; - Cmd when is_list(Cmd) -> - gstk:exec(Cmd) - end. - -pickout_coords([{coords,Coords} | Rest], Opts, ObjType, NbrOfCoords) - when length(Coords) == NbrOfCoords -> - case coords(Coords) of - invalid -> - {error, io_lib:format("A ~w must have ~w coordinates", - [ObjType,NbrOfCoords])}; - RealCoords -> - {RealCoords, lists:append(Rest, Opts)} - end; -pickout_coords([Opt | Rest], Opts, ObjType, NbrOfCoords) -> - pickout_coords(Rest, [Opt|Opts], ObjType, NbrOfCoords); -pickout_coords([], _Opts, ObjType, NbrOfCoords) -> - {error, io_lib:format("A ~w must have ~w coordinates", - [ObjType,NbrOfCoords])}. - -coords([{X,Y} | R]) when is_number(X),is_number(Y) -> - [gstk:to_ascii(X), " ", gstk:to_ascii(Y), " ", coords(R)]; -coords([_]) -> %% not a pair - invalid; -coords([]) -> - []. - -item_delete_impl(DB,Gstkid) -> - gstk_db:delete_widget(DB, Gstkid), - #gstkid{widget=Canvas,widget_data=Item,parent=P,id=ID,objtype=Type}=Gstkid, - {P,ID,gstk_widgets:type2mod(Type), [Canvas, Item]}. - - -upd_gstkid(DB, Gstkid, Opts) -> - #gstkid{parent=Parent,owner=Owner}=Gstkid, - Pgstkid = gstk_db:lookup_gstkid(DB, Parent, Owner), - SO = Pgstkid#gstkid.widget_data, - CanvasTkW = SO#so.object, - gstk_db:insert_opt(DB,Gstkid,{coords,gs:val(coords,Opts)}), - gstk_db:update_widget(DB,Gstkid#gstkid{widget=CanvasTkW,widget_data=no_item}). - - -%%% ----- Done ----- - - diff --git a/lib/gs/src/gstk_checkbutton.erl b/lib/gs/src/gstk_checkbutton.erl deleted file mode 100644 index ac8abaedf3..0000000000 --- a/lib/gs/src/gstk_checkbutton.erl +++ /dev/null @@ -1,320 +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% -%% - -%% -%% ------------------------------------------------------------ -%% Basic CheckButton Type -%% ------------------------------------------------------------ - --module(gstk_checkbutton). - -%%------------------------------------------------------------------------------ -%% CHECKBUTTON OPTIONS -%% -%% Attributes: -%% activebg Color -%% activefg Color -%% align n,w,s,e,nw,se,ne,sw,center -%% anchor n,w,s,e,nw,se,ne,sw,center -%% bg Color -%% bw Int -%% data Data -%% disabledfg Color -%% fg Color -%% group Atom -%% groupid Groupid -%% height Int -%% highlightbg Color -%% highlightbw Int -%% highlightfg Color -%% justify left|right|center -%% label {text, String} | {image, BitmapFile} -%% padx Int (Pixels) -%% pady Int (Pixels) -%% relief Relief [flat|raised|sunken|ridge|groove] -%% select Bool -%% selectbg Color -%% underline Int -%% width Int -%% wraplength Int -%% x Int -%% y Int -%% -%% Commands: -%% enable Bool -%% flash -%% invoke -%% setfocus Bool -%% toggle -%% -%% Events: -%% buttonpress [Bool | {Bool, Data}] -%% buttonrelease [Bool | {Bool, Data}] -%% click [Bool | {Bool, Data}] -%% destroy [Bool | {Bool, Data}] -%% enter [Bool | {Bool, Data}] -%% focus [Bool | {Bool, Data}] -%% keypress [Bool | {Bool, Data}] -%% keyrelease [Bool | {Bool, Data}] -%% leave [Bool | {Bool, Data}] -%% motion [Bool | {Bool, Data}] -%% -%% Read Options: -%% children -%% id -%% parent -%% type -%% -%% Not Implemented: -%% cursor ?????? -%% focus ?????? (-takefocus) -%% font ?????? -%% - --export([create/3,config/3,read/3,delete/2,event/5,option/5,read_option/5]). - --include("gstk.hrl"). - -%%----------------------------------------------------------------------------- -%% MANDATORY INTERFACE FUNCTIONS -%%----------------------------------------------------------------------------- -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : create/7 -%% Purpose : Create a widget of the type defined in this module. -%% Return : [Gsid_of_new_widget | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -create(DB, GstkId, Opts) -> - TkW = gstk_generic:mk_tkw_child(DB,GstkId), - {G, GID, _NOpts} = fix_group(Opts, DB, GstkId#gstkid.owner), - NGstkId=GstkId#gstkid{widget=TkW,widget_data={G, GID}}, - PlacePreCmd = [";place ", TkW], - case gstk_generic:make_command(Opts,NGstkId,TkW,"",PlacePreCmd,DB) of - {error,Reason} -> {error,Reason}; - Cmd when is_list(Cmd) -> - gstk:exec(["checkbutton ", TkW," -bo 2 -indi true ",Cmd]), - NGstkId - end. - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : config/3 -%% Purpose : Configure a widget of the type defined in this module. -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% Opts - A list of options for configuring the widget -%% -%% Return : [true | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -config(DB, Gstkid, Opts) -> - TkW = Gstkid#gstkid.widget, - {NOpts, NGstkid} = fix_group(Opts, DB, Gstkid#gstkid.owner, Gstkid), - SimplePreCmd = [TkW, " conf"], - PlacePreCmd = [";place ", TkW], - gstk_generic:mk_cmd_and_exec(NOpts,NGstkid,TkW,SimplePreCmd,PlacePreCmd,DB). - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : read/3 -%% Purpose : Read one option from a widget -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% Opt - An option to read -%% -%% Return : [OptionValue | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -read(DB, Gstkid, Opt) -> - gstk_generic:read_option(DB, Gstkid, Opt). - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : delete/2 -%% Purpose : Delete widget from databas and return tkwidget to destroy -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% -%% Return : TkWidget to destroy -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -delete(DB, Gstkid) -> - gstk_db:delete_widget(DB, Gstkid), - {_, Gid} = Gstkid#gstkid.widget_data, - gstk_db:delete_bgrp(DB, Gid), - Gstkid#gstkid.widget. - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : event/5 -%% Purpose : Construct the event and send it to the owner of the widget -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% Etype - The event type -%% Edata - The event data -%% Args - The data from tcl/tk -%% -%% Return : true -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -event(DB, Gstkid, Etype, Edata, Args) -> - Arg2 = case Etype of - click -> - [Text, Bool | Rest] = Args, - RBool = case Bool of - 1 -> true; - _Other2 -> false - end, - {G, _Gid} = Gstkid#gstkid.widget_data, - [Text, G, RBool | Rest]; - _Other3 -> - Args - end, - gstk_generic:event(DB, Gstkid, Etype, Edata, Arg2). - - - -%%------------------------------------------------------------------------------ -%% MANDATORY FUNCTIONS -%%------------------------------------------------------------------------------ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : option/4 -%% Purpose : Take care of options -%% Args : Option - An option tuple -%% Gstkid - The gstkid of the widget -%% TkW - The tk-widget -%% DB - The Database -%% -%% Return : A tuple {OptionType, OptionCmd} -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -option(Option, Gstkid, TkW, DB,_) -> - case Option of - {disabledfg, Color} -> {s, [" -disabledforegr ", gstk:to_color(Color)]}; - {group, Group} -> {s, [" -var ", gstk:to_ascii(Group)]}; - {selectbg, Color} -> {s, [" -selectc ", gstk:to_color(Color)]}; - {underline, Int} -> {s, [" -un ", gstk:to_ascii(Int)]}; - {wraplength, Int} -> {s, [" -wr ", gstk:to_ascii(Int)]}; - - flash -> {c, [TkW, " f;"]}; - invoke -> {c, [TkW, " i;"]}; - toggle -> {c, [TkW, " to;"]}; - {select, true} -> {c, [TkW, " se;"]}; - {select, false} -> {c, [TkW, " de;"]}; - {click, On} -> cbind(DB, Gstkid, click, On); - _ -> invalid_option - end. - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : read_option/3 -%% Purpose : Take care of a read option -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% Option - An option -%% -%% Return : The value of the option or invalid_option -%% [OptionValue | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -read_option(Option,Gstkid, TkW,DB,_) -> - case Option of - disabledfg -> tcl2erl:ret_color([TkW," cg -disabledforegr"]); - group -> {G, _} = Gstkid#gstkid.widget_data, G; - selectbg -> tcl2erl:ret_color([TkW," cg -selectc"]); - groupid -> {_, Gid} = Gstkid#gstkid.widget_data, Gid; - underline -> tcl2erl:ret_int([TkW," cg -un"]); - wraplength -> tcl2erl:ret_int([TkW," cg -wr"]); - select -> tcl2erl:ret_bool(["set x [", TkW, - " cg -va];global $x;set $x"]); - - click -> gstk_db:is_inserted(DB, Gstkid, click); - _ -> {bad_result, {Gstkid#gstkid.objtype, invalid_option, Option}} - end. - -%%------------------------------------------------------------------------------ -%% PRIMITIVES -%%------------------------------------------------------------------------------ -%% check button version -%% create version -fix_group(Opts, DB, Owner) -> - {G, GID, NOpts} = fg(Opts, erlNIL, erlNIL, []), - NG = case G of - erlNIL -> - Vref = gstk_db:counter(DB, variable), - list_to_atom(lists:flatten(["cb", gstk:to_ascii(Vref)])); - Other1 -> Other1 - end, - RGID = case GID of - erlNIL -> {cbgrp, NG, Owner}; - Other2 -> Other2 - end, - RG = gstk_db:insert_bgrp(DB, RGID), - {NG, RGID, [{group, RG} | NOpts]}. - -%% config version -fix_group(Opts, DB, Owner, Gstkid) -> - {RG, RGID} = Gstkid#gstkid.widget_data, - {G, GID, NOpts} = fg(Opts, RG, RGID, []), - case {G, GID} of - {RG, RGID} -> - {NOpts, Gstkid}; - {NG, RGID} -> - NGID = {cbgrp, NG, Owner}, - gstk_db:delete_bgrp(DB, RGID), - NRG = gstk_db:insert_bgrp(DB, NGID), - NGstkid = Gstkid#gstkid{widget_data={NG,NGID}}, - gstk_db:insert_widget(DB, NGstkid), - {[{group, NRG} | NOpts], NGstkid}; - {_, NGID} when NGID =/= RGID -> - gstk_db:delete_bgrp(DB, RGID), - NRG = gstk_db:insert_bgrp(DB, NGID), - NGstkid = Gstkid#gstkid{widget_data={RG,NGID}}, - gstk_db:insert_widget(DB, NGstkid), - {[{group, NRG} | NOpts], NGstkid} - end. - - - -fg([{group, G} | Opts], _, GID, Nopts) -> - fg(Opts, G, GID, Nopts); - -fg([{groupid, GID} | Opts], G, _, Nopts) -> - fg(Opts, G, GID, Nopts); - -fg([Opt | Opts], G, GID, Nopts) -> - fg(Opts, G, GID, [Opt | Nopts]); - -fg([], Group, GID, Opts) -> - {Group, GID, Opts}. - - -%% -%% Config bind -%% -cbind(DB, Gstkid, Etype, On) -> - TkW = Gstkid#gstkid.widget, - Cmd = case On of - {true, Edata} -> - Eref = gstk_db:insert_event(DB, Gstkid, Etype, Edata), - [" -command {erlsend ", Eref, " \\\"[", TkW, - " cg -text]\\\" \[expr \$[", TkW, " cg -va]\]}"]; - true -> - Eref = gstk_db:insert_event(DB, Gstkid, Etype, ""), - [" -command {erlsend ", Eref, " \\\"[", TkW, - " cg -text]\\\" \[expr \$[", TkW, " cg -va]\]}"]; - _Other -> - gstk_db:delete_event(DB, Gstkid, Etype), - " -command {}" - end, - {s, Cmd}. - -%% ----- Done ----- - diff --git a/lib/gs/src/gstk_db.erl b/lib/gs/src/gstk_db.erl deleted file mode 100644 index d9379cb3c8..0000000000 --- a/lib/gs/src/gstk_db.erl +++ /dev/null @@ -1,413 +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% -%% - -%% -%% ------------------------------------------------------------ -%% -%% Database interface for `gstk'. -%% -%% ------------------------------------------------------------ - --module(gstk_db). - --export([init/1, - insert/3, - lookup/2, - lookup_event/3, - insert_bgrp/2, - delete_bgrp/2, - insert_gs/2, - insert_widget/2, - delete_kid/3, - insert_opts/3, - lookup_def/3, - opt_or_not/3, - lookup_gstkid/3, - lookup_ids/2, - lookup_item/3, - delete_widget/2, - delete_gstkid/2, - get_deleted/1, - delete_event/3, - insert_event/4, - update_widget/2, - is_inserted/3, - lookup_kids/2, - insert_def/3, - opt/4, - opt/3, - insert_opt/3, - default_container_opts/3, - default_opts/3, - counter/2, - lookup_gstkid/2]). - --include("gstk.hrl"). - - -%% ------------------------------------------------------------ -%% INITIALIZATION -%% ------------------------------------------------------------ - -init(_Opts) -> - put(events,ets:new(gstk_db, [public, set])), - put(kids,ets:new(gstk_db, [public, bag])), - put(defaults,ets:new(gstk_db, [public, bag])), - put(deleted,ets:new(gstk_db, [public, bag])), - put(options,ets:new(gstk_db, [public, set])), - ets:new(gstk_db, [public, set]). - -%% ----------------------------------------------------------------- -%% PRIMITIVE DB INTERFACE -%% ----------------------------------------------------------------- - -insert(DB, Key, Value) -> - ets:insert(DB, {Key, Value}). - - -lookup(DB, Key) -> - Result = - case ets:lookup(DB, Key) of - [{Key, Value}] -> Value; - _ -> undefined - end, - Result. - - -delete(DB, Key) -> - ets:delete(DB, Key). - - - -%% ----------------------------------------------------------------- -%% NOT SO PRIMITIVE DB INTERFACE -%% ----------------------------------------------------------------- - -%% ----------------------------------------------------------------- -%% HANDLE EVENTS -%% ----------------------------------------------------------------- -insert_event(DB, Gstkid, Etype, Edata) -> - ID = Gstkid#gstkid.id, - Rdata = - case Edata of - [] -> opt(DB,ID,data); - _Other1 -> Edata - end, - Events = lookup_events(DB, ID), - case lists:keysearch(Etype, 2, Events) of - {value, {Etag, _, _}} -> - NewEvents = - lists:keyreplace(Etype, 2, Events, {Etag, Etype, Rdata}), - ets:insert(get(events), {{events, ID}, NewEvents}), - [$#, gstk:to_ascii(ID), " ", Etag]; - _Other2 -> - Etag = etag(Etype), - NewEvents = [{Etag, Etype, Rdata} | Events], - ets:insert(get(events), {{events, ID}, NewEvents}), - [$#, gstk:to_ascii(ID), " ", Etag] - end. - -etag(Etype) -> - case Etype of - click -> "c"; - doubleclick -> "dc"; - configure -> "co"; - enter -> "e"; - leave -> "l"; - motion -> "m"; - buttonpress -> "bp"; - buttonrelease -> "br"; - focus -> "f"; - destroy -> "d"; - keypress -> "kp"; - keyrelease -> "kr" - end. - -lookup_events(_DB, ID) -> - case lookup(get(events), {events, ID}) of - undefined -> []; - Events -> Events - end. - -lookup_event(DB, ID, Etag) -> - case lists:keysearch(Etag, 1, lookup_events(DB, ID)) of - {value, {Etag, Etype, Edata}} -> - {Etype, Edata}; - _Other -> - nonexisting_event - end. - -delete_event(DB, Gstkid, Etype) -> - ID = Gstkid#gstkid.id, - NewEvents = lists:keydelete(Etype, 2, lookup_events(DB, ID)), - ets:insert(get(events), {{events, ID}, NewEvents}). - -%% ----------------------------------------------------------------- -%% HANDLE BUTTON GROUPS -%% ----------------------------------------------------------------- -insert_bgrp(DB, Key) -> - case ets:lookup(DB, Key) of - [] -> - {_Bgrp, RG, _Owner} = Key, - insert(DB, Key, {0, RG}), - RG; - [{_, {Counter, RG}}] -> - insert(DB, Key, {Counter+1, RG}), - RG - end. - - -delete_bgrp(DB, Key) -> - case ets:lookup(DB, Key) of - [] -> - true; - [{_, {0, _RG}}] -> - delete(DB, Key), - true; - [{_, {Counter, RG}}] -> - insert(DB, Key, {Counter-1, RG}), - true - end. - - -%% ----------------------------------------------------------------- -%% insert things - -update_widget(DB, Gstkid) -> - ID = Gstkid#gstkid.id, - insert(DB, ID, Gstkid), - Gstkid. - -insert_gs(DB,Gstkid) -> - update_widget(DB,Gstkid). - -insert_widget(DB, Gstkid) -> - ID = Gstkid#gstkid.id, - insert_kid(DB, Gstkid#gstkid.parent, ID), - insert(DB, ID, Gstkid), - Gstkid. - -insert_kid(_DB, Parent, Kid) -> - ets:insert(get(kids), {{kids, Parent},Kid}). - -delete_kid(_DB, Parent, Kid) -> - ets:match_delete(get(kids), {{kids, Parent},Kid}). - -lookup_kids(_DB, Parent) -> - ril(ets:match(get(kids), {{kids, Parent},'$1'})). - -%%---------------------------------------------------------------------- -%% Options are stored as {{Id,Opt},Val} -%%---------------------------------------------------------------------- -insert_opt(_DB,Id,{default,ObjType,Opt}) -> - insert_def(Id,ObjType,Opt); -insert_opt(_DB,#gstkid{id=Id},{Key,Val}) -> - ets:insert(get(options),{{Id,Key},Val}); -insert_opt(_DB,Id,{Key,Val}) -> - ets:insert(get(options),{{Id,Key},Val}). - -insert_opts(_DB,_Id,[]) -> done; -insert_opts(DB,Id,[Opt|Opts]) -> - insert_opt(DB,Id,Opt), - insert_opts(DB,Id,Opts). - -insert_def(#gstkid{id=ID},ObjType,{Key,Val}) -> - insert_def(ID,ObjType,{Key,Val}); -insert_def(ID,ObjType,{Key,Val}) -> - Def = get(defaults), - ets:match_delete(Def,{{ID,ObjType},{Key,'_'}}), - ets:insert(Def,{{ID,ObjType},{Key,Val}}). - -lookup_def(ID,ObjType,Key) -> - case ets:match(get(defaults),{{ID,ObjType},{Key,'$1'}}) of - [] -> false; - [[Val]] -> {value,Val} - end. - -opt(DB,#gstkid{id=Id},Opt) -> opt(DB,Id,Opt); -opt(_DB,Id,Opt) -> - [{_, Value}] = ets:lookup(get(options), {Id,Opt}), - Value. - -opt_or_not(DB,#gstkid{id=Id},Opt) -> opt_or_not(DB,Id,Opt); -opt_or_not(_DB,Id,Opt) -> - case ets:lookup(get(options), {Id,Opt}) of - [{_, Value}] -> {value, Value}; - _ -> false - end. - -opt(DB,#gstkid{id=Id},Opt,ElseVal) -> opt(DB,Id,Opt,ElseVal); -opt(_DB,Id,Opt,ElseVal) -> - case ets:lookup(get(options), {Id,Opt}) of - [{_, Value}] -> - Value; - _ -> ElseVal - end. - -%%---------------------------------------------------------------------- -%% Returns: list of {Key,Val} -%%---------------------------------------------------------------------- -default_container_opts(_DB,Id,ChildType) -> - L = ets:match(get(defaults),{{Id,'$1'},'$2'}), - lists:sort(fix_def_for_container(L,ChildType)). - -default_opts(_DB,Id,ChildType) -> - L1 = ets:lookup(get(defaults),{Id,ChildType}), - L2 = ets:lookup(get(defaults),{Id,all}), - lists:sort(fix_def(L1,L2)). - -fix_def([{_,Opt}|Opts],Opts2) -> - [Opt|fix_def(Opts,Opts2)]; -fix_def([],[]) -> []; -fix_def([],Opts) -> - fix_def(Opts,[]). - -%%---------------------------------------------------------------------- -%% Purpose: Extracs {default,ObjType,DefsultOpt} for the ChildType -%% and keeps default options since it is a container object. -%% Returns: list of options -%%---------------------------------------------------------------------- -fix_def_for_container([[all,{Key,Val}]|Opts],ChildType) -> - [{{default,all,Key},Val},{Key,Val} - |fix_def_for_container(Opts,ChildType)]; -fix_def_for_container([[ChildType,{Key,Val}]|Opts],ChildType) -> - [{{default,ChildType,Key},Val},{Key,Val} - |fix_def_for_container(Opts,ChildType)]; -fix_def_for_container([[ChildType2,{Key,Val}]|Opts],_ChildType) -> - [{{default,ChildType2,Key},Val}|fix_def_for_container(Opts,ChildType2)]; -fix_def_for_container([],_) -> []. - -%% ----------------------------------------------------------------- -%% lookup things - -lookup_gstkid(DB, Name, Owner) when is_atom(Name) -> - ID = lookup(DB, {Owner, Name}), - lookup(DB, ID); - -lookup_gstkid(DB, ID, _Owner) -> - lookup(DB, ID). - - -lookup_gstkid(_DB, Name) when is_atom(Name) -> - exit({'must use owner',Name}); - -lookup_gstkid(DB, ID) -> - lookup(DB, ID). - - -lookup_ids(DB, Pid) -> - ril(ets:match(DB, {'$1', {gstkid,'_','_','_',Pid,'_','_'}})). - -lookup_item(DB, TkW, Item) -> - % [[Id]] = ets:match(DB, {'$1', {gstkid,'_',TkW, Item,'_','_','_'}}), - % Id. - %% OTP-4167 Gif images gstkids are stored differently from other objects - case ets:match(DB, {'$1', {gstkid,'_',TkW, Item,'_','_','_'}}) of - [[Id]] -> - Id; - [] -> - Pattern = {'$1', {gstkid,'_',TkW, {'_',Item},'_','_',image}}, - [[Id]] = ets:match(DB, Pattern), - Id - end. - - -%% ----------------------------------------------------------------- -%% counters - -counter(DB, Key) -> - Result = - case ets:lookup(DB, Key) of - [{Key, Value}] -> Value+1; - _ -> 0 - end, - ets:insert(DB, {Key, Result}), - Result. - - -%% ----------------------------------------------------------------- -%% delete things - -delete_widgets(DB, [ID | Rest]) -> - delete_widget(DB, ID), - delete_widgets(DB, Rest); -delete_widgets(_, []) -> - true. - - -delete_widget(DB, #gstkid{id = ID}) -> - delete_widget(DB, ID); -delete_widget(DB, ID) -> - delete_widgets(DB, lookup_kids(DB, ID)), - delete_id(DB, ID). - -delete_gstkid(DB,Gstkid) -> - delete_id(DB,Gstkid). - -delete_id(DB, ID) -> - case lookup_gstkid(DB, ID) of - undefined -> - true; - _Gstkid -> - gstk:worker_do({match_delete,[{get(options),[{{ID,'_'},'_'}]}, - {get(defaults),[{{ID,'_'},'_'}]}]}), - ets:insert(get(deleted),{deleted,ID}), - delete(DB, ID) - end, - ets:delete(get(kids), {kids, ID}), - delete(get(events), {events, ID}), - true. - -get_deleted(_DB) -> - Dd = get(deleted), - R=fix_deleted(ets:lookup(Dd,deleted)), - ets:delete(Dd,deleted), - R. - -fix_deleted([{_,Id}|Dd]) -> - [Id | fix_deleted(Dd)]; -fix_deleted([]) -> []. - -%% ----------------------------------------------------------------- -%% odd stuff - -%% check if an event is in the database, used by read_option -is_inserted(DB, #gstkid{id = ID}, What) -> - is_inserted(DB, ID, What); -is_inserted(_DB, ID, What) -> - case lookup(get(events), {events, ID}) of - undefined -> false; - Events -> - case lists:keysearch(What, 2, Events) of - {value, _} -> true; - _Other -> false - end - end. - -%% ----------------------------------------------------------------- -%% PRIMITIVES -%% ----------------------------------------------------------------- - -%% remove irritating lists -ril([[Foo] | Rest]) -> [Foo | ril(Rest)]; -ril([]) -> []. - - - diff --git a/lib/gs/src/gstk_editor.erl b/lib/gs/src/gstk_editor.erl deleted file mode 100644 index 6376efc851..0000000000 --- a/lib/gs/src/gstk_editor.erl +++ /dev/null @@ -1,400 +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% -%% - -%% -%% ------------------------------------------------------------ -%% Basic Editor Type -%% ------------------------------------------------------------ - --module(gstk_editor). --compile([{nowarn_deprecated_function,{gs,assq,2}}, - {nowarn_deprecated_function,{gs,error,2}}, - {nowarn_deprecated_function,{gs,val,2}}]). - -%%------------------------------------------------------------------------------ -%% CANVAS OPTIONS -%% -%% Attributes: -%% activebg Color -%% anchor n,w,s,e,nw,se,ne,sw,center -%% bc Color -%% bg Color -%% bw Wth -%% data Data -%% fg Color -%% font Font -%% height Int -%% highlightbg Color -%% highlightbw Wth -%% highlightfg Color -%% hscroll Bool | top | bottom -%% insertbg Color -%% insertbw Wth -%% insertpos {Row,Col}|'end' (Row: 1..Max, Col: 0..Max) -%% justify left|right|center -%% padx Int (Pixels) -%% pady Int (Pixels) -%% relief Relief -%% scrollbg Color -%% scrollfg Color -%% selectbg Color -%% selectbw Width -%% selectfg Color -%% vscroll Bool | left | right -%% width Int -%% wrap none | char | word -%% x Int -%% y Int -%% -%% -%% Commands: -%% clear -%% del {FromIdx, ToIdx} -%% enable Bool -%% file String -%% get {FromIdx, ToIdx} => Text -%% insert {Index, Text}Index = [insert,{Row,lineend},end,{Row,Col}] -%% setfocus Bool -%% -%% Events: -%% buttonpress [Bool | {Bool, Data}] -%% buttonrelease [Bool | {Bool, Data}] -%% destroy [Bool | {Bool, Data}] -%% enter [Bool | {Bool, Data}] -%% focus [Bool | {Bool, Data}] -%% keypress [Bool | {Bool, Data}] -%% keyrelease [Bool | {Bool, Data}] -%% leave [Bool | {Bool, Data}] -%% motion [Bool | {Bool, Data}] -%% -%% Read Options: -%% children -%% id -%% parent -%% type -%% - -%.t tag names 2.7 -> red blue (blue is the colour) -%.t tag add blue 2.1 2.10 tag the text -%.t tag configure blue -foregr blue create tag -% .t index end -> MaxRows.cols -% .t yview moveto (Row-1)/MaxRows - --export([create/3, config/3, read/3, delete/2,event/5,option/5,read_option/5]). - --include("gstk.hrl"). - -%%----------------------------------------------------------------------------- -%% MANDATORY INTERFACE FUNCTIONS -%%----------------------------------------------------------------------------- -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : create/3 -%% Purpose : Create a widget of the type defined in this module. -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -create(DB, Gstkid, Opts) -> - MainW = gstk_generic:mk_tkw_child(DB,Gstkid), - Editor = lists:append(MainW,".z"), - {Vscroll, Hscroll, NewOpts} = gstk_generic:parse_scrolls(Opts), - WidgetD = #so{main=MainW, object=Editor, - hscroll=Hscroll, vscroll=Vscroll,misc=[{1,white}]}, - NGstkid=Gstkid#gstkid{widget=MainW, widget_data=WidgetD}, - gstk_db:insert_widget(DB,NGstkid), - MandatoryCmd = ["so_create text ", MainW], - case gstk:call(MandatoryCmd) of - {result, _} -> - SimplePreCmd = [MainW, " conf"], - PlacePreCmd = [";place ", MainW], - case gstk_generic:make_command(NewOpts, NGstkid, MainW, SimplePreCmd, - PlacePreCmd, DB,Editor) of - {error,Reason} -> {error,Reason}; - Cmd -> - gstk:exec(Cmd), - gstk:exec( - [Editor," conf -bo 2 -relief sunken -highlightth 2;", - MainW,".sy conf -rel sunken -bo 2;", - MainW,".pad.sx conf -rel sunken -bo 2;", - Editor, " tag co c1 -for white;"]), - ok - end - end. - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : config/3 -%% Purpose : Configure a widget of the type defined in this module. -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% Opts - A list of options for configuring the widget -%% -%% Return : [true | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -config(DB, Gstkid, Options) -> - SO = Gstkid#gstkid.widget_data, - MainW = Gstkid#gstkid.widget, - Editor = SO#so.object, - NewOpts = - case {gs:assq(vscroll,Options),gs:assq(hscroll,Options)} of - {false,false} -> Options; - _ -> gstk_generic:parse_scrolls(Gstkid, Options) - end, - SimplePreCmd = [MainW, " conf"], - PlacePreCmd = [";place ", MainW], - gstk_generic:mk_cmd_and_exec(NewOpts, Gstkid, MainW, SimplePreCmd, - PlacePreCmd, DB, Editor). - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : read/3 -%% Purpose : Read one option from a widget -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% Opt - An option to read -%% -%% Return : [OptionValue | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -read(DB, Gstkid, Opt) -> - SO = Gstkid#gstkid.widget_data, - gstk_generic:read_option(DB, Gstkid, Opt,SO#so.object). - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : delete/2 -%% Purpose : Delete widget from databas and return tkwidget to destroy -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% -%% Return : TkWidget to destroy -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -delete(DB, Gstkid) -> - gstk_db:delete_widget(DB, Gstkid), - Gstkid#gstkid.widget. - -event(DB, Gstkid, Etype, Edata, Args) -> - gstk_generic:event(DB, Gstkid, Etype, Edata, Args). - - -%%----------------------------------------------------------------------------- -%% MANDATORY FUNCTIONS -%%----------------------------------------------------------------------------- -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : option/5 -%% Purpose : Take care of options -%% Args : Option - An option tuple -%% Gstkid - The gstkid of the widget -%% MainW - The main tk-widget -%% Editor - The Editor tk-widget -%% DB - The Database -%% -%% Return : A tuple {OptionType, OptionCmd} -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -option(Option, Gstkid, _MainW, DB, Editor) -> - case Option of - {font,Font} when is_tuple(Font) -> - gstk_db:insert_opt(DB,Gstkid,Option), - {c, [Editor, " conf -font ", gstk_font:choose_ascii(DB,Font)]}; - {font_style, {{Start,End},Font}} -> % should be only style - {Tag,Ngstkid} = get_style_tag(DB,Editor,Font,Gstkid), - gstk_db:update_widget(DB,Ngstkid), - {c, Ngstkid, [Editor, " tag ad ", Tag, " ", p_index(Start), " ", - p_index(End)]}; - {fg, {{Start,End},Color}} -> - {Tag,Ngstkid} = get_color_tag(Editor,Color,Gstkid), - gstk_db:update_widget(DB,Ngstkid), - {c, Ngstkid, [Editor, " tag ad ", Tag, " ", p_index(Start), " ", - p_index(End)]}; - {padx, Pad} -> {c, [Editor," conf -padx ",gstk:to_ascii(Pad)]}; - {pady, Pad} -> {c, [Editor," conf -pady ",gstk:to_ascii(Pad)]}; - {selection, {From, To}} -> - {c, [Editor," tag ad sel ",p_index(From)," ", p_index(To)]}; - {vscrollpos, Row} -> - {MaxRow,_Col} = ret_ed_index([Editor," ind end"]), - {c, [Editor, " yv mo ",gstk:to_ascii(Row/MaxRow)]}; - {wrap, How} -> - {c, [Editor, " conf -wrap ", gstk:to_ascii(How)]}; - {fg, Color} -> - {c, [Editor, " conf -fg ", gstk:to_color(Color)]}; - {insertbw, Wth} -> - {c, [Editor, " conf -insertbo ", gstk:to_ascii(Wth)]}; - {insertbg, Color} -> - {c, [Editor, " conf -insertba ", gstk:to_color(Color)]}; - {insertpos, Index} -> - {c, [Editor, " m s insert ", p_index(Index)]}; - {insert, {Index, Text}} -> - {c, [Editor, " ins ", p_index(Index), " ", gstk:to_ascii(Text)]}; - {del, {From, To}} -> - {c, [Editor, " del ", p_index(From), " ", p_index(To)]}; - {overwrite, {Index, Text}} -> - AI = p_index(Index), - Len = gstk:to_ascii(lists:flatlength(Text)), - {c, [Editor, " del ",AI," \"",AI,"+",Len,"c\";", - Editor, " ins ",AI," ", gstk:to_ascii(Text)]}; - clear -> {c, [Editor, " delete 1.0 end"]}; - {load, File} -> - F2 = re:replace(File, [92,92], "/", [global,{return,list}]), - case gstk:call(["ed_load ", Editor, " ", gstk:to_ascii(F2)]) of - {result, _} -> none; - {bad_result,Re} -> - {error,{no_such_file,editor,load,F2,Re}} - end; - {save, File} -> - F2 = re:replace(File, [92,92], "/", [global,{return,list}]), - case gstk:call(["ed_save ",Editor," ",gstk:to_ascii(F2)]) of - {result, _} -> none; - {bad_result,Re} -> - {error,{no_such_file,editor,save,F2,Re}} - end; - {enable, true} -> {c, [Editor, " conf -state normal"]}; - {enable, false} -> {c, [Editor, " conf -state disabled"]}; - - {setfocus, true} -> {c, ["focus ", Editor]}; - {setfocus, false} -> {c, ["focus ."]}; - _ -> invalid_option - end. - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : read_option/5 -%% Purpose : Take care of a read option -%% Return : The value of the option or invalid_option -%% [OptionValue | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -read_option(Option,GstkId,_MainW,DB,Editor) -> - case Option of - font -> gstk_db:opt(DB,GstkId,font,undefined); - padx -> tcl2erl:ret_atom([Editor," cg -padx"]); - pady -> tcl2erl:ret_atom([Editor," cg -pady"]); - enable -> tcl2erl:ret_enable([Editor," cg -st"]); - fg -> tcl2erl:ret_color([Editor," cg -fg"]); - {fg, Pos} -> - L=tcl2erl:ret_list([Editor," tag nam ", p_index(Pos)]), - SO = GstkId#gstkid.widget_data, - case last_tag_val(undefined, $c, L, SO#so.misc) of - undefined -> tcl2erl:ret_color([Editor," cg -fg"]); - Color -> Color - end; - {font_style, Pos} -> - L=tcl2erl:ret_list([Editor," tag nam ", p_index(Pos)]), - SO = GstkId#gstkid.widget_data, - case last_tag_val(undefined, $f, L, SO#so.misc) of - undefined -> 'my style? nyi'; - Style -> Style - end; - selection -> ret_ed_indexes([Editor," tag ne sel 1.0"]); - char_height -> tcl2erl:ret_int([Editor, " cg -he"]); - char_width -> tcl2erl:ret_int([Editor, " cg -wi"]); - insertbg -> tcl2erl:ret_color([Editor," cg -insertba"]); - insertbw -> tcl2erl:ret_int([Editor," cg -insertbo"]); - insertpos -> ret_ed_index([Editor, " ind insert"]); - setfocus -> tcl2erl:ret_focus(Editor, "focus"); - wrap -> tcl2erl:ret_atom([Editor," cg -wrap"]); - size -> {MaxRow,_Col} = ret_ed_index([Editor," ind end"]), - MaxRow-1; - vscrollpos -> - {MaxRow,_Col} = ret_ed_index([Editor," ind end"]), - [Top,_Bot] = tcl2erl:ret_list([Editor," yvi"]), - round(Top*(MaxRow-1))+1; - {get, {From, To}} -> - tcl2erl:ret_str([Editor, " get ", p_index(From), " ", p_index(To)]); - _ -> {bad_result, {GstkId#gstkid.objtype, invalid_option, Option}} - end. - - -%%------------------------------------------------------------------------------ -%% PRIMITIVES -%%------------------------------------------------------------------------------ - -p_index({Line, lineend}) -> [$",gstk:to_ascii(Line), ".1 lineend",$"]; -p_index({Line, Char}) -> [gstk:to_ascii(Line), $., gstk:to_ascii(Char)]; -p_index(insert) -> "insert"; -p_index('end') -> "end"; -p_index(Idx) -> gs:error("bad index in editor: ~w~n",[Idx]),0. - -ret_ed_index(Cmd) -> - case gstk:call(Cmd) of - {result, Val} -> - case io_lib:fread("~d.~d", Val) of - {ok, [Row,Col], []} -> {Row, Col}; - Other -> {bad_result, Other} - end; - Bad_result -> Bad_result - end. - -ret_ed_indexes(Cmd) -> - case gstk:call(Cmd) of - {result, ""} -> undefined; - {result, Val} -> - case io_lib:fread("~d.~d ~d.~d", Val) of - {ok, [Row1,Col1,Row2,Col2], []} -> {{Row1, Col1}, {Row2,Col2}}; - Other -> {bad_result, Other} - end; - Bad_result -> Bad_result - end. - - -%%---------------------------------------------------------------------- -%% Returns: {Tag text(), NewGstkId} -%%---------------------------------------------------------------------- -%% The misc field of the so record is a list of {ColorNo, Color|Font|...} -get_color_tag(Editor,Color,Gstkid) -> - SO = Gstkid#gstkid.widget_data, - Tags = SO#so.misc, - case lists:keysearch(Color, 2, Tags) of -% {value, {No, _}} -> {["c",gstk:to_ascii(No)], Gstkid}; -% false -> % don't reuse tags, priority order spoils that - _Any -> - {No,_} = lists:max(Tags), - N=No+1, - SO2 = SO#so{misc=[{N,Color}|Tags]}, - TagStr=["c",gstk:to_ascii(N)], - gstk:exec([Editor," tag co ",TagStr," -for ", gstk:to_color(Color)]), - {TagStr,Gstkid#gstkid{widget_data=SO2}} - end. - -get_style_tag(DB,Editor,Style,Gstkid) -> - SO = Gstkid#gstkid.widget_data, - Tags = SO#so.misc, - case lists:keysearch(Style, 2, Tags) of -% {value, {No, _}} -> {["f",gstk:to_ascii(No)], Gstkid}; -% false -> % don't reuse tags, priority order spoils that - _Any -> - {No,_} = lists:max(Tags), - N=No+1, - SO2 = SO#so{misc=[{N,Style}|Tags]}, - TagStr=["f",gstk:to_ascii(N)], - gstk:exec([Editor," tag co ",TagStr," -font ", - gstk_font:choose_ascii(DB,Style)]), % should be style only - {TagStr,Gstkid#gstkid{widget_data=SO2}} - end. - -%%---------------------------------------------------------------------- -%% Purpose: Given a list of tags for a char, return its visible color -%% (that is that last color tag in the list). -%%---------------------------------------------------------------------- -last_tag_val(TagVal, _Chr, [], _TagDict) -> TagVal; -last_tag_val(TagVal, Chr, [Tag|Ts],TagDict) -> - case atom_to_list(Tag) of - [Chr|ANo] -> - No = list_to_integer(ANo), - last_tag_val(gs:val(No, TagDict),Chr,Ts,TagDict); - _NoAcolor -> - last_tag_val(TagVal,Chr, Ts,TagDict) - end. - -%%% ----- Done ----- diff --git a/lib/gs/src/gstk_entry.erl b/lib/gs/src/gstk_entry.erl deleted file mode 100644 index a83bf2f896..0000000000 --- a/lib/gs/src/gstk_entry.erl +++ /dev/null @@ -1,234 +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% -%% - -%% -%% ------------------------------------------------------------ -%% Basic Entry Type -%% ------------------------------------------------------------ - --module(gstk_entry). --compile([{nowarn_deprecated_function,{gs,error,2}}]). - -%%------------------------------------------------------------------------------ -%% ENTRY OPTIONS -%% -%% Attributes: -%% anchor n,w,s,e,nw,se,ne,sw,center -%% bg Color -%% bw Int -%% data Data -%% fg Color -%% font Font -%% height Int -%% highlightbg Color -%% highlightbw Int (Pixels) -%% highlightfg Color -%% insertbg Color -%% insertbw Int (0 or 1 Pixels ???) -%% justify left|right|center -%% relief Relief [flat|raised|sunken|ridge|groove] -%% selectbg Color -%% selectbw Int (Pixels) -%% selectfg Color -%% text String -%% width Int -%% x Int -%% xselection Bool -%% y Int -%% -%% Commands: -%% delete Index | {From, To} -%% enable Bool -%% insert {index,String} -%% select {From, To} | clear -%% setfocus Bool -%% -%% Events: -%% buttonpress [Bool | {Bool, Data}] -%% buttonrelease [Bool | {Bool, Data}] -%% configure [Bool | {Bool, Data}] -%% destroy [Bool | {Bool, Data}] -%% enter [Bool | {Bool, Data}] -%% focus [Bool | {Bool, Data}] -%% keypress [Bool | {Bool, Data}] -%% keyrelease [Bool | {Bool, Data}] -%% leave [Bool | {Bool, Data}] -%% motion [Bool | {Bool, Data}] -%% -%% Read options: -%% children -%% id -%% index Index => Int -%% parent -%% type -%% -%% -%% Not Implemented: -%% cursor ?????? -%% focus ?????? (-takefocus) -%% font ?????? -%% hscroll ?????? -%% show ?????? -%% state ?????? -%% - --export([create/3,config/3,read/3,delete/2,event/5,option/5,read_option/5]). - --include("gstk.hrl"). - -%%----------------------------------------------------------------------------- -%% MANDATORY INTERFACE FUNCTIONS -%%----------------------------------------------------------------------------- -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : create/7 -%% Purpose : Create a widget of the type defined in this module. -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -create(DB, GstkId, Opts) -> - TkW = gstk_generic:mk_tkw_child(DB,GstkId), - PlacePreCmd = [";place ", TkW], - Ngstkid = GstkId#gstkid{widget=TkW}, - case gstk_generic:make_command(Opts,Ngstkid,TkW,"", PlacePreCmd,DB) of - {error,Reason} -> {error,Reason}; - Cmd when is_list(Cmd) -> - case gstk:call(["entry ", TkW,Cmd]) of - {result, _} -> - gstk:exec( - [TkW," conf -bo 2 -relief sunken -highlightth 2;"]), - Ngstkid; - Bad_Result -> - {error, Bad_Result} - end - end. - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : config/3 -%% Purpose : Configure a widget of the type defined in this module. -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% Opts - A list of options for configuring the widget -%% -%% Return : [true | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -config(DB, Gstkid, Opts) -> - TkW = Gstkid#gstkid.widget, - SimplePreCmd = [TkW, " conf"], - PlacePreCmd = [";place ", TkW], - gstk_generic:mk_cmd_and_exec(Opts,Gstkid,TkW,SimplePreCmd,PlacePreCmd,DB). - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : read/3 -%% Purpose : Read one option from a widget -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% Opt - An option to read -%% -%% Return : [OptionValue | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -read(DB, Gstkid, Opt) -> - gstk_generic:read_option(DB, Gstkid, Opt). - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : delete/2 -%% Purpose : Delete widget from databas and return tkwidget to destroy -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% -%% Return : TkWidget to destroy -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -delete(DB, Gstkid) -> - gstk_db:delete_widget(DB, Gstkid), - Gstkid#gstkid.widget. - - -event(DB, Gstkid, Etype, Edata, Args) -> - gstk_generic:event(DB, Gstkid, Etype, Edata, Args). - - -%%------------------------------------------------------------------------------ -%% MANDATORY FUNCTIONS -%%------------------------------------------------------------------------------ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : option/4 -%% Purpose : Take care of options -%% Args : Option - An option tuple -%% Gstkid - The gstkid of the widget -%% TkW - The tk-widget -%% DB - The Database -%% -%% Return : A tuple {OptionType, OptionCmd} -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -option(Option, Gstkid, TkW, DB,_) -> - case Option of - {font, Font} -> - gstk_db:insert_opt(DB,Gstkid,Option), - {s, [" -font ", gstk_font:choose_ascii(DB,Font)]}; - {insertbg, Color} -> {s, [" -insertba ", gstk:to_color(Color)]}; - {insertbw, Width} -> {s, [" -insertbo ", gstk:to_ascii(Width)]}; - {justify, How} -> {s, [" -ju ", gstk:to_ascii(How)]}; - {text, Str} -> - {c, [TkW," del 0 end; ",TkW," ins 0 ", gstk:to_ascii(Str)]}; - {xselection, Bool} -> {s, [" -exportse ", gstk:to_ascii(Bool)]}; - - {delete, {From, To}} -> - {c, [TkW, " del ", p_index(From), $ , p_index(To)]}; - {delete, Index} -> {c, [TkW, " de ", p_index(Index)]}; - {insert, {Idx, Str}} -> - {c, [TkW, " ins ", gstk:to_ascii(Idx),$ , gstk:to_ascii(Str)]}; - {select, clear} -> {c, [TkW, " sel clear"]}; - {select, {From, To}} -> - {c, [TkW, " sel range ", p_index(From), $ , p_index(To)]}; - _ -> invalid_option - - end. - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : read_option/5 -%% Purpose : Take care of a read option -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% Option - An option -%% -%% Return : The value of the option or invalid_option -%% [OptionValue | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -read_option(Option,Gstkid,TkW,DB,_) -> - case Option of - insertbg -> tcl2erl:ret_color([TkW," cg -insertba"]); - insertbw -> tcl2erl:ret_int([TkW," cg -insertbo"]); - font -> gstk_db:opt(DB,Gstkid,font,undefined); - justify -> tcl2erl:ret_atom([TkW," cg -jus"]); - text -> tcl2erl:ret_str([TkW," get"]); - xselection -> tcl2erl:ret_bool([TkW," cg -exports"]); - {index, Idx} -> tcl2erl:ret_int([TkW, "cg ind ", p_index(Idx)]); - _ -> {bad_result, {Gstkid#gstkid.objtype, invalid_option, Option}} - end. - -%%------------------------------------------------------------------------------ -%% PRIMITIVES -%%------------------------------------------------------------------------------ -p_index(Index) when is_integer(Index) -> gstk:to_ascii(Index); -p_index(insert) -> "insert"; -p_index(last) -> "end"; -p_index(Idx) -> gs:error("Bad index in entry: ~w~n",[Idx]),0. - - -%%% ----- Done ----- diff --git a/lib/gs/src/gstk_font.erl b/lib/gs/src/gstk_font.erl deleted file mode 100644 index 80cc46d493..0000000000 --- a/lib/gs/src/gstk_font.erl +++ /dev/null @@ -1,255 +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% -%% - -%% -%%% Purpose : The font model - -%% ########################################################################### -%% -%% This module handle fonts. It was changed for Tcl 8.2 but it could -%% probably be simplified more. -%% -%% In Tcl 8.2 we can use named fonts. So the whe get a font request we -%% first check if it already exists and if not we name it and insert it -%% into the database. -%% -%% The font naming is also changedin Tcl 8.2. -%% -%% In Tcl 8.2 there is a way to find out the width of a string in -%% a specified font. -%% -%% ########################################################################### - --module(gstk_font). - -%-compile(export_all). - --export([init/0,choose_ascii/2,choose/2,width_height/3]). - - --ifndef(NEW_WIDTH_HEIGHT). -init() -> - %% hack. the only way to find the size of a text seems to be to put - %% it into a label in an unmappen window (DummyFontWindow) - gstk:exec("toplevel .dfw;wm withdraw .dfw;" %deiconify - "label .dfw.l -text dummyinittxt -padx 0 -pady 0 -borderwidth 0;" - "pack .dfw.l"). --else. -init() -> true. --endif. - -%%---------------------------------------------------------------------- -%% Returns: undefined if font doesn't exist -%% {WidthPixels, HeightPixels} -%%---------------------------------------------------------------------- --ifndef(NEW_WIDTH_HEIGHT). -width_height(_DB, FontSpec, Txt) -> - FontSpecStr = tk_font_spec(norm_font_spec(FontSpec)), - case gstk:call([".dfw.l co -font {", FontSpecStr,"}", - " -text ", gstk:to_ascii(Txt)]) of - {result, _} -> - Width = tcl2erl:ret_int("update idletasks;winfo w .dfw.l"), - Height = tcl2erl:ret_int("winfo h .dfw.l"), -% io:format("width_height(~p,~p) =>\n~p\n\n",[FontSpec,Txt,{Width,Height}]), - {Width,Height}; - _Bad_Result -> -% io:format("width_height(~p,~p) =>\nundefined\n\n",[FontSpec,Txt]), - undefined - end. --else. -%% This code should work but does't. Tk gives incorrect -%% values if asking to fast or something /kent -width_height(DB, FontSpec, Txt) when tuple(FontSpec) -> - NormFontSpec = norm_font_spec(FontSpec), - FontSpecStr = tk_font_spec(NormFontSpec), - {Family,_,Size} = NormFontSpec, - LineHeight = - case cached_line_height(DB, {Family,Size}) of - undefined -> - LineH = tcl2erl:ret_int( - ["font metrics {",FontSpecStr,"} -linespace"]), - cache_line_height(DB, {Family,Size}, LineH), - LineH; - LineH -> - LineH - end, - EscapedText = gstk:to_ascii(Txt), - Width = tcl2erl:ret_int( - ["font measure {",FontSpecStr,"} ",EscapedText]), - Height = LineHeight * line_count(Txt), - {Width,Height}; - -width_height(_DB, FontSpec, Txt) when list(FontSpec) -> - EscapedText = gstk:to_ascii(Txt), - Width = - tcl2erl:ret_int(["font measure {",FontSpec,"} ",EscapedText]), - LineHeight = - tcl2erl:ret_int(["font metrics {",FontSpec,"} -linespace"]), - Height = LineHeight * line_count(Txt), - {Width,Height}. - -cached_line_height(DB,FontSpec) -> - gstk_db:lookup(DB, {cached_line_height,FontSpec}). - -cache_line_height(DB,FontSpec,Size) -> - gstk_db:insert(DB, {cached_line_height,FontSpec}, Size). - -line_count(Line) -> - line_count(Line, 1). - -line_count([H | T], Count) -> - Count + line_count(H, 0) + line_count(T, 0); -line_count($\n, Count) -> Count + 1; -line_count(Char, Count) when integer(Char) -> Count; -line_count([], Count) -> Count. --endif. - -% "expr [font metrics ",FSpec," -linespace] * \ -% [regsub -all \\n ",Txt," {} ignore]" - -%%---------------------------------------------------------------------- -%% Returns: Font specification string in Tk format -%% -%% The input is {Family,Size} or {Family,Style,Size} where Family and -%% Style are atoms ?! FIXME true??? -%%---------------------------------------------------------------------- -choose_ascii(DB, Font) -> - {Fam,Styl,Siz} = choose(DB, Font), - {variable,V} =gstk_db:lookup(DB,{font,Fam,Styl,Siz}), -% io:format("choose_ascii(~p) =>\n~p\n\n",[Font,V]), - V. - -%% DB contains: {font,Fam,Style,Size} -> {replaced_by,{font,Fam,Style,Size}} or -%% {variable, TkVariableStrInclDollar} - -%% ########################################################################### -%% -%% We create a new font name on the other side and store the name in the -%% database. We reorder the options so that they have a predefined order. -%% -%% ########################################################################### - -choose(DB, FontSpec) -> - choose_font(DB, norm_font_spec(FontSpec)). - -choose_font(DB, {Fam,Styl,Siz}) -> - Fam0 = map_family(Fam), - case gstk_db:lookup(DB,{font,Fam0,Styl,Siz}) of - {variable,_OwnFontName} -> true; - undefined -> - N = gstk_db:counter(DB,font), % FIXME: Can use "font create" - % without name to get unique name - NewName=["f",gstk:to_ascii(N)], -% io:format("~s\n\n", -% [lists:flatten(["font create ",NewName," ", -% tk_font_spec({Fam0,Styl,Siz})])]), - gstk:exec(["font create ",NewName," ", - tk_font_spec({Fam0,Styl,Siz})]), - %% should us variable syntax gs(f1) instead - %% have to recompile erlcall to define this global gs var - V2 = {variable,NewName}, - gstk_db:insert(DB,{font,Fam0,Styl,Siz},V2), - true - end, -% io:format("choose(~p,~p,~p) =>\n~p\n\n",[Fam,Styl,Siz,{Fam0,Styl,Siz}]), - {Fam0,Styl,Siz}. - - -%% ----- The Font Model ----- - -%% Guaranteed system fonts to exists in Tk 8.2 are: -%% -%% Windows : system systemfixed ansi ansifixed device oemfixed -%% Unix : fixed -%% -%% Times, Courier and Helvetica always exists. Tk try to substitute -%% others with the best matchin font. - -%% We map GS font style and names to something we know Tk 8 have. -%% We know Tk have 'times', 'courier', 'helvetica' and 'fixed'. -%% -%% GS style specification is 'bold' or 'italic'. -%% GS family is a typeface of type 'times', 'courier', 'helvetica', -%% 'symbol', 'new_century_schoolbook', or 'screen' (which is a suitable -%% screen font). -%% -%% Note that 'symbol' may not be present and this is not handled. -%% -%% The X/Tk8 font handling don't work very well. The fonts are -%% scaled "tk scaling", we can display a 9 and 10 point helvetica -%% but "font actual {helvetica 9}" will return 10 points.... - -map_family(new_century_schoolbook) -> - times; -map_family(Fam) -> - Fam. - -% Normalize so can make the coding easier and compare font -% specifications stored in database with new ones. We ignore invalid -% entries in the list. - -norm_font_spec({Family,Size}) -> - {Family,[],Size}; -norm_font_spec({Family,Style,Size}) -> - {Family,norm_style(Style),Size}. - -norm_style(bold) -> - [bold]; -norm_style(italic) -> - [italic]; -norm_style([italic]) -> - [italic]; -norm_style([bold]) -> - [bold]; -norm_style([bold,italic] = Style) -> - Style; -norm_style([italic,bold]) -> - [bold,italic]; -norm_style(List) when is_list(List) -> % not well formed list, ignore garbage - case {lists:member(bold, List),lists:member(italic, List)} of - {true,true} -> - [bold,italic]; - {true,_} -> - [bold]; - {_,true} -> - [italic]; - _ -> - [] % ignore garbage - end; -norm_style(_Any) -> % ignore garbage - []. - - -% Create a tcl string from a normalized font specification -% The style list is normalized. - -tk_font_spec({Fam,Style,Size}) -> - ["-family ",gstk:to_ascii(Fam), - " -size ",gstk:to_ascii(-Size), - tk_font_spec_style(Style)]. - -tk_font_spec_style([]) -> - ""; -tk_font_spec_style([bold]) -> - " -weight bold"; -tk_font_spec_style([italic]) -> - " -slant italic"; -tk_font_spec_style([bold,italic]) -> - " -weight bold -slant italic". diff --git a/lib/gs/src/gstk_frame.erl b/lib/gs/src/gstk_frame.erl deleted file mode 100644 index 2e9d160eef..0000000000 --- a/lib/gs/src/gstk_frame.erl +++ /dev/null @@ -1,282 +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% -%% - -%% -%% ------------------------------------------------------------ -%% Basic Frame Type. -%% ------------------------------------------------------------ - --module(gstk_frame). - -%%----------------------------------------------------------------------------- -%% FRAME OPTIONS -%% -%% Attributes: -%% anchor n,w,s,e,nw,se,ne,sw,center -%% bg Color -%% bw Int -%% data Data -%% height Int -%% highlightbg Color -%% highlightbw Int -%% highlightfg Color -%% relief Relief [flat|raised|sunken|ridge|groove] -%% width Int -%% x Int -%% y Int -%% cursor arrow|busy|cross|hand|help|resize|text -%% -%% Commands: -%% setfocus Bool -%% -%% Events: -%% buttonpress [Bool | {Bool, Data}] -%% buttonrelease [Bool | {Bool, Data}] -%% configure [Bool | {Bool, Data}] -%% destroy [Bool | {Bool, Data}] -%% enter [Bool | {Bool, Data}] -%% focus [Bool | {Bool, Data}] -%% keypress [Bool | {Bool, Data}] -%% keyrelease [Bool | {Bool, Data}] -%% leave [Bool | {Bool, Data}] -%% motion [Bool | {Bool, Data}] -%% -%% Read Options: -%% children -%% id -%% parent -%% type -%% - --export([create/3,config/3,read/3,delete/2,event/5,option/5,read_option/5, - mk_create_opts_for_child/4]). - --include("gstk.hrl"). - -%%----------------------------------------------------------------------------- -%% MANDATORY INTERFACE FUNCTIONS -%%----------------------------------------------------------------------------- -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : create/3 -%% Purpose : Create a widget of the type defined in this module. -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -create(DB, GstkId, Opts) -> - TkW = gstk_generic:mk_tkw_child(DB,GstkId), - NGstkid=GstkId#gstkid{widget=TkW}, - PlacePreCmd = [";place ", TkW], - case gstk_generic:make_command(Opts, NGstkid, TkW, "", PlacePreCmd, DB) of - {error,Reason} -> {error,Reason}; - Cmd when is_list(Cmd) -> - gstk:exec(["frame ", TkW, - " -relief raised -bo 0",Cmd]), - NGstkid - end. - -mk_create_opts_for_child(DB,Cgstkid, Pgstkid, Opts) -> - gstk_generic:mk_create_opts_for_child(DB,Cgstkid,Pgstkid,Opts). - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : config/3 -%% Purpose : Configure a widget of the type defined in this module. -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% Opts - A list of options for configuring the widget -%% -%% Return : [true | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -config(DB, Gstkid, Opts) -> - TkW = Gstkid#gstkid.widget, - SimplePreCmd = [TkW, " conf"], - PlacePreCmd = [";place ", TkW], - Opts2 = atomic_width_height(false,false,Opts), - gstk_generic:mk_cmd_and_exec(Opts2,Gstkid,TkW,SimplePreCmd,PlacePreCmd,DB). - -atomic_width_height(false,false,[]) -> - []; -atomic_width_height(false,Width,[]) -> - [{width,Width}]; -atomic_width_height(Height,false,[]) -> - [{height,Height}]; -atomic_width_height(H,W,[]) -> - [{width_height,{W,H}}]; -atomic_width_height(_,W,[{height,H}|Opts]) -> - atomic_width_height(H,W,Opts); -atomic_width_height(H,_,[{width,W}|Opts]) -> - atomic_width_height(H,W,Opts); -atomic_width_height(H,W,[Opt|Opts]) -> - [Opt|atomic_width_height(H,W,Opts)]. - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : read/3 -%% Purpose : Read one option from a widget -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% Opt - An option to read -%% -%% Return : [OptionValue | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -read(DB, Gstkid, Opt) -> - gstk_generic:read_option(DB, Gstkid, Opt). - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : delete/2 -%% Purpose : Delete widget from databas and return tkwidget to destroy -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% -%% Return : TkWidget to destroy -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -delete(DB, Gstkid) -> - gstk_db:delete_widget(DB, Gstkid), - Gstkid#gstkid.widget. - -event(DB, Gstkid, Etype, Edata, Args) -> - gstk_generic:event(DB, Gstkid, Etype, Edata, Args). - - -%%----------------------------------------------------------------------------- -%% MANDATORY FUNCTIONS -%%----------------------------------------------------------------------------- -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : option/4 -%% Purpose : Take care of options -%% Args : Option - An option tuple -%% Gstkid - The gstkid of the widget -%% TkW - The tk-widget -%% DB - The Database -%% -%% Return : A tuple {OptionType, OptionCmd} -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -option(Option, Gstkid, _TkW, DB,_) -> - case Option of - {bg, Color} -> {s, [" -bg ", gstk:to_color(Color)]}; - {packer_x, _Pack} -> - gstk_db:insert_opt(DB,Gstkid,Option), - none; - {packer_y, _Pack} -> - gstk_db:insert_opt(DB,Gstkid,Option), - none; - {width, W} -> - execute_pack_cmds(DB,xpack(W,DB,Gstkid)), - {s,[" -wi ", gstk:to_ascii(W)]}; - {height, H} -> - execute_pack_cmds(DB,ypack(H,DB,Gstkid)), - {s,[" -he ", gstk:to_ascii(H)]}; - {width_height,{W,H}} -> - execute_pack_cmds(DB, merge_pack_cmds(xpack(W,DB,Gstkid), - ypack(H,DB,Gstkid))), - {s,[" -he ", gstk:to_ascii(H)," -wi ", gstk:to_ascii(W)]}; - _ -> invalid_option - end. - -xpack(W,DB,Gstkid) -> - gstk_db:insert_opt(DB,Gstkid,{width,W}), - case gstk_db:opt_or_not(DB,Gstkid,packer_x) of - {value,Pack} when is_list(Pack) -> - ColSiz = gs_packer:pack(W,Pack), - pack_children(pack_x,x,width,DB, - gstk_db:lookup_kids(DB,Gstkid#gstkid.id), - ColSiz); - _Else -> [] - end. - -ypack(H,DB,Gstkid) -> - gstk_db:insert_opt(DB,Gstkid,{height,H}), - case gstk_db:opt_or_not(DB,Gstkid,packer_y) of - {value,Pack} when is_list(Pack) -> - ColSiz = gs_packer:pack(H,Pack), - pack_children(pack_y,y,height,DB, - gstk_db:lookup_kids(DB,Gstkid#gstkid.id), - ColSiz); - _Else -> [] - end. - -merge_pack_cmds([{Id,Opts1}|Cmds1],[{Id,Opts2}|Cmds2]) -> - [{Id,Opts1++Opts2}|merge_pack_cmds(Cmds1,Cmds2)]; -merge_pack_cmds(L1,L2) -> - L1++L2. - -execute_pack_cmds(DB,[{Id,Opts}|Cmds]) -> - gstk:config_impl(DB,Id,Opts), - execute_pack_cmds(DB,Cmds); -execute_pack_cmds(_,[]) -> - ok. - -%%---------------------------------------------------------------------- -%% Returns: list of {Id,Opts} to be executed (or merged with other first) -%%---------------------------------------------------------------------- -pack_children(PackOpt,PosOpt,SizOpt,DB,Kids,Sizes) -> - Schildren = keep_packed(Kids,PackOpt,DB), - pack_children2(PackOpt,PosOpt,SizOpt,Schildren,Sizes). - -pack_children2(PackOpt,PosOpt,SizOpt,[{StartStop,Id}|Childs],Sizes) -> - [pack_child(Id,StartStop,SizOpt,PosOpt,Sizes) - | pack_children2(PackOpt,PosOpt,SizOpt,Childs,Sizes)]; -pack_children2(_,_,_,[],_) -> - []. - -pack_child(Id,{StartPos,StopPos},SizOpt,PosOpt,Sizes) -> - {Pos,Size} = find_pos(StartPos,StopPos,1,0,0,Sizes), - {Id,[{PosOpt,Pos},{SizOpt,Size}]}. - -%%---------------------------------------------------------------------- -%% Returns: {PixelPos,PixelSize} -%%---------------------------------------------------------------------- -find_pos(_StartPos,Pos,Pos,AccPixelPos,AccPixelSize,[Size|_]) -> - {AccPixelPos,Size+AccPixelSize}; -find_pos(StartPos,StopPos,Pos,AccPixelPos,0,[Size|Sizes]) - when Pos < StartPos -> - find_pos(StartPos,StopPos,Pos+1,Size+AccPixelPos,0,Sizes); -find_pos(_StartPos,StopPos,Pos,AccPixelPos,AccPixelSize,[Size|Sizes]) - when Pos < StopPos -> - find_pos(Pos,StopPos,Pos+1,AccPixelPos,Size+AccPixelSize,Sizes). - - - -keep_packed([Id|Ids],PackOpt,DB) -> - case gstk:read_impl(DB,Id,PackOpt) of - undefined -> - keep_packed(Ids,PackOpt,DB); - StartStop -> - [{StartStop,Id} | keep_packed(Ids,PackOpt,DB)] - end; -keep_packed([],_,_) -> - []. - - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : read_option/3 -%% Purpose : Take care of a read option -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% Option - An option -%% -%% Return : The value of the option or invalid_option -%% [OptionValue | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -read_option(Option,Gstkid,TkW,_DB,_) -> - case Option of - bg -> tcl2erl:ret_color([TkW," cg -bg"]); - _ -> {bad_result, {Gstkid#gstkid.objtype, invalid_option, Option}} - end. - -%% ----- Done ----- diff --git a/lib/gs/src/gstk_generic.erl b/lib/gs/src/gstk_generic.erl deleted file mode 100644 index db4e2fdff4..0000000000 --- a/lib/gs/src/gstk_generic.erl +++ /dev/null @@ -1,1089 +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_generic). --compile([{nowarn_deprecated_function,{gs,assq,2}}]). - --export([out_opts/8, - read_option/5, - mk_tkw_child/2, - merge_default_options/3, - merge_default_options/2, - opts_for_child/3, - mk_cmd_and_exec/4, - mk_cmd_and_exec/5, - mk_cmd_and_exec/6, - mk_cmd_and_exec/7, - make_command/5, - make_command/6, - make_command/7, - read_option/4, - handle_external_opt_call/9, - handle_external_read/1, - gen_anchor/9, - gen_anchor/5, - gen_height/9, - gen_height/5, - gen_width/9, - gen_width/5, - gen_x/9, - gen_x/5, - gen_y/9, - gen_y/5, - gen_raise/9, - gen_raise/5, - gen_lower/9, - gen_lower/5, - gen_enable/9, - gen_enable/5, - gen_align/9, - gen_align/5, - gen_justify/9, - gen_justify/5, - gen_padx/9, - gen_padx/5, - gen_pady/9, - gen_pady/5, - gen_font/9, - gen_font/5, - gen_label/9, - gen_label/5, - gen_activebg/9, - gen_activebg/5, - gen_activefg/9, - gen_activefg/5, - gen_default/9, - gen_relief/9, - gen_relief/5, - gen_bw/9, - gen_bw/5, - gen_font_wh/5, - gen_choose_font/5, - gen_data/9, - gen_data/5, - gen_pack_x/9, - gen_pack_x/5, - gen_pack_y/9, - gen_pack_y/5, - gen_pack_xy/9, - gen_flush/9, - gen_flush/5, - gen_keep_opt/9, - gen_children/5, - make_extern_id/2, - gen_id/5, - gen_parent/5, - gen_type/5, - gen_beep/9, - gen_setfocus/9, - gen_setfocus/5, - gen_buttonpress/9, - gen_buttonpress/5, - gen_buttonrelease/9, - gen_buttonrelease/5, - gen_configure/9, - gen_configure/5, - gen_destroy/9, - gen_destroy/5, - gen_enter/9, - gen_enter/5, - gen_focus_ev/9, - gen_focus_ev/5, - gen_keypress/9, - gen_keypress/5, - gen_keyrelease/9, - gen_keyrelease/5, - gen_leave/9, - gen_leave/5, - gen_motion/9, - gen_motion/5, - gen_highlightbw/9, - gen_highlightbw/5, - gen_highlightbg/9, - gen_highlightbg/5, - gen_highlightfg/9, - gen_highlightfg/5, - gen_selectbw/9, - gen_selectbw/5, - gen_selectfg/9, - gen_selectfg/5, - gen_selectbg/9, - gen_selectbg/5, - gen_fg/9, - gen_fg/5, - gen_bg/9, - gen_bg/5, - gen_so_activebg/9, - gen_so_activebg/5, - gen_so_bc/9, - gen_so_bc/5, - gen_so_scrollfg/9, - gen_so_scrollfg/5, - gen_so_scrollbg/9, - gen_so_scrollbg/5, - obj/1, - gen_so_bg/9, - gen_so_bg/5, - gen_so_selectbw/9, - gen_so_selectbw/5, - gen_so_selectfg/9, - gen_so_selectfg/5, - gen_so_selectbg/9, - gen_so_selectbg/5, - gen_so_scrolls/9, - gen_so_hscroll/5, - gen_so_vscroll/5, - cursors/0, - gen_cursor/9, - gen_cursor/5, - gen_citem_coords/9, - gen_citem_coords/5, - gen_citem_fill/9, - gen_citem_fill/5, - gen_citem_lower/9, - gen_citem_raise/9, - gen_citem_move/9, - move_coords/3, - add_to_coords/3, - gen_citem_setfocus/9, - gen_citem_setfocus/5, - gen_citem_buttonpress/9, - gen_citem_buttonrelease/9, - gen_citem_enter/9, - gen_citem_keypress/9, - gen_citem_keyrelease/9, - gen_citem_leave/9, - gen_citem_motion/9, - scrolls_vh/3, - parse_scrolls/1, - parse_scrolls/2, - parse_scrolls/4, - bind/5, - bind/6, - ebind/6, - eunbind/6, - item_bind/6, - item_ebind/6, - item_eunbind/5, - event/5, - read_option/3, - make_command/4, - mk_create_opts_for_child/4]). - --include("gstk.hrl"). --include("gstk_generic.hrl"). - -%%---------------------------------------------------------------------- -%% Returns: a new unique TkWidget (string()) -%%---------------------------------------------------------------------- -mk_tkw_child(DB,#gstkid{parent=P,objtype=Ot}) -> - Pgstkid = gstk_db:lookup_gstkid(DB, P), - PW = Pgstkid#gstkid.widget, - Oref = gstk_db:counter(DB, Ot), - PF = gstk_widgets:suffix(Ot), - _TkW = lists:concat([PW, PF, Oref]). - -%%---------------------------------------------------------------------- -%% Purpose: Merges options. Opts have higher priority than BuiltIn -%% (and ParentOpts have higher than BuiltIn) -%% Returns: A list of new options. -%%---------------------------------------------------------------------- -merge_default_options(ParOpts, BuildInOpts, Opts) -> - %% parents options first - Tmp=merge_default_options(ParOpts, lists:sort(Opts)), - merge_default_options(BuildInOpts,Tmp). - -merge_default_options([Def|Ds],[Opt|Os]) - when element(1,Def) < element(1,Opt) -> - [Def | merge_default_options(Ds,[Opt|Os])]; - -merge_default_options([Def|Ds],[Opt|Os]) - when element(1,Def) > element(1,Opt) -> - [Opt | merge_default_options([Def|Ds],Os)]; - -merge_default_options([Def|Ds],[Opt|Os]) - when element(1,Def) == element(1,Opt) -> - [Opt | merge_default_options(Ds,Os)]; - -merge_default_options(Defs,[Opt|Os]) -> - [Opt | merge_default_options(Defs,Os)]; - -merge_default_options([],Opts) -> Opts; -merge_default_options(Defs,[]) -> Defs. - -opts_for_child(DB,Childtype,ParId) -> - case gs_widgets:container(Childtype) of - true -> - gstk_db:default_container_opts(DB,ParId,Childtype); - false -> - gstk_db:default_opts(DB,ParId,Childtype) - end. - -mk_create_opts_for_child(DB,#gstkid{objtype=ChildType}, Pgstkid, Opts) -> - merge_default_options( - opts_for_child(DB,ChildType,Pgstkid#gstkid.id), - gs_widgets:default_options(ChildType), - Opts). - -mk_cmd_and_exec(Opts,Gstkid,Scmd,DB) -> - TkW = Gstkid#gstkid.widget, - mk_cmd_and_exec(Opts,Gstkid,TkW,Scmd,[";place ", TkW],DB,dummy). -mk_cmd_and_exec(Opts,Gstkid,Scmd,Pcmd,DB) -> - mk_cmd_and_exec(Opts,Gstkid,Gstkid#gstkid.widget,Scmd,Pcmd,DB,dummy). -mk_cmd_and_exec(Options, Gstkid, TkW, SCmd, PCmd, DB) -> - mk_cmd_and_exec(Options, Gstkid, TkW, SCmd, PCmd, DB,dummy). -mk_cmd_and_exec(Options, Gstkid, TkW, SCmd, PCmd, DB,ExtraArg) -> - case gstk_generic:make_command(Options,Gstkid,TkW,SCmd,PCmd,DB,ExtraArg) of - {error,Reason} -> {error,Reason}; - Cmd when is_list(Cmd) -> - gstk:exec(Cmd) - end. - -%%---------------------------------------------------------------------- -%% SCmd: SimplePreCommand - prepended to simple (s) options -%% PCmd: PlacePreCommand - prepended to placer (p) options -%% (should start with ';' (at least if preceeded with simple cmds)) -%% Comment: If some function changes the gstkid, -%% it's responsible for storing it in the DB. -%%---------------------------------------------------------------------- -make_command(Opts,Gstkid,Scmd,DB) -> - TkW = Gstkid#gstkid.widget, - make_command(Opts,Gstkid,TkW,Scmd,[";place ", TkW],DB,dummy). -make_command(Opts,Gstkid,Scmd,Pcmd,DB) -> - make_command(Opts,Gstkid,Gstkid#gstkid.widget,Scmd,Pcmd,DB,dummy). -make_command(Options, Gstkid, TkW, SCmd, PCmd, DB) -> - make_command(Options, Gstkid, TkW, SCmd, PCmd, DB,dummy). -make_command(Options, Gstkid, TkW, SCmd, PCmd, DB,ExtraArg) -> - case out_opts(Options, Gstkid, TkW, DB, ExtraArg, [], [], []) of - {[], [], []} -> []; - {Si, [], []} -> [SCmd, Si,$;]; - {[], Pl, []} -> [PCmd, Pl,$;]; - {[], [], Co} -> [$;,Co]; - {[], Pl, Co} -> [PCmd, Pl, $;, Co]; - {Si, [], Co} -> [SCmd, Si, $;, Co]; - {Si, Pl, []} -> [SCmd, Si, PCmd, Pl, $;]; - {Si, Pl, Co} -> [SCmd, Si, PCmd, Pl, $;, Co]; - {error,Reason} -> {error,Reason} - end. - -read_option(DB,Gstkid,Opt) -> - read_option(DB,Gstkid,Gstkid#gstkid.widget,Opt,dummy). -read_option(DB,Gstkid,Opt,ExtraArg) -> - read_option(DB,Gstkid,Gstkid#gstkid.widget,Opt,ExtraArg). - -%%---------------------------------------------------------------------- -%% Args: Args is [Gstkid, TkW, DB, ExtraArg] -%% Comment: An optimization:don't reconstruct the arg list for apply each time. -%% This is the option-engine so we should optimize. -%%---------------------------------------------------------------------- -handle_external_opt_call([Opt|Options],Gstkid,TkW,DB,ExtraArg,ExtRes,S,P,C) -> - case ExtRes of - {s, Cmd} -> - out_opts(Options,Gstkid, TkW,DB, ExtraArg, [Cmd|S], P, C); - {p, Cmd} -> - out_opts(Options, Gstkid,TkW,DB, ExtraArg, S, [Cmd|P], C); - {c, Cmd} -> - out_opts(Options, Gstkid,TkW,DB, ExtraArg,S, P, [Cmd,$;|C]); - none -> - out_opts(Options, Gstkid,TkW,DB,ExtraArg, S, P, C); - % {s, NGstkid, Cmd} -> - % out_opts(Options,NGstkid,TkW,DB,ExtraArg, [Cmd|S], P, C); - % {p, NGstkid, Cmd} -> - % out_opts(Options,NGstkid,TkW,DB,ExtraArg, S, [Cmd|P], C); - {c, NGstkid, Cmd} -> - out_opts(Options,NGstkid,TkW,DB, ExtraArg,S,P,[Cmd,$;|C]); - {none, NGstkid} -> - out_opts(Options,NGstkid,TkW,DB, ExtraArg, S, P, C); - {sp,{Scmd,Pcmd}} -> - out_opts(Options,Gstkid,TkW,DB,ExtraArg,[Scmd|S],[Pcmd|P],C); - invalid_option -> - {error,{invalid_option,Gstkid#gstkid.objtype,Opt}}; - break -> % a hack. it is possible to abort generic option handling at - %% any time (without even inserting the gstkid inte to DB (for - %% performance reasons)). - {S, P, C} - end. - -handle_external_read(Res) -> - %% We have removed dead code here that attempted to translate - %% a bad return value from {bad_result,{A,B,C}} to {error,{A,B,C}}. - %% Since the gs application is deprecated, we don't want to introduce - %% a potential incompatibility; thus we have removed the dead code - %% instead of correcting it. - Res. - -%%---------------------------------------------------------------------- -%% Generic options -%%---------------------------------------------------------------------- - -gen_anchor(How,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,[" -anc ", gstk:to_ascii(How)|P],C). -gen_anchor(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> - tcl2erl:ret_place(anchor, TkW). - -gen_height(Height,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - gstk_db:insert_opt(DB,Gstkid,{height,Height}), - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S, - [" -he ", gstk:to_ascii(Height)|P],C). -gen_height(_Opt,Gstkid,_TkW,DB,_ExtraArg) -> - gstk_db:opt(DB,Gstkid,height). - -gen_width(Width,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - gstk_db:insert_opt(DB,Gstkid,{width,Width}), - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S, - [" -wi ", gstk:to_ascii(Width)|P],C). -gen_width(_Opt,Gstkid,_TkW,DB,_ExtraArg) -> - gstk_db:opt(DB,Gstkid,width). - -gen_x(X,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - gstk_db:insert_opt(DB,Gstkid,{x,X}), - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S, - [" -x ", gstk:to_ascii(X)|P],C). -gen_x(_Opt,Gstkid,_TkW,DB,_ExtraArg) -> - gstk_db:opt(DB,Gstkid,x). - -gen_y(Y,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - gstk_db:insert_opt(DB,Gstkid,{y,Y}), - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S, - [" -y ", gstk:to_ascii(Y)|P],C). -gen_y(_Opt,Gstkid,_TkW,DB,_ExtraArg) -> - gstk_db:opt(DB,Gstkid,y). - -gen_raise(_,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,["raise ", TkW,$;|C]). -gen_raise(_Opt,_Gstkid,_TkW,_DB,_ExtraArg) -> - undefined. - -gen_lower(_,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,["lower ", TkW,$;|C]). -gen_lower(_Opt,_Gstkid,_TkW,_DB,_ExtraArg) -> - undefined. - -gen_enable(true,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,[" -st normal"|S],P,C); -gen_enable(false,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,[" -st disabled"|S],P,C). -gen_enable(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> - tcl2erl:ret_enable([TkW, " cg -st"]). - -gen_align(How,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,[" -an ", gstk:to_ascii(How)|S],P,C). -gen_align(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> - tcl2erl:ret_atom([TkW, " cg -anch"]). - -gen_justify(How,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,[" -ju ", gstk:to_ascii(How)|S],P,C). -gen_justify(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> - tcl2erl:ret_atom([TkW, " cg -ju"]). - -gen_padx(Pad,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,[" -padx ", gstk:to_ascii(Pad)|S],P,C). -gen_padx(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> - tcl2erl:ret_atom([TkW, " cg -padx"]). - -gen_pady(Pad,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,[" -pady ", gstk:to_ascii(Pad)|S],P,C). -gen_pady(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> - tcl2erl:ret_atom([TkW, " cg -pady"]). - - -gen_font(Font,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - gstk_db:insert_opt(DB,Gstkid,{font,Font}), - out_opts(Opts,Gstkid,TkW,DB,ExtraArg, - [" -font ", gstk_font:choose_ascii(DB,Font)|S],P,C). -gen_font(_Opt,Gstkid,_TkW,DB,_ExtraArg) -> - gstk_db:opt(DB,Gstkid,font,undefined). - -gen_label({text,Text},Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,[" -text ", gstk:to_ascii(Text), " -bi {}"|S],P,C); -gen_label({image,Img},Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - I2 = re:replace(Img, [92,92], "/", [global,{return,list}]), - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,[" -bi \"@", I2, "\" -text {}"|S],P,C). -gen_label(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> - case gstk:call([TkW, " cg -bit"]) of - {result, [$@|Image]} -> {image,Image}; - _Nope -> - case gstk:call([TkW, " cg -text"]) of - {result, Txt} -> {text, Txt}; - Bad_Result -> Bad_Result - end - end. - -gen_activebg(Color,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,[" -activeba ", gstk:to_color(Color)|S],P,C). -gen_activebg(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> - tcl2erl:ret_color([TkW, " cg -activeba"]). - -gen_activefg(Color,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,[" -activef ", gstk:to_color(Color)|S],P,C). -gen_activefg(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> - tcl2erl:ret_color([TkW, " cg -activef"]). - - -gen_default(Opt,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - case Opt of - {all, {font, Font}} -> - C2 = ["option a *",tl(TkW), % have to remove preceeding dot - "*font ",gstk_font:choose_ascii(DB, Font)], - gstk_db:insert_def(Gstkid,grid,{font,Font}), - gstk_db:insert_def(Gstkid,text,{font,Font}), - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,[C2,$;|C]); - {buttons, {font, Font}} -> - C2 = ["option a *",tl(TkW), % have to remove preceeding dot - ".Button.font ",gstk_font:choose_ascii(DB, Font)], - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,[C2,$;|C]); - {buttons,{Key,Val}} -> - gstk_db:insert_def(Gstkid,button,{Key,Val}), - gstk_db:insert_def(Gstkid,checkbutton,{Key,Val}), - gstk_db:insert_def(Gstkid,radiobutton,{Key,Val}), - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,C); - {ObjType, {Key,Val}} -> - gstk_db:insert_def(Gstkid,ObjType,{Key,Val}), - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) - end. - - -gen_relief(Relief,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,[" -reli ",gstk:to_ascii(Relief)|S],P,C). -gen_relief(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> - tcl2erl:ret_atom([TkW, " cg -reli"]). - -gen_bw(Wth,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,[" -bd ", gstk:to_ascii(Wth)|S],P,C). -gen_bw(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> - tcl2erl:ret_int([TkW, " cg -bd"]). - - - -gen_font_wh({font_wh,{Font, Txt}},_Gstkid,_TkW,DB,_) -> - gstk_font:width_height(DB, gstk_font:choose(DB,Font), Txt). - -gen_choose_font({choose_font,Font},_Gstkid,_TkW,DB,_ExtraArg) -> - gstk_font:choose(DB,Font). - -gen_data(Data,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - gstk_db:insert_opt(DB,Gstkid,{data,Data}), - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,C). -gen_data(_Opt,Gstkid,_TkW,DB,_ExtraArg) -> - gstk_db:opt(DB,Gstkid,data). - -gen_pack_x({Start,Stop},Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - gstk_db:insert_opt(DB,Gstkid,{pack_x,{Start,Stop}}), - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,C); -gen_pack_x(Col,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) when is_integer(Col) -> - gstk_db:insert_opt(DB,Gstkid,{pack_x,{Col,Col}}), - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,C). -gen_pack_x(_Opt,Gstkid,_TkW,DB,_ExtraArg) -> - gstk_db:opt(DB,Gstkid,pack_x, undefined). - -gen_pack_y({Start,Stop},Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - gstk_db:insert_opt(DB,Gstkid,{pack_y,{Start,Stop}}), - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,C); -gen_pack_y(Row,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) when is_integer(Row) -> - gstk_db:insert_opt(DB,Gstkid,{pack_y,{Row,Row}}), - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,C). -gen_pack_y(_Opt,Gstkid,_TkW,DB,_ExtraArg) -> - gstk_db:opt(DB,Gstkid,pack_y, undefined). - -gen_pack_xy({Col,Row},Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) - when is_integer(Col), is_integer(Row) -> - gstk_db:insert_opt(DB,Gstkid,{pack_x,{Col,Col}}), - gstk_db:insert_opt(DB,Gstkid,{pack_y,{Row,Row}}), - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,C); -gen_pack_xy({Col,{StartRow,StopRow}},Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) - when is_integer(Col) -> - gstk_db:insert_opt(DB,Gstkid,{pack_x,{Col,Col}}), - gstk_db:insert_opt(DB,Gstkid,{pack_y,{StartRow,StopRow}}), - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,C); -gen_pack_xy({{StartCol,StopCol},Row},Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) - when is_integer(Row) -> - gstk_db:insert_opt(DB,Gstkid,{pack_x,{StartCol,StopCol}}), - gstk_db:insert_opt(DB,Gstkid,{pack_y,{Row,Row}}), - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,C); -gen_pack_xy({Col,Row},Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - gstk_db:insert_opt(DB,Gstkid,{pack_x,Col}), - gstk_db:insert_opt(DB,Gstkid,{pack_y,Row}), - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,C). - - -gen_flush(_Opt,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - tcl2erl:ret_int(["update idletasks;expr 1+1"]), - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,C). -gen_flush(_Opt,_Gstkid,_TkW,_DB,_ExtraArg) -> - tcl2erl:ret_int(["update idletasks;expr 1+1"]). - - % a hidden impl option. -gen_keep_opt(Opt,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - gstk_db:insert_opt(DB,Gstkid,Opt), - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,C). - -gen_children(_Opt,Gstkid,_TkW,DB,_ExtraArg) -> - make_extern_id(gstk_db:lookup_kids(DB, Gstkid#gstkid.id), DB). - -make_extern_id([Id|Ids], DB) -> - [gstk:make_extern_id(Id, DB) | make_extern_id(Ids, DB)]; -make_extern_id([], _) -> []. - -gen_id(_Opt,#gstkid{id=Id},_TkW,DB,_ExtraArg) -> - gstk:make_extern_id(Id, DB). - -gen_parent(_Opt,Gstkid,_TkW,DB,_ExtraArg) -> - gstk:make_extern_id(Gstkid#gstkid.parent, DB). - -gen_type(_Opt,Gstkid,_TkW,_DB,_ExtraArg) -> - Gstkid#gstkid.objtype. - -gen_beep(_,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,["bell;",$;|C]). - -gen_setfocus(true,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,["focus ", TkW,$;|C]); -gen_setfocus(false,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,["focus .",$;|C]). - -gen_setfocus(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> - tcl2erl:ret_focus(TkW, "focus"). - -gen_buttonpress(On,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - Cmd = bind(DB, Gstkid, TkW, buttonpress, On), - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,[Cmd,$;|C]). -gen_buttonpress(_Opt,Gstkid,_TkW,DB,_ExtraArg) -> - gstk_db:is_inserted(DB, Gstkid, buttonpress). - -gen_buttonrelease(On,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - Cmd = bind(DB, Gstkid, TkW, buttonrelease, On), - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,[Cmd,$;|C]). -gen_buttonrelease(_Opt,Gstkid,_TkW,DB,_ExtraArg) -> - gstk_db:is_inserted(DB,Gstkid,buttonrelease). - -gen_configure(On,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - Cmd = bind(DB, Gstkid, TkW, configure, On), - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,[Cmd,$;|C]). -gen_configure(_Opt,Gstkid,_TkW,DB,_ExtraArg) -> - gstk_db:is_inserted(DB,Gstkid,configure). - -gen_destroy(On,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - Cmd = bind(DB, Gstkid, TkW, destroy, On), - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,[Cmd,$;|C]). -gen_destroy(_Opt,Gstkid,_TkW,DB,_ExtraArg) -> - gstk_db:is_inserted(DB,Gstkid,destroy). - -gen_enter(On,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - Cmd = bind(DB, Gstkid, TkW, enter, On), - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,[Cmd,$;|C]). -gen_enter(_Opt,Gstkid,_TkW,DB,_ExtraArg) -> - gstk_db:is_inserted(DB,Gstkid,enter). - -gen_focus_ev(On,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - Cmd = bind(DB, Gstkid, TkW, focus, On), - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,[Cmd,$;|C]). -gen_focus_ev(_Opt,Gstkid,_TkW,DB,_ExtraArg) -> - gstk_db:is_inserted(DB,Gstkid,focus). - -gen_keypress(On,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - Cmd = bind(DB, Gstkid, TkW, keypress, On), - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,[Cmd,$;|C]). -gen_keypress(_Opt,Gstkid,_TkW,DB,_ExtraArg) -> - gstk_db:is_inserted(DB,Gstkid,keypress). - -gen_keyrelease(On,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - Cmd = bind(DB, Gstkid, TkW, keyrelease, On), - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,[Cmd,$;|C]). -gen_keyrelease(_Opt,Gstkid,_TkW,DB,_ExtraArg) -> - gstk_db:is_inserted(DB,Gstkid,keyrelease). - -gen_leave(On,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - Cmd = bind(DB, Gstkid, TkW, leave, On), - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,[Cmd,$;|C]). -gen_leave(_Opt,Gstkid,_TkW,DB,_ExtraArg) -> - gstk_db:is_inserted(DB,Gstkid,leave). - -gen_motion(On,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - Cmd = bind(DB, Gstkid, TkW, motion, On), - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,[Cmd,$;|C]). -gen_motion(_Opt,Gstkid,_TkW,DB,_ExtraArg) -> - gstk_db:is_inserted(DB,Gstkid,motion). - -gen_highlightbw(Wth,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,[" -highlightt ", gstk:to_ascii(Wth)|S],P,C). -gen_highlightbw(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> - tcl2erl:ret_int([TkW, " cg -highlightt"]). - -gen_highlightbg(Color,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,[" -highlightb ", gstk:to_color(Color)|S],P,C). -gen_highlightbg(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> - tcl2erl:ret_color([TkW, " cg -highlightb"]). - -gen_highlightfg(Color,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,[" -highlightc ", gstk:to_color(Color)|S],P,C). -gen_highlightfg(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> - tcl2erl:ret_color([TkW, " cg -highlightc"]). - - -gen_selectbw(Width,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,[TkW, " conf -selectbo ", gstk:to_ascii(Width),$;|C]). -gen_selectbw(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> - tcl2erl:ret_int([TkW," cg -selectbo"]). - -gen_selectfg(Color,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,[TkW, " conf -selectfo ", gstk:to_color(Color),$;|C]). -gen_selectfg(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> - tcl2erl:ret_color([TkW," cg -selectfo"]). - -gen_selectbg(Color,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,[TkW, " conf -selectba ", gstk:to_color(Color),$;|C]). -gen_selectbg(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> - tcl2erl:ret_color([TkW," cg -selectba"]). - -gen_fg(Color,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,[" -fg ", gstk:to_color(Color)|S],P,C). -gen_fg(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> - tcl2erl:ret_color([TkW, " cg -fg"]). - -gen_bg(Color,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,[" -bg ", gstk:to_color(Color)|S],P,C). -gen_bg(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> - tcl2erl:ret_color([TkW, " cg -bg"]). - -%%---------------------------------------------------------------------- -%% Generic functions for scrolled objects -%%---------------------------------------------------------------------- -gen_so_activebg(Color,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - Col = gstk:to_color(Color), - C2 = [TkW, ".sy conf -activeba ", Col,$;, - TkW, ".pad.sx conf -activeba ", Col], - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,[C2,$;|C]). -gen_so_activebg(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> - tcl2erl:ret_color([TkW,".sy cg -activeba"]). - -gen_so_bc(Color,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - Col = gstk:to_color(Color), - C2= [TkW, " conf -bg ", Col,$;, - TkW, ".sy conf -highlightba ", Col,$;, - TkW, ".pad.it conf -bg ", Col,$;, - TkW, ".pad.sx conf -highlightba ", Col], - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,[C2,$;|C]). -gen_so_bc(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> - tcl2erl:ret_color([TkW," cg -bg"]). - -gen_so_scrollfg(Color,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - Col = gstk:to_color(Color), - C2=[TkW, ".sy conf -bg ", Col,$;, - TkW, ".pad.sx conf -bg ", Col], - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,[C2,$;|C]). -gen_so_scrollfg(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> - tcl2erl:ret_color([TkW,".sy cg -bg"]). - - -gen_so_scrollbg(Color,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - Col = gstk:to_color(Color), - C2 = [TkW, ".sy conf -troughc ", Col, $;, - TkW, ".pad.sx conf -troughc ", Col], - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,[C2,$;|C]). - -gen_so_scrollbg(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> - tcl2erl:ret_color([TkW,".sy cg -troughc"]). - -obj(#gstkid{widget_data=SO}) -> - SO#so.object. - -gen_so_bg(Color,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - C2= [obj(Gstkid), " conf -bg ", gstk:to_color(Color)], - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,[C2,$;|C]). -gen_so_bg(_Opt,Gstkid,_TkW,_DB,_ExtraArg) -> - tcl2erl:ret_color([obj(Gstkid)," cg -bg"]). - -gen_so_selectbw(Width,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - C2 = [obj(Gstkid), " conf -selectbo ", gstk:to_ascii(Width)], - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,[C2,$;|C]). -gen_so_selectbw(_Opt,Gstkid,_TkW,_DB,_ExtraArg) -> - tcl2erl:ret_int([obj(Gstkid)," cg -selectbo"]). - -gen_so_selectfg(Color,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - C2 = [obj(Gstkid), " conf -selectfo ", gstk:to_color(Color)], - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,[C2,$;|C]). -gen_so_selectfg(_Opt,Gstkid,_TkW,_DB,_ExtraArg) -> - tcl2erl:ret_color([obj(Gstkid)," cg -selectfo"]). - -gen_so_selectbg(Color,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - C2 = [obj(Gstkid), " conf -selectba ", gstk:to_color(Color)], - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,[C2,$;|C]). -gen_so_selectbg(_Opt,Gstkid,_TkW,_DB,_ExtraArg) -> - tcl2erl:ret_color([obj(Gstkid)," cg -selectba"]). - -gen_so_scrolls({Vscroll, Hscroll},Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - SO = Gstkid#gstkid.widget_data, - NewSO = SO#so{hscroll=Hscroll, vscroll=Vscroll}, - C2 = scrolls_vh(TkW, Vscroll, Hscroll), - Ngstkid = Gstkid#gstkid{widget_data=NewSO}, - gstk_db:update_widget(DB,Ngstkid), - out_opts(Opts,Ngstkid,TkW,DB,ExtraArg,S,P,[C2,$;|C]). - - % read-only -gen_so_hscroll(_Opt,#gstkid{widget_data=SO},_TkW,_DB,_) -> - SO#so.hscroll. - - % read-only -gen_so_vscroll(_Opt,#gstkid{widget_data=SO},_TkW,_DB,_) -> - SO#so.vscroll. - -cursors() -> [{arrow,"top_left_arrow"},{busy,"watch"},{cross,"X_cursor"}, - {hand,"hand2"},{help,"question_arrow"},{resize,"fleur"}, - {text,"xterm"}]. - -gen_cursor(parent,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,[" -cur {}"|S],P,C); -gen_cursor(Cur,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - case gs:assq(Cur,cursors()) of - {value, TxtCur} -> - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,[" -cur ",TxtCur|S],P,C); - _ -> - {error,{invalid_cursor,Gstkid#gstkid.objtype,Cur}} - end. -gen_cursor(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> - case tcl2erl:ret_str([TkW," cg -cur"]) of - "" -> parent; - Txt when is_list(Txt) -> - case lists:keysearch(Txt,2,cursors()) of - {value,{Cur,_}} -> Cur; - _ -> {bad_result, read_cursor} - end; - Bad_Result -> Bad_Result - end. - -gen_citem_coords(Coords,Opts,Gstkid,TkW,DB,AItem,S,P,C) -> - gstk_db:insert_opt(DB,Gstkid,{coords,Coords}), - out_opts(Opts,Gstkid,TkW,DB,AItem,S,P, - [TkW, " coords ", AItem," ",gstk_canvas:coords(Coords),$;|C]). -gen_citem_coords(_Opt,Gstkid,_TkW,DB,_ExtraArg) -> - gstk_db:opt(DB,Gstkid, coords). - -gen_citem_fill(none,Opts,Gstkid,TkW,DB,AItem,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,AItem,[" -f {}"|S],P,C); -gen_citem_fill(Color,Opts,Gstkid,TkW,DB,AItem,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,AItem,[" -f ",gstk:to_color(Color)|S],P,C). -gen_citem_fill(_Opt,_Gstkid,TkW,_DB,AItem) -> - tcl2erl:ret_color([TkW, " itemcg ", AItem, " -f"]). - -gen_citem_lower(_,Opts,Gstkid,TkW,DB,AItem,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,AItem,S,P, - [TkW, " lower ", AItem,$;|C]). - -gen_citem_raise(_,Opts,Gstkid,TkW,DB,AItem,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,AItem,S,P, - [TkW, " raise ", AItem,$;|C]). - -gen_citem_move({Dx,Dy},Opts,Gstkid,TkW,DB,AItem,S,P,C) -> - NewCoords = move_coords(Dx,Dy,gstk_db:opt(DB,Gstkid,coords)), - gstk_db:insert_opt(DB,Gstkid,NewCoords), - out_opts(Opts,Gstkid,TkW,DB,AItem,S,P, - [TkW, " move ", AItem, " ", - gstk:to_ascii(Dx), " ", gstk:to_ascii(Dy),$;|C]). - -move_coords(Dx,Dy,Coords) -> - Coords2 = add_to_coords(Dx,Dy, Coords), - {coords,Coords2}. - -add_to_coords(Dx,Dy,[{X,Y}|Coords]) -> - [{X+Dx,Y+Dy}|add_to_coords(Dx,Dy,Coords)]; -add_to_coords(_,_,[]) -> []. - - -gen_citem_setfocus(true,Opts,Gstkid,TkW,DB,AItem,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,AItem,S,P, - [TkW, " focus ", AItem,$;|C]); -gen_citem_setfocus(false,Opts,Gstkid,TkW,DB,AItem,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,AItem,S,P, - [TkW, " focus {}",$;|C]). -gen_citem_setfocus(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> - tcl2erl:ret_focus(gstk:to_ascii(bug_aitem),[TkW, " focus"]). - -gen_citem_buttonpress(On,Opts,Gstkid,TkW,DB,AItem,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,AItem,S,P, - [item_bind(DB, Gstkid, TkW, AItem,buttonpress, On),$;|C]). -gen_citem_buttonrelease(On,Opts,Gstkid,TkW,DB,AItem,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,AItem,S,P, - [item_bind(DB,Gstkid,TkW,AItem,buttonrelease, On),$;|C]). -gen_citem_enter(On,Opts,Gstkid,TkW,DB,AItem,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,AItem,S,P, - [item_bind(DB, Gstkid, TkW, AItem, enter, On),$;|C]). - -gen_citem_keypress(On,Opts,Gstkid,TkW,DB,AItem,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,AItem,S,P, - [item_bind(DB, Gstkid, TkW, AItem, keypress, On),$;|C]). -gen_citem_keyrelease(On,Opts,Gstkid,TkW,DB,AItem,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,AItem,S,P, - [item_bind(DB, Gstkid, TkW, AItem, keyrelease, On),$;|C]). - -gen_citem_leave(On,Opts,Gstkid,TkW,DB,AItem,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,AItem,S,P, - [item_bind(DB, Gstkid, TkW, AItem, leave, On),$;|C]). -gen_citem_motion(On,Opts,Gstkid,TkW,DB,AItem,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,AItem,S,P, - [item_bind(DB, Gstkid, TkW, AItem, motion, On),$;|C]). - - -scrolls_vh(W, V, true) -> scrolls_vh(W, V, bottom); -scrolls_vh(W, true, H) -> scrolls_vh(W, left, H); -scrolls_vh(W, left, bottom) -> ["so_bottom_left ",W]; -scrolls_vh(W, left, top) -> ["so_top_left ",W]; -scrolls_vh(W, left, _) -> ["so_left ",W]; -scrolls_vh(W, right, bottom) -> ["so_bottom_right ",W]; -scrolls_vh(W, right, top) -> ["so_top_right ",W]; -scrolls_vh(W, right, _) -> ["so_right ",W]; -scrolls_vh(W, _, bottom) -> ["so_bottom ",W]; -scrolls_vh(W, _, top) -> ["so_top ",W]; -scrolls_vh(W, _, _) -> ["so_plain ",W]. - -%% create version -parse_scrolls(Opts) -> - {Vscroll, Hscroll, NewOpts} = parse_scrolls(Opts, false, false, []), - {Vscroll, Hscroll, [{scrolls, {Vscroll, Hscroll}} | NewOpts]}. - -%% config version -parse_scrolls(Gstkid, Opts) -> - SO = Gstkid#gstkid.widget_data, - Vscroll = SO#so.vscroll, - Hscroll = SO#so.hscroll, - case parse_scrolls(Opts, Vscroll, Hscroll, []) of - {Vscroll, Hscroll, Opts} -> Opts; - {NewVscroll, NewHscroll, NewOpts} -> - [{scrolls, {NewVscroll, NewHscroll}} | NewOpts] - end. - - -parse_scrolls([Option | Rest], Vscroll, Hscroll, Opts) when is_tuple(Option) -> - case element(1, Option) of - vscroll -> - parse_scrolls(Rest, element(2, Option), Hscroll, Opts); - hscroll -> - parse_scrolls(Rest, Vscroll, element(2, Option), Opts); - _ -> - parse_scrolls(Rest, Vscroll, Hscroll, [Option | Opts]) - end; - -parse_scrolls([Option | Rest], Vscroll, Hscroll, Opts) -> - parse_scrolls(Rest, Vscroll, Hscroll, [Option | Opts]); - -parse_scrolls([], Vscroll, Hscroll, Opts) -> - {Vscroll, Hscroll, Opts}. - - -%% -%% Event bind main function -%% -%% Should return a list of tcl commands or invalid_option -%% -%% WS = Widget suffix for complex widgets -%% -bind(DB, Gstkid, TkW, Etype, On) -> - WD = Gstkid#gstkid.widget_data, - TkW2 = if is_record(WD, so) -> - WD#so.object; - true -> TkW - end, - case bind(DB, Gstkid, TkW2, Etype, On, "") of - invalid_option -> invalid_option; - Cmd -> - Cmd - end. - -bind(DB, Gstkid, TkW, Etype, On, WS) -> - case On of - true -> ebind(DB, Gstkid, TkW, Etype, WS, ""); - false -> eunbind(DB, Gstkid, TkW, Etype, WS, ""); - {true, Edata} -> ebind(DB, Gstkid, TkW, Etype, WS, Edata); - {false, Edata} -> eunbind(DB, Gstkid, TkW, Etype, WS, Edata); - _ -> invalid_option - end. - - -%% -%% Event bind on -%% -%% Should return a list of tcl commands or invalid_option -%% -%% WS = Widget suffix for complex widgets -%% -ebind(DB, Gstkid, TkW, Etype, WS, Edata) -> - Eref = gstk_db:insert_event(DB, Gstkid, Etype, Edata), - P = ["bind ", TkW, WS], - Cmd = case Etype of - motion -> [P, " <Motion> {erlsend ", Eref, " %x %y}"]; - keypress -> - [P, " <KeyPress> {erlsend ", Eref," %K %N 0 0};", - P, " <Shift-KeyPress> {erlsend ", Eref, " %K %N 1 0};", - P, " <Control-KeyPress> {erlsend ", Eref, " %K %N 0 1};", - P," <Control-Shift-KeyPress> {erlsend ", Eref," %K %N 1 1}"]; - keyrelease -> - [P, " <KeyRelease> {erlsend ", Eref," %K %N 0 0};", - P, " <Shift-KeyRelease> {erlsend ", Eref, " %K %N 1 0};", - P, " <Control-KeyRelease> {erlsend ", Eref, " %K %N 0 1};", - P," <Control-Shift-KeyRelease> {erlsend ",Eref," %K %N 1 1}"]; - buttonpress -> - [P, " <ButtonPress> {erlsend ", Eref, " %b %x %y}"]; - buttonrelease -> - [P, " <ButtonRelease> {erlsend ", Eref, " %b %x %y}"]; - leave -> [P, " <Leave> {erlsend ", Eref, "}"]; - enter -> [P, " <Enter> {erlsend ", Eref, "}"]; - destroy -> - [P, " <Destroy> {if {\"%W\"==\"", [TkW, WS], - "\"} {erlsend ", Eref, "}}"]; - focus -> - [P, " <FocusIn> {erlsend ", Eref, " 1};" , - P, " <FocusOut> {erlsend ", Eref, " 0}"]; - configure -> - [P, " <Configure> {if {\"%W\"==\"", [TkW, WS], - "\"} {erlsend ", Eref, " %w %h %x %y}}"] - end, - Cmd. - - -%% -%% Unbind event -%% -%% Should return a list of tcl commands -%% Already checked for validation in bind/5 -%% -%% WS = Widget suffix for complex widgets -%% -eunbind(DB, Gstkid, TkW, Etype, WS, _Edata) -> - gstk_db:delete_event(DB, Gstkid, Etype), - P = ["bind ", TkW, WS], - Cmd = case Etype of - motion -> - [P, " <Motion> {}"]; - keypress -> - [P, " <KeyPress> {};", - P, " <Shift-KeyPress> {};", - P, " <Control-KeyPress> {};", - P, " <Control-Shift-KeyPress> {}"]; - keyrelease -> - [P, " <KeyRelease> {};", - P, " <Shift-KeyRelease> {};", - P, " <Control-KeyRelease> {};", - P, " <Control-Shift-KeyRelease> {}"]; - buttonpress -> - [P, " <ButtonPress> {}"]; - buttonrelease -> - [P, " <ButtonRelease> {}"]; - leave -> - [P, " <Leave> {}"]; - enter -> - [P, " <Enter> {}"]; - destroy -> - [P, " <Destroy> {}"]; - focus -> - [P, " <FocusIn> {};", - P, " <FocusOut> {}"]; - configure -> - [P, " <Configure> {}"] - end, - Cmd. - - -%% -%% Event item bind main function -%% -%% Should return a list of tcl commands or invalid_option -%% -item_bind(DB, Gstkid, Canvas, Item, Etype, On) -> - case On of - true -> item_ebind(DB, Gstkid, Canvas, Item, Etype, ""); - {true, Edata} -> item_ebind(DB, Gstkid, Canvas, Item, Etype, Edata); - _Other -> item_eunbind(DB, Gstkid, Canvas, Item, Etype) - end. - -%% -%% Event bind on -%% -%% Should return a list of tcl commands or invalid_option -%% -item_ebind(DB, Gstkid, Canvas, Item, Etype, Edata) -> - Eref = gstk_db:insert_event(DB, Gstkid, Etype, Edata), - P = [Canvas, " bind ", Item], - case Etype of - enter -> [P, " <Enter> {erlsend ", Eref, "}"]; - leave -> [P, " <Leave> {erlsend ", Eref, "}"]; - motion -> [P, " <Motion> {erlsend ", Eref, " [", - Canvas, " canvasx %x] [", Canvas, " canvasy %y] %x %y}"]; - keypress -> - [P, " <Key> {erlsend ", Eref," %K %N 0 0 [", - Canvas, " canvasx %x] [", Canvas, " canvasy %y]};", - P, " <Shift-Key> {erlsend ", Eref, " %K %N 1 0 [", - Canvas, " canvasx %x] [", Canvas, " canvasy %y]};", - P, " <Control-Key> {erlsend ", Eref, " %K %N 0 1 [", - Canvas, " canvasx %x] [", Canvas, " canvasy %y]};", - P, " <Control-Shift-Key> {erlsend ", Eref," %K %N 1 1 [", - Canvas, " canvasx %x] [", Canvas, " canvasy %y]}"]; - keyrelease -> - [P, " <KeyRelease> {erlsend ", Eref," %K %N 0 0 [", - Canvas, " canvasx %x] [", Canvas, " canvasy %y]};", - P, " <Shift-KeyRelease> {erlsend ", Eref, " %K %N 1 0 [", - Canvas, " canvasx %x] [", Canvas, " canvasy %y]};", - P, " <Control-KeyRelease> {erlsend ", Eref, " %K %N 0 1 [", - Canvas, " canvasx %x] [", Canvas, " canvasy %y]};", - P, " <Control-Shift-KeyRelease> {erlsend ", Eref," %K %N 1 1[", - Canvas, " canvasx %x] [", Canvas, " canvasy %y]}"]; - buttonpress -> - [P, " <Button> {erlsend ", Eref, " %b [", - Canvas, " canvasx %x] [", Canvas, " canvasy %y] %x %y}"]; - buttonrelease -> - [P, " <ButtonRelease> {erlsend ", Eref, " %b [", - Canvas, " canvasx %x] [", Canvas, " canvasy %y] %x %y}"] - end. - - -%% -%% Unbind event -%% -%% Should return a list of tcl commands -%% Already checked for validation in bind/5 -%% -item_eunbind(DB, Gstkid, Canvas, Item, Etype) -> - gstk_db:delete_event(DB, Gstkid, Etype), - P = [Canvas, " bind ", Item], - Cmd = case Etype of - enter -> [P, " <Enter> {}"]; - leave -> [P, " <Leave> {}"]; - motion -> [P, " <Motion> {}"]; - keypress -> - [P, " <KeyPress> {};", - P, " <Shift-KeyPress> {};", - P, " <Control-KeyPress> {};", - P, " <Control-Shift-KeyPress> {}"]; - keyrelease -> - [P, " <KeyRelease> {};", - P, " <Shift-KeyRelease> {};", - P, " <Control-KeyRelease> {};", - P, " <Control-Shift-KeyRelease> {}"]; - buttonpress -> [P, " <Button> {}"]; - buttonrelease -> [P, " <ButtonRelease> {}"] - end, - Cmd. - - - -event(DB, Gstkid, Etype, _Edata, Args) -> - #gstkid{owner=Ow,id=Id} = Gstkid, - Data = gstk_db:opt(DB,Gstkid,data), - gs_frontend:event(get(gs_frontend),Ow,{gs,Id,Etype,Data,Args}). diff --git a/lib/gs/src/gstk_grid.erl b/lib/gs/src/gstk_grid.erl deleted file mode 100644 index 4e8cffc018..0000000000 --- a/lib/gs/src/gstk_grid.erl +++ /dev/null @@ -1,284 +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_grid). --compile([{nowarn_deprecated_function,{gs,val,2}}]). - --export([event/5,create/3,config/3,option/5,read/3,delete/2,destroy/2, - mk_create_opts_for_child/4,read_option/5]). - --include("gstk.hrl"). - -%%----------------------------------------------------------------------------- -%% GRID OPTIONS -%% -%% rows {ViewFrom, ViewTo} -%% columnwidths [CW1, CW2, ..., CWn] -%% vscroll Bool | left | right -%% hscroll Bool | top | bottom -%% x Coord -%% y Coord -%% width Int -%% height Int -%% fg Color (lines and default line color) -%% bg Color -%%----------------------------------------------------------------------------- - --record(state,{canvas,ncols,max_range,cell_id, cell_pos,ids,db,tkcanvas}). --record(item,{text_id,rect_id,line_id}). - -%%====================================================================== -%% Interfaces -%%====================================================================== - -event(DB, Gstkid, Etype, Edata, Args) -> - gstk_gridline:event(DB, Gstkid, Etype, Edata, Args). - -create(DB, Gstkid, Options) -> - WinParent=Gstkid#gstkid.parent, - {OtherOpts,CanvasOpts} = parse_opts(Options,[],[]), - %% Why this (secret) hack? Performance reasons. - %% if we ".canvas bind all" once and for all, then we can - %% create lines twice as fast since we don't have to bind each line. - C = make_ref(), - gstk:create_impl(DB,{a_grid, {canvas,C,WinParent, - [{secret_hack_gridit, Gstkid} - | CanvasOpts]}}), - CanvasGstkid = gstk_db:lookup_gstkid(DB, C), - Wid = CanvasGstkid#gstkid.widget, - SO = CanvasGstkid#gstkid.widget_data, - TkCanvas = SO#so.object, - CI=ets:new(gstk_grid_cellid,[private,set]), - CP=ets:new(gstk_grid_cellpos,[private,set]), - IDs=ets:new(gstk_grid_id,[private,set]), - S=#state{db=DB,ncols=length(gs:val(columnwidths,OtherOpts)), - canvas=C,cell_id=CI,tkcanvas=TkCanvas,cell_pos=CP,ids=IDs}, - Ngstkid = Gstkid#gstkid{widget=Wid,widget_data=S}, - gstk_db:insert_opts(DB,Ngstkid,OtherOpts), - gstk_db:insert_widget(DB,Ngstkid), - gstk_generic:mk_cmd_and_exec(lists:keydelete(columnwidths,1,OtherOpts), - Ngstkid, TkCanvas,"","", DB,nop). - -config(DB, Gstkid, Options) -> - #gstkid{widget=TkW,widget_data=State}=Gstkid, - {OtherOpts,CanvasOpts} = parse_opts(Options,[],[]), - case gstk:config_impl(DB,State#state.canvas,CanvasOpts) of - ok -> - SimplePreCmd = "nyi?", - PlacePreCmd = [";place ", TkW], - gstk_generic:mk_cmd_and_exec(OtherOpts,Gstkid,TkW, - SimplePreCmd,PlacePreCmd,DB,State); - Err -> Err - end. - - -option(Option, Gstkid, _TkW, DB,State) -> - case Option of - {rows,{From,To}} -> - Ngstkid = reconfig_rows(From,To,Gstkid), - gstk_db:insert_opt(DB,Gstkid,Option), - gstk_db:update_widget(DB,Ngstkid), - {none,Ngstkid}; - {fg,_Color} -> - reconfig_grid(DB,Option,State), - gstk_db:insert_opt(DB,Gstkid,Option), - none; - {bg,_Color} -> - reconfig_grid(DB,Option,State), - gstk_db:insert_opt(DB,Gstkid,Option), - none; - {font,_Font} -> - reconfig_grid(DB,Option,State), - gstk_db:insert_opt(DB,Gstkid,Option), - none; - {columnwidths,ColWs} -> - gstk_db:insert_opt(DB,Gstkid,Option), - Rows = gstk_db:opt(DB,Gstkid,rows), - CellHeight = gstk_db:opt(DB,Gstkid,cellheight), - gstk:config_impl(DB,State#state.canvas, - [calc_scrollregion(Rows,ColWs,CellHeight)]), - %% Crash upon an error msg (so we know WHY) - {result,_} = gstk:call(["resize_grid_cols ",State#state.tkcanvas, - " [list ",asc_tcl_colw(ColWs),"]"]), - none; - {cellheight,_Height} -> - gstk_db:insert_opt(DB,Gstkid,Option), - none; - _ -> - invalid_option - end. - -reconfig_grid(_,_,nop) -> done; -reconfig_grid(DB,Option,#state{tkcanvas=TkW,cell_pos=CP, - ncols=Ncols,max_range={From,To}}) -> - reconfig_grid(DB,TkW,Option,From,To,CP,Ncols). - -reconfig_grid(DB,TkW,Opt,Row,MaxRow,CellPos,Ncols) when Row =< MaxRow -> - [{_,Item}] = ets:lookup(CellPos,{1,Row}), - case Item#item.line_id of - free -> empty_cell_config(DB,TkW,Row,1,Ncols,CellPos,Opt); - GridLine -> - gstk_gridline:config(DB,gstk_db:lookup_gstkid(DB,GridLine), - [Opt]) - end, - reconfig_grid(DB,TkW,Opt,Row+1,MaxRow,CellPos,Ncols); -reconfig_grid(_,_,_,_,_,_,_) -> done. - -%%---------------------------------------------------------------------- -%% Purpose: Config an empty cell (i.e. has no gridline) -%%---------------------------------------------------------------------- -empty_cell_config(DB,TkW,Row,Col,Ncols,CellPos,Opt) when Col =< Ncols -> - [{_,Item}] = ets:lookup(CellPos,{Col,Row}), - empty_cell_config(DB,TkW,Item,Opt), - empty_cell_config(DB,TkW,Row,Col+1,Ncols,CellPos,Opt); -empty_cell_config(_,_,_,_,_,_,_) -> done. - -empty_cell_config(_,TkW,#item{rect_id=Rid},{bg,Color}) -> - gstk:exec([TkW," itemconf ",gstk:to_ascii(Rid)," -f ",gstk:to_color(Color)]); -empty_cell_config(_,TkW,#item{rect_id=Rid,text_id=Tid},{fg,Color}) -> - Acolor = gstk:to_color(Color), - Pre = [TkW," itemconf "], - RectStr = [Pre, gstk:to_ascii(Rid)," -outline ",Acolor], - TexdStr = [Pre, gstk:to_ascii(Tid)," -fi ",Acolor], - gstk:exec([RectStr,$;,TexdStr]); -empty_cell_config(DB,TkW,#item{text_id=Tid},{font,Font}) -> - gstk:exec([TkW," itemconf ",gstk:to_ascii(Tid)," -font ", - gstk_font:choose_ascii(DB,Font)]); -empty_cell_config(_,_,_,_) -> done. - - - -reconfig_rows(From, To, Gstkid) -> - #gstkid{widget_data=State,id=Id} = Gstkid, - #state{tkcanvas=TkCanvas,cell_pos=CP,cell_id=CI, - canvas=C,db=DB,max_range=Range}=State, - NewRange = - if Range == undefined -> - mkgrid(DB,CP,CI,TkCanvas,Id,From,To), - {From,To}; - true -> - {Top,Bot} = Range, - if - From < Top -> % we need more rects above - mkgrid(DB,CP,CI,TkCanvas,Id,From,Top-1); - true -> true - end, - if - To > Bot -> % we need more rects below - mkgrid(DB,CP,CI,TkCanvas,Id,Bot+1,To); - true -> true - end, - {lists:min([Top, From]), lists:max([Bot, To])} - end, - gstk:config_impl(DB,C,[calc_scrollregion({From,To}, - gstk_db:opt(DB,Id,columnwidths), - gstk_db:opt(DB,Id,cellheight))]), - S2 = State#state{max_range=NewRange}, - Gstkid#gstkid{widget_data=S2}. - -read(DB,Gstkid,Opt) -> - State = Gstkid#gstkid.widget_data, - case lists:member(Opt,[x,y,width,height,hscroll,vscroll]) of - true -> gstk:read_impl(DB,State#state.canvas,Opt); - false -> - gstk_generic:read_option(DB, Gstkid, Opt,State) - end. - -read_option(Option,Gstkid,_TkW,DB,State) -> - case Option of - {obj_at_row,Row} -> - case ets:lookup(State#state.cell_pos,{1,Row}) of - [{_pos,Item}] -> - case Item#item.line_id of - free -> undefined; - GridLine -> - gstk:make_extern_id(GridLine, DB) - end; - _ -> undefined - end; - Opt -> gstk_db:opt(DB,Gstkid#gstkid.id,Opt,undefined) - end. - - -%%---------------------------------------------------------------------- -%% Is always called. -%% Clean-up my specific side-effect stuff. -%%---------------------------------------------------------------------- -delete(DB, Gstkid) -> - gstk_db:delete_widget(DB, Gstkid), - State = Gstkid#gstkid.widget_data, - #state{canvas=C,cell_pos=CP,cell_id=CIs, ids=IDs} = State, - ets:delete(CP), - ets:delete(CIs), - ets:delete(IDs), - {Gstkid#gstkid.parent, Gstkid#gstkid.id, gstk_grid, [C]}. - -%%---------------------------------------------------------------------- -%% Is called iff my parent is not also destroyed. -%%---------------------------------------------------------------------- -destroy(DB, Canvas) -> - gstk:destroy_impl(DB,gstk_db:lookup_gstkid(DB,Canvas)). - -mk_create_opts_for_child(DB,Cgstkid, Pgstkid, Opts) -> - gstk_generic:mk_create_opts_for_child(DB,Cgstkid,Pgstkid,Opts). - -mkgrid(DB,CellPos,CellIds,TkCanvas,Id,From,To) -> - ColWs = gstk_db:opt(DB,Id,columnwidths), - AscColW = ["[list ",asc_tcl_colw(ColWs),"]"], - Font = gstk_font:choose_ascii(DB,gstk_db:opt(DB,Id,font)), - Fg = gstk:to_color(gstk_db:opt(DB,Id,fg)), - Bg = gstk:to_color(gstk_db:opt(DB,Id,bg)), - Objs = tcl2erl:ret_list(["mkgrid ",TkCanvas," ",AscColW," ", - gstk:to_ascii(From)," ", - gstk:to_ascii(To)," ", - gstk:to_ascii(gstk_db:opt(DB,Id,cellheight))," ", - Font," ",Fg," ",Bg]), - insert_objs(CellPos,CellIds,From,To,1,length(ColWs)+1,Objs). - -insert_objs(_,_,_,_,_,_,[]) -> done; -insert_objs(CP,CI,Row,T,MaxCol,MaxCol,Objs) -> - insert_objs(CP,CI,Row+1,T,1,MaxCol,Objs); -insert_objs(CellPos,CellIds,Row,To,Col,Ncols,[RectId,TextId|Objs]) -> - ets:insert(CellPos,{{Col,Row}, - #item{text_id=TextId,rect_id=RectId,line_id=free}}), - ets:insert(CellIds,{RectId,{Col,Row}}), - ets:insert(CellIds,{TextId,{Col,Row}}), - insert_objs(CellPos,CellIds,Row,To,Col+1,Ncols,Objs). - -asc_tcl_colw([]) -> ""; -asc_tcl_colw([Int|T]) -> [gstk:to_ascii(Int)," "|asc_tcl_colw(T)]. - -%%---------------------------------------------------------------------- -%% Args: Cols list of column sizes (measured in n-chars) -%%---------------------------------------------------------------------- -calc_scrollregion({From, To}, Cols, Height) -> - {scrollregion, {0, ((From-1) * Height) + From, - lists:sum(Cols)+length(Cols)+1, (To * Height)+ To+1}}. - -parse_opts([],OtherOpts,CanvasOpts) -> {OtherOpts,CanvasOpts}; -parse_opts([{Key,Val}|Opts],OtherOpts,CanvasOpts) -> - case lists:member(Key,[x,y,width,height,vscroll,hscroll]) of - true -> parse_opts(Opts,OtherOpts,[{Key,Val}|CanvasOpts]); - false -> parse_opts(Opts,[{Key,Val}|OtherOpts],CanvasOpts) - end; -parse_opts([Opt|Opts],OtherOpts,CanvasOpts) -> - parse_opts(Opts,[Opt|OtherOpts],CanvasOpts). - diff --git a/lib/gs/src/gstk_gridline.erl b/lib/gs/src/gstk_gridline.erl deleted file mode 100644 index d504ed5319..0000000000 --- a/lib/gs/src/gstk_gridline.erl +++ /dev/null @@ -1,301 +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_gridline). --compile([{nowarn_deprecated_function,{gs,val,2}}, - {nowarn_deprecated_function,{gs,val,3}}]). - --export([event/5,create/3,config/3,option/5,read/3,delete/2,destroy/3, - read_option/5]). - --include("gstk.hrl"). --record(state,{canvas,ncols,max_range,cell_id, cell_pos,ids,db,tkcanvas}). --record(item,{text_id,rect_id,line_id}). - -%%----------------------------------------------------------------------------- -%% GRIDLINE OPTIONS -%% -%% text Text -%% row Row -%% data Data -%% fg Color (default is the same as grid fg) -%% click Bool -%% -%%----------------------------------------------------------------------------- - -create(DB, Gstkid, Options) -> - Pgstkid = gstk_db:lookup_gstkid(DB,Gstkid#gstkid.parent), - Id = Gstkid#gstkid.id, - #gstkid{widget_data=State} = Pgstkid, - #state{cell_pos=CP,tkcanvas=TkW,ncols=Ncols} = State, - Row = gs:val(row,Options), - case check_row(CP,Row) of - {error,Reason} -> {error,Reason}; - ok -> - Ngstkid = Gstkid#gstkid{widget=TkW}, - gstk_db:insert_opts(DB,Id,[{data,[]},{row,Row}]), - update_cp_db(Ncols,Row,Id,CP), - config_line(DB,Pgstkid,Ngstkid,Row,Options), - Ngstkid - end. - -%%---------------------------------------------------------------------- -%% Returns: ok|false -%%---------------------------------------------------------------------- -check_row(_CellPos,undefined) -> - {error,{gridline,{row,undefined}}}; -check_row(CellPos,Row) -> - case ets:lookup(CellPos,{1,Row}) of - [] -> - {error,{gridline,row_outside_range,Row}}; - [{_,Item}] -> - case Item#item.line_id of - free -> ok; - _ -> - {error,{gridline,row_is_occupied,Row}} - end - end. - -%%---------------------------------------------------------------------- -%% s => text item -%% p => rect item -%%---------------------------------------------------------------------- -option(Option, _Gstkid, _TkW, DB,_) -> - case Option of - {{bg,_Item}, Color} -> {p,[" -f ", gstk:to_color(Color)]}; - {{text,_Item},Text} -> {s, [" -te ", gstk:to_ascii(Text)]}; - {{fg,_Item},Color} -> {sp,{[" -fi ", gstk:to_color(Color)], - [" -outline ", gstk:to_color(Color)]}}; - {{font,_Item},Font} -> {s,[" -font ",gstk_font:choose_ascii(DB,Font)]}; - _ -> invalid_option - end. - -%%---------------------------------------------------------------------- -%% Is always called. -%% Clean-up my specific side-effect stuff. -%%---------------------------------------------------------------------- -delete(DB, Gstkid) -> - Row = gstk_db:opt(DB,Gstkid,row), - gstk_db:delete_widget(DB, Gstkid), - {Gstkid#gstkid.parent, Gstkid#gstkid.id, gstk_gridline,[Gstkid, Row]}. - -%%---------------------------------------------------------------------- -%% Is called iff my parent is not also destroyed. -%%---------------------------------------------------------------------- -destroy(DB, Lgstkid, Row) -> - Ggstkid = gstk_db:lookup_gstkid(DB,Lgstkid#gstkid.parent), - #gstkid{widget_data=State} = Ggstkid, - config_line(DB,Ggstkid,Lgstkid,Row, - [{bg,gstk_db:opt(DB,Ggstkid,bg)}, - {fg,gstk_db:opt(DB,Ggstkid,fg)},{text,""}]), - Ncols = State#state.ncols, - update_cp_db(Ncols,Row,free,State#state.cell_pos). - - -config(DB, Gstkid, Opts) -> - Pgstkid = gstk_db:lookup_gstkid(DB,Gstkid#gstkid.parent), - case {gs:val(row,Opts,missing),gstk_db:opt(DB,Gstkid,row)} of - {Row,Row} -> % stay here... - config_line(DB,Pgstkid,Gstkid,Row,Opts); - {missing,Row} -> % stay here... - config_line(DB,Pgstkid,Gstkid,Row,Opts); - {NewRow,OldRow} -> - config_line(DB,Pgstkid,Gstkid,OldRow,Opts), - Ngstkid = gstk_db:lookup_gstkid(DB,Gstkid#gstkid.id), - case move_line(NewRow,OldRow,DB,Pgstkid#gstkid.widget_data,Ngstkid) of - true -> - gstk_db:insert_opt(DB,Ngstkid,{row,NewRow}), - ok; - {error,_Reason} -> ok - end - end, - ok. - -%%---------------------------------------------------------------------- -%% Returns: true|false depending on if operation succeeded -%%---------------------------------------------------------------------- -move_line(NewRow,OldRow,_DB,State,_Ngstkid) -> - case ets:lookup(State#state.cell_pos,{1,NewRow}) of - [] -> - {error,{gridline,row_outside_grid,NewRow}}; - [{_,#item{line_id=Lid}}] when Lid =/= free-> - {error,{gridline,new_row_occupied,NewRow}}; - [{_,_NewItem}] -> - #state{tkcanvas=TkW,ncols=Ncols,cell_pos=CP} = State, - swap_lines(TkW,OldRow,NewRow,1,Ncols,CP), - true - end. - -%%---------------------------------------------------------------------- -%% Purpose: swaps an empty newrow with a (oldrow) gridline -%%---------------------------------------------------------------------- -swap_lines(TkW,OldRow,NewRow,Col,MaxCol,CellPos) when Col =< MaxCol -> - [{_,NewItem}] = ets:lookup(CellPos,{Col,NewRow}), - [{_,OldItem}] = ets:lookup(CellPos,{Col,OldRow}), - swap_cells(TkW,NewItem,OldItem), - ets:insert(CellPos,{{Col,NewRow},OldItem}), - ets:insert(CellPos,{{Col,OldRow},NewItem}), - swap_lines(TkW,OldRow,NewRow,Col+1,MaxCol,CellPos); -swap_lines(_,_,_,_,_,_) -> done. - -swap_cells(TkW,#item{rect_id=NewRectId,text_id=NewTextId}, - #item{rect_id=OldRectId,text_id=OldTextId}) -> - Aorid = gstk:to_ascii(OldRectId), - Aotid = gstk:to_ascii(OldTextId), - Anrid = gstk:to_ascii(NewRectId), - Antid = gstk:to_ascii(NewTextId), - Pre = [TkW," coords "], - OldRectCoords = tcl2erl:ret_str([Pre,Aorid]), - OldTextCoords = tcl2erl:ret_str([Pre,Aotid]), - NewRectCoords = tcl2erl:ret_str([Pre,Anrid]), - NewTextCoords = tcl2erl:ret_str([Pre,Antid]), - gstk:exec([Pre,Aotid," ",NewTextCoords]), - gstk:exec([Pre,Antid," ",OldTextCoords]), - gstk:exec([Pre,Aorid," ",NewRectCoords]), - gstk:exec([Pre,Anrid," ",OldRectCoords]). - -%%---------------------------------------------------------------------- -%% Pre: {row,Row} option is taken care of. -%%---------------------------------------------------------------------- -config_line(DB,Pgstkid,Lgstkid,Row,Opts) -> - #gstkid{widget_data=State, widget=TkW} = Pgstkid, - #state{cell_pos=CP,ncols=Ncols} = State, - Ropts = transform_opts(Opts,Ncols), - RestOpts = config_gridline(DB,CP,Lgstkid,Ncols,Row,Ropts), - gstk_generic:mk_cmd_and_exec(RestOpts,Lgstkid,TkW,"","",DB). - -%%---------------------------------------------------------------------- -%% Returns: non-processed options -%%---------------------------------------------------------------------- -config_gridline(_DB,_CP,_Gstkid,0,_Row,Opts) -> - Opts; -config_gridline(DB,CP,Gstkid,Col,Row,Opts) -> - {ColOpts,OtherOpts} = opts_for_col(Col,Opts,[],[]), - if - ColOpts==[] -> done; - true -> - [{_pos,Item}] = ets:lookup(CP,{Col,Row}), - TkW = Gstkid#gstkid.widget, - TextPre = [TkW," itemconf ",gstk:to_ascii(Item#item.text_id)], - RectPre = [$;,TkW," itemconf ",gstk:to_ascii(Item#item.rect_id)], - case gstk_generic:make_command(ColOpts,Gstkid,TkW, - TextPre,RectPre,DB) of - [] -> ok; - {error,_Reason} -> ok; - Cmd -> gstk:exec(Cmd) - end - end, - config_gridline(DB,CP,Gstkid,Col-1,Row,OtherOpts). - -opts_for_col(Col,[{{Key,Col},Val}|Opts],ColOpts,RestOpts) -> - opts_for_col(Col,Opts,[{{Key,Col},Val}|ColOpts],RestOpts); -opts_for_col(Col,[Opt|Opts],ColOpts,RestOpts) -> - opts_for_col(Col,Opts,ColOpts,[Opt|RestOpts]); -opts_for_col(_Col,[],ColOpts,RestOpts) -> {ColOpts,RestOpts}. - -%%---------------------------------------------------------------------- -%% {Key,{Col,Val}} becomes {{Key,Col},Val} -%% {Key,Val} becomes {{Key,1},Val}...{{Key,Ncol},Val} -%%---------------------------------------------------------------------- -transform_opts([], _Ncols) -> []; -transform_opts([{{Key,Col},Val} | Opts],Ncols) -> - [{{Key,Col},Val}|transform_opts(Opts,Ncols)]; -transform_opts([{Key,{Col,Val}}|Opts],Ncols) when is_integer(Col) -> - [{{Key,Col},Val}|transform_opts(Opts,Ncols)]; -transform_opts([{Key,Val}|Opts],Ncols) -> - case lists:member(Key,[fg,bg,text,font]) of - true -> - lists:append(expand_to_all_cols(Key,Val,Ncols), - transform_opts(Opts,Ncols)); - false -> - case lists:member(Key,[click,doubleclick,row]) of - true -> - [{keep_opt,{Key,Val}}|transform_opts(Opts,Ncols)]; - false -> - [{Key,Val}|transform_opts(Opts,Ncols)] - end - end; -transform_opts([Opt|Opts],Ncols) -> - [Opt|transform_opts(Opts,Ncols)]. - -expand_to_all_cols(Key,Val,1) -> - [{{Key,1},Val}]; -expand_to_all_cols(Key,Val,Col) -> - [{{Key,Col},Val}|expand_to_all_cols(Key,Val,Col-1)]. - - -read(DB, Gstkid, Opt) -> - Pgstkid = gstk_db:lookup_gstkid(DB,Gstkid#gstkid.parent), - gstk_generic:read_option(DB, Gstkid, Opt,Pgstkid). - -read_option({font,Column},Gstkid, _TkW,DB,Pgstkid) -> - case gstk_db:opt_or_not(DB,Gstkid,{font,Column}) of - false -> gstk_db:opt(DB,Pgstkid,font); - {value,V} -> V - end; -read_option({Opt,Column},Gstkid, TkW,DB,#gstkid{widget_data=State}) -> - Row = gstk_db:opt(DB,Gstkid,row), - [{_pos,Item}] = ets:lookup(State#state.cell_pos,{Column,Row}), - Rid = gstk:to_ascii(Item#item.rect_id), - Tid = gstk:to_ascii(Item#item.text_id), - Pre = [TkW," itemcg "], - case Opt of - bg -> tcl2erl:ret_color([Pre,Rid," -f"]); - fg -> tcl2erl:ret_color([Pre,Tid," -fi"]); - text -> tcl2erl:ret_str([Pre,Tid," -te"]); - _ -> {bad_result, {Gstkid#gstkid.objtype, invalid_option, {Opt,Column}}} - end; -read_option(Option,Gstkid,TkW,DB,Pgstkid) -> - case lists:member(Option,[bg,fg,text]) of - true -> read_option({Option,1},Gstkid,TkW,DB,Pgstkid); - false -> gstk_db:opt(DB,Gstkid,Option,undefined) - end. - -update_cp_db(0,_Row,_,_) -> ok; -update_cp_db(Col,Row,ID,CP) -> - [{_,Item}] = ets:lookup(CP,{Col,Row}), - ets:insert(CP,{{Col,Row},Item#item{line_id = ID}}), - update_cp_db(Col-1,Row,ID,CP). - - -event(DB, GridGstkid, Etype, _Edata, [CanItem]) -> - State = GridGstkid#gstkid.widget_data, - #state{cell_pos=CP,cell_id=CIs,tkcanvas=TkW} = State, - case ets:lookup(CIs,CanItem) of - [{_id,{Col,Row}}] -> - [{_pos,Item}] = ets:lookup(CP,{Col,Row}), - case Item#item.line_id of - free -> ok; - Id -> - Lgstkid = gstk_db:lookup_gstkid(DB,Id), - case gstk_db:opt_or_not(DB,Lgstkid,Etype) of - {value,true} -> - Txt = read_option({text,Col},Lgstkid,TkW, - DB,GridGstkid), - gstk_generic:event(DB,Lgstkid,Etype,dummy, - [Col,Row,Txt]); - _ -> ok - end - end; - _ -> ok - end; -event(_DB, _Gstkid, _Etype, _Edata, _Args) -> - ok. diff --git a/lib/gs/src/gstk_gs.erl b/lib/gs/src/gstk_gs.erl deleted file mode 100644 index 80be066626..0000000000 --- a/lib/gs/src/gstk_gs.erl +++ /dev/null @@ -1,54 +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% -%% - -%% -%%% Purpose : The GS object - --module(gstk_gs). - --export([mk_create_opts_for_child/4, - config/3, - read/3, - read_option/5, - option/5]). - --include("gstk.hrl"). - -%%---------------------------------------------------------------------- -%% The GS object implementation -%%---------------------------------------------------------------------- - -mk_create_opts_for_child(DB,Cgstkid, Pgstkid, Opts) -> - gstk_generic:mk_create_opts_for_child(DB,Cgstkid,Pgstkid,Opts). - -config(DB, Gstkid, Opts) -> - Cmd=gstk_generic:make_command(Opts,Gstkid,"",DB), - gstk:exec(Cmd), - ok. - -read(DB, Gstkid, Opt) -> - gstk_generic:read_option(DB, Gstkid, Opt). - -% No options of my own -read_option(Option,Gstkid, _TkW,_DB,_) -> - {bad_result, {Gstkid#gstkid.objtype, invalid_option, Option}}. - -option(_Option, _Gstkid, _TkW, _DB,_) -> - invalid_option. diff --git a/lib/gs/src/gstk_image.erl b/lib/gs/src/gstk_image.erl deleted file mode 100644 index 124bda77a2..0000000000 --- a/lib/gs/src/gstk_image.erl +++ /dev/null @@ -1,321 +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% -%% - -%% -%% ------------------------------------------------------------ -%% Basic Image Type -%% ------------------------------------------------------------ - --module(gstk_image). --compile([{nowarn_deprecated_function,{gs,pair,2}}]). - -%%----------------------------------------------------------------------------- -%% BITMAP OPTIONS -%% -%% Attributes: -%% anchor n|w|e|s|nw|sw|ne|se|center -%% bg Color -%% bitmap String -%% coords [{X,Y}] -%% data Data -%% fg Color -%% -%% Attributes for gifs only: -%% pix_val {{X,Y},Color}|{{{X1,Y1},{X2,Y2}},Color] -%% save String -%% refresh -%% -%% Commands: -%% lower -%% move {Dx, Dy} -%% raise -%% scale {Xo, Yo, Sx, Sy} -%% setfocus Bool -%% -%% Events: -%% buttonpress [Bool | {Bool, Data}] -%% buttonrelease [Bool | {Bool, Data}] -%% enter [Bool | {Bool, Data}] -%% keypress [Bool | {Bool, Data}] -%% keyrelease [Bool | {Bool, Data}] -%% leave [Bool | {Bool, Data}] -%% motion [Bool | {Bool, Data}] -%% -%% Read Options: -%% pix_val {X,Y} -%% children -%% id -%% parent -%% type -%% -%% Not Implemented: -%% - --export([create/3, config/3, read/3, delete/2, destroy/3, event/5, - option/5,read_option/5]). - --include("gstk.hrl"). - -%%------------------------------------------------------------------------------ -%% MANDATORY INTERFACE FUNCTIONS -%%------------------------------------------------------------------------------ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : create/7 -%% Purpose : Create a widget of the type defined in this module. -%% Args : DB - The Database -%% Objmod - An atom, this module -%% Objtype - An atom, the logical widget type -%% Owner - Pid of the creator -%% Name - An atom naming the widget -%% Parent - Gsid of the parent -%% Opts - A list of options for configuring the widget -%% -%% Return : [Gsid_of_new_widget | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -create(DB, Gstkid, Opts) -> - case pickout_type(Opts) of - bitmap -> - create(bitmap,DB, Gstkid, Opts); - _gif -> %%Default gif - create(gif,DB, Gstkid, Opts) - end. - -create(gif,DB, Gstkid, Opts) -> - case pickout_coords(Opts, []) of - {error, Error} -> - {bad_result, Error}; - {Coords, NewOpts} -> - CCmd = "image create photo", - case tcl2erl:ret_atom(CCmd) of - Photo_item when is_atom(Photo_item) -> - #gstkid{parent=Parent,owner=Owner,id=Id}=Gstkid, - Pgstkid = gstk_db:lookup_gstkid(DB, Parent, Owner), - SO = Pgstkid#gstkid.widget_data, - CanvasTkW = SO#so.object, - Photo_item_s = atom_to_list(Photo_item), - gstk_db:insert_opt(DB,Id,gs:pair(coords,Opts)), - Ngstkid=Gstkid#gstkid{widget=CanvasTkW, - widget_data={Photo_item_s,unknown}}, - gstk_db:update_widget(DB,Ngstkid), - MCmd = [CanvasTkW," create image ",Coords," -image ", - Photo_item_s," -anchor nw"], - case gstk_canvas:make_command(NewOpts, Ngstkid, - CanvasTkW, MCmd, DB) of - {error,Reason} -> {error,Reason}; - Cmd when is_list(Cmd) -> - case tcl2erl:ret_int(Cmd) of - Item when is_integer(Item) -> - %% buu, not nice - G2 = gstk_db:lookup_gstkid(DB,Id), - NewWidget = {Photo_item_s,Item}, - NewGstkid = G2#gstkid{widget_data=NewWidget}, - gstk_db:insert_widget(DB, NewGstkid), - NewGstkid; - Bad_result -> - {error,Bad_result} - end - end; - Bad_result -> - {error,Bad_result} - end - end; - -create(bitmap,DB, Gstkid, Opts) -> - case pickout_coords(Opts, []) of - {error, Error} -> - {bad_result, Error}; - {Coords, NewOpts} -> - #gstkid{parent=Parent,owner=Owner,id=Id}=Gstkid, - Pgstkid = gstk_db:lookup_gstkid(DB, Parent, Owner), - SO = Pgstkid#gstkid.widget_data, - CanvasTkW = SO#so.object, - gstk_db:insert_opt(DB,Id,gs:pair(coords,Opts)), - Ngstkid=Gstkid#gstkid{widget=CanvasTkW, widget_data=no_item}, - gstk_db:update_widget(DB,Ngstkid), - MCmd = [CanvasTkW," create bi ", Coords], - gstk_canvas:mk_cmd_and_call(NewOpts,Ngstkid, CanvasTkW, MCmd,DB) - end. - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : config/3 -%% Purpose : Configure a widget of the type defined in this module. -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% Opts - A list of options for configuring the widget -%% -%% Return : [true | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -config(DB, Gstkid, Opts) -> - {Canvas, Item} = get_widget(Gstkid), - AItem = gstk:to_ascii(Item), - SCmd = [Canvas, " itemconf ", AItem], - gstk_canvas:mk_cmd_and_exec(Opts, Gstkid, Canvas, AItem, SCmd, DB). - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : read/3 -%% Purpose : Read one option from a widget -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% Opt - An option to read -%% -%% Return : [OptionValue | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -read(DB, Gstkid, Opt) -> - {_, Item} = get_widget(Gstkid), - gstk_generic:read_option(DB,Gstkid,Opt,[gstk:to_ascii(Item)]). - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : delete/2 -%% Purpose : Delete widget from databas and return tkwidget to destroy -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% -%% Return : TkWidget to destroy | {Parent, Objmod, Args}. -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -delete(DB, Gstkid) -> - gstk_db:delete_widget(DB, Gstkid), - #gstkid{parent=P,id=ID}=Gstkid, - {Canvas, Item} = get_widget(Gstkid), - {P, ID, gstk_image, [Canvas, Item]}. - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : destroy/3 -%% Purpose : Destroy a widget -%% Args : DB - The Database -%% Canvas - The canvas tk widget -%% Item - The item number to destroy -%% -%% Return : [true | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -destroy(_DB, Canvas, Item) -> - gstk:exec([Canvas, " delete ", gstk:to_ascii(Item)]). - - -event(DB, Gstkid, Etype, Edata, Args) -> - gstk_generic:event(DB, Gstkid, Etype, Edata, Args). - -%%------------------------------------------------------------------------------ -%% MANDATORY FUNCTIONS -%%------------------------------------------------------------------------------ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : option/5 -%% Purpose : Take care of options -%% Args : Option - An option tuple -%% Gstkid - The gstkid of the widget -%% MainW - The main tk-widget -%% Canvas - The canvas tk-widget -%% DB - The Database -%% -%% Return : A tuple {OptionType, OptionCmd} -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -option(Option, Gstkid, _Canvas, _DB, _AItem) -> - case Option of - {bitmap, Bitmap} -> - BF = re:replace(Bitmap, [92,92], "/", [global,{return,list}]), - {s, [" -bi @", BF]}; - {load_gif, File} -> - F2 = re:replace(File, [92,92], "/", [global,{return,list}]), - {Photo_item, _item} = Gstkid#gstkid.widget_data, - {c,[Photo_item, " configure -file ", gstk:to_ascii(F2)]}; - {pix_val, {Coords,Color}} -> - {Photo_item, _item} = Gstkid#gstkid.widget_data, - {c, [Photo_item, " put ", gstk:to_color(Color), " -to ", - coords(Coords)]}; - {save_gif, Name} -> - {Photo_item, _item} = Gstkid#gstkid.widget_data, - {c, [Photo_item, " write ", gstk:to_ascii(Name)]}; - {fg, Color} -> {s, [" -fo ", gstk:to_color(Color)]}; - {bg, Color} -> {s, [" -ba ", gstk:to_color(Color)]}; - {anchor, How} -> {s, [" -anchor ", gstk:to_ascii(How)]}; - _ -> invalid_option - end. - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : read_option/5 -%% Return : The value of the option or invalid_option -%% [OptionValue | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -read_option(Option, Gstkid, Canvas, _DB, AItem) -> - case Option of - anchor -> tcl2erl:ret_atom([Canvas," itemcget ",AItem," -anchor"]); - bg -> tcl2erl:ret_color([Canvas, " itemcget ", AItem, " -ba"]); - bitmap -> tcl2erl:ret_file([Canvas, " itemcget ", AItem, " -bi"]); - fg -> tcl2erl:ret_color([Canvas, " itemcget ", AItem, " -fo"]); - {pix_val,{X,Y}} -> - {Photo_item, _item} = Gstkid#gstkid.widget_data, - ret_photo_color([Photo_item," get ",coords({X,Y})]); - _ -> {bad_result, {Gstkid#gstkid.objtype, invalid_option, Option}} - end. - -ret_photo_color(Cmd) -> - case gstk:call(Cmd) of - {result,Str} -> - {ok, [R,G,B],[]} = io_lib:fread("~d ~d ~d", Str), - {R,G,B}; - Bad_result -> Bad_result - end. - - -%%------------------------------------------------------------------------------ -%% PRIMITIVES -%%------------------------------------------------------------------------------ -get_widget(#gstkid{widget=Canvas,widget_data={_Photo_item,Item}}) -> - {Canvas,Item}; -get_widget(#gstkid{widget=Canvas,widget_data=Item}) -> - {Canvas,Item}. - -pickout_coords([{coords,Coords} | Rest], Opts) when length(Coords) == 1 -> - case coords(Coords) of - invalid -> - {error, "An image must have two coordinates"}; - RealCoords -> - {RealCoords, lists:append(Rest, Opts)} - end; -pickout_coords([Opt | Rest], Opts) -> - pickout_coords(Rest, [Opt|Opts]); -pickout_coords([], _Opts) -> - {error, "An image must have two coordinates"}. - -coords({X,Y}) when is_number(X),is_number(Y) -> - [gstk:to_ascii(X), " ", gstk:to_ascii(Y), " "]; -coords([{X,Y} | R]) when is_number(X),is_number(Y) -> - [gstk:to_ascii(X), " ", gstk:to_ascii(Y), " ", coords(R)]; -coords({{X1,Y1},{X2,Y2}}) when is_number(X1),is_number(Y1),is_number(X2),is_number(Y2) -> - [gstk:to_ascii(X1), " ", gstk:to_ascii(Y1)," ", - gstk:to_ascii(X2), " ", gstk:to_ascii(Y2)]; -coords([_]) -> %% not a pair - invalid; -coords([]) -> - []. - - -pickout_type([{bitmap,_Str}|_Options]) -> - bitmap; -pickout_type([{gif,_Str}|_Options]) -> - gif; -pickout_type([]) -> - none; -pickout_type([_|Tail]) -> - pickout_type(Tail). - -%% ----- Done ----- - diff --git a/lib/gs/src/gstk_label.erl b/lib/gs/src/gstk_label.erl deleted file mode 100644 index 2cdd36f331..0000000000 --- a/lib/gs/src/gstk_label.erl +++ /dev/null @@ -1,183 +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% -%% - -%% -%% ------------------------------------------------------------ -%% Basic Label Type -%% ------------------------------------------------------------ - --module(gstk_label). -%%------------------------------------------------------------------------------ -%% LABEL OPTIONS -%% -%% Attributes: -%% align n,w,s,e,nw,se,ne,sw,center -%% anchor n,w,s,e,nw,se,ne,sw,center -%% bg Color -%% bw Int -%% data Data -%% fg Color -%% font Font -%% height Int -%% highlightbg Color -%% highlightbw Int -%% highlightfg Color -%% justify left|right|center -%% label {text, String} | {image, BitmapFile} -%% padx Int (Pixels) -%% pady Int (Pixels) -%% relief Relief [flat|raised|sunken|ridge|groove] -%% underline Int -%% width Int -%% wraplength Int -%% x Int -%% y Int -%% -%% Commands: -%% setfocus Bool -%% -%% Events: -%% buttonpress [Bool | {Bool, Data}] -%% buttonrelease [Bool | {Bool, Data}] -%% configure [Bool | {Bool, Data}] -%% destroy [Bool | {Bool, Data}] -%% enter [Bool | {Bool, Data}] -%% focus [Bool | {Bool, Data}] -%% keypress [Bool | {Bool, Data}] -%% keyrelease [Bool | {Bool, Data}] -%% leave [Bool | {Bool, Data}] -%% motion [Bool | {Bool, Data}] -%% -%% Read Options: -%% children -%% id -%% parent -%% type -%% -%% Not Implemented: -%% cursor ?????? -%% focus ?????? (-takefocus) -%% - --export([create/3,config/3,read/3,delete/2,event/5,option/5,read_option/5]). - --include("gstk.hrl"). - -%%----------------------------------------------------------------------------- -%% MANDATORY INTERFACE FUNCTIONS -%%----------------------------------------------------------------------------- -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : create/3 -%% Purpose : Create a widget of the type defined in this module. -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -create(DB, GstkId, Opts) -> - TkW = gstk_generic:mk_tkw_child(DB,GstkId), - PlacePreCmd = [";place ", TkW], - Ngstkid = GstkId#gstkid{widget=TkW}, - case gstk_generic:make_command(Opts,Ngstkid,TkW,"",PlacePreCmd,DB) of - {error,Reason} -> {error,Reason}; - Cmd when is_list(Cmd) -> - gstk:exec(["label ", TkW,Cmd]), - Ngstkid - end. - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : config/3 -%% Purpose : Configure a widget of the type defined in this module. -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% Opts - A list of options for configuring the widget -%% -%% Return : [true | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -config(DB, Gstkid, Opts) -> - TkW = Gstkid#gstkid.widget, - SimplePreCmd = [TkW, " conf"], - PlacePreCmd = [";place ", TkW], - gstk_generic:mk_cmd_and_exec(Opts,Gstkid,TkW,SimplePreCmd,PlacePreCmd,DB). - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : read/3 -%% Purpose : Read one option from a widget -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% Opt - An option to read -%% -%% Return : [OptionValue | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -read(DB, Gstkid, Opt) -> - gstk_generic:read_option(DB, Gstkid, Opt). - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : delete/2 -%% Purpose : Delete widget from databas and return tkwidget to destroy -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% -%% Return : TkWidget to destroy -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -delete(DB, Gstkid) -> - gstk_db:delete_widget(DB, Gstkid), - Gstkid#gstkid.widget. - -event(DB, Gstkid, Etype, Edata, Args) -> - gstk_generic:event(DB, Gstkid, Etype, Edata, Args). - - -%%----------------------------------------------------------------------------- -%% MANDATORY FUNCTIONS -%%----------------------------------------------------------------------------- -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : option/4 -%% Purpose : Take care of options -%% Args : Option - An option tuple -%% Gstkid - The gstkid of the widget -%% TkW - The tk-widget -%% DB - The Database -%% -%% Return : A tuple {OptionType, OptionCmd} -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -option(Option, _Gstkid, _TkW, _DB,_) -> - case Option of - {underline, Int} -> {s, [" -und ", gstk:to_ascii(Int)]}; - {wraplength, Int} -> {s, [" -wra ", gstk:to_ascii(Int)]}; - _ -> invalid_option - end. - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : read_option/4 -%% Purpose : Take care of a read option -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% Option - An option -%% -%% Return : The value of the option or invalid_option -%% [OptionValue | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -read_option(Option,Gstkid,TkW,_DB,_) -> - case Option of - underline -> tcl2erl:ret_int([TkW," cg -und"]); - wraplength -> tcl2erl:ret_int([TkW," cg -wra"]); - _ -> {bad_result, {Gstkid#gstkid.objtype, invalid_option, Option}} - end. - -%%% ----- Done ----- - diff --git a/lib/gs/src/gstk_line.erl b/lib/gs/src/gstk_line.erl deleted file mode 100644 index 18c87b2011..0000000000 --- a/lib/gs/src/gstk_line.erl +++ /dev/null @@ -1,203 +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% -%% - -%% -%% ------------------------------------------------------------ -%% Basic Line Type -%% ------------------------------------------------------------ - --module(gstk_line). - - -%%----------------------------------------------------------------------------- -%% LINE OPTIONS -%% -%% Attributes: -%% arrow none | first | last | both -%% capstyle butt | projecting | round -%% coords [{X1,Y1}, {X2,Y2} | {Xn,Yn}] -%% data Data -%% fg Color -%% joinstyle miter | bevel | round -%% smooth Bool -%% splinesteps Int -%% stipple Bool -%% width Wth -%% -%% Commands: -%% lower -%% move {Dx, Dy} -%% raise -%% scale {Xo, Yo, Sx, Sy} -%% setfocus Bool -%% -%% Events: -%% buttonpress [Bool | {Bool, Data}] -%% buttonrelease [Bool | {Bool, Data}] -%% enter [Bool | {Bool, Data}] -%% keypress [Bool | {Bool, Data}] -%% keyrelease [Bool | {Bool, Data}] -%% leave [Bool | {Bool, Data}] -%% motion [Bool | {Bool, Data}] -%% -%% Read Options: -%% children -%% id -%% parent -%% type -%% -%% Not Implemented: -%% - --export([create/3, config/3, read/3, delete/2, destroy/3, event/5, - option/5,read_option/5]). - --include("gstk.hrl"). - -%%----------------------------------------------------------------------------- -%% MANDATORY INTERFACE FUNCTIONS -%%----------------------------------------------------------------------------- -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : create/3 -%% Purpose : Create a widget of the type defined in this module. -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -create(DB, Gstkid, Opts) -> - case pickout_coords(Opts, []) of - {error, Error} -> - {bad_result, Error}; - {Coords, NewOpts} -> - Ngstkid=gstk_canvas:upd_gstkid(DB, Gstkid, Opts), - #gstkid{widget=CanvasTkW}=Ngstkid, - MCmd = [CanvasTkW, " create li ", Coords], - gstk_canvas:mk_cmd_and_call(NewOpts,Ngstkid, CanvasTkW, MCmd, DB) - end. - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : config/3 -%% Purpose : Configure a widget of the type defined in this module. -%% Return : [true | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -config(DB, Gstkid, Opts) -> - gstk_canvas:item_config(DB, Gstkid, Opts). - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : read/3 -%% Purpose : Read one option from a widget -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% Opt - An option to read -%% -%% Return : [OptionValue | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -read(DB, Gstkid, Opt) -> - Item = Gstkid#gstkid.widget_data, - gstk_generic:read_option(DB,Gstkid,Opt,[gstk:to_ascii(Item)]). - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : delete/2 -%% Purpose : Delete widget from databas and return tkwidget to destroy -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% -%% Return : TkWidget to destroy | {Parent, Objmod, Args}. -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -delete(DB, Gstkid) -> - gstk_canvas:item_delete_impl(DB,Gstkid). - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : destroy/3 -%% Purpose : Destroy a widget -%% Args : DB - The Database -%% Canvas - The canvas tk widget -%% Item - The item number to destroy -%% -%% Return : [true | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -destroy(_DB, Canvas, Item) -> - gstk:exec([Canvas, " delete ", gstk:to_ascii(Item)]). - - -event(DB, Gstkid, Etype, Edata, Args) -> - gstk_generic:event(DB, Gstkid, Etype, Edata, Args). - -%%----------------------------------------------------------------------------- -%% MANDATORY FUNCTIONS -%%----------------------------------------------------------------------------- -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : option/5 -%% Purpose : Take care of options -%% Args : Option - An option tuple -%% Gstkid - The gstkid of the widget -%% MainW - The main tk-widget -%% Canvas - The canvas tk-widget -%% DB - The Database -%% -%% Return : A tuple {OptionType, OptionCmd} -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -option(Option, _Gstkid, _Canvas, _DB, _AItem) -> - case Option of - {arrow, Where} -> {s, [" -arrow ", gstk:to_ascii(Where)]}; - {capstyle, Style} -> {s, [" -ca ", gstk:to_ascii(Style)]}; - {fg, Color} -> {s, [" -f ", gstk:to_color(Color)]}; - {joinstyle, Style} -> {s, [" -jo ", gstk:to_ascii(Style)]}; - {smooth, Bool} -> {s, [" -sm ", gstk:to_ascii(Bool)]}; - {splinesteps, Int} -> {s, [" -sp ", gstk:to_ascii(Int)]}; - {width, Int} -> {s, [" -w ", gstk:to_ascii(Int)]}; - - _ -> invalid_option - end. - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : read_option/5 -%% Purpose : Take care of a read option -%% Args : DB - The Database -%% Return : The value of the option or invalid_option -%% [OptionValue | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -read_option(Option, Gstkid, Canvas, _DB, AItem) -> - case Option of - arrow -> tcl2erl:ret_atom([Canvas, " itemcg ",AItem, " -arrow"]); - capstyle -> tcl2erl:ret_atom([Canvas, " itemcg ", AItem, " -ca"]); - fg -> tcl2erl:ret_color([Canvas, " itemcg ", AItem, " -f"]); - joinstyle -> tcl2erl:ret_atom([Canvas, " itemcg ", AItem, " -jo"]); - smooth -> tcl2erl:ret_bool([Canvas, " itemcg ", AItem, " -sm"]); - splinesteps -> tcl2erl:ret_int([Canvas, " itemcg ", AItem, " -sp"]); - stipple -> - tcl2erl:ret_stipple([Canvas," itemcg ",AItem," -stipple"]); - width -> tcl2erl:ret_int([Canvas, " itemcg ", AItem, " -w"]); - _ -> {bad_result, {Gstkid#gstkid.objtype, invalid_option, Option}} - end. - -pickout_coords([{coords,Coords} | Rest], Opts) when length(Coords) >= 2 -> - case gstk_canvas:coords(Coords) of - invalid -> - {error, "A line must have at least four coordinates"}; - RealCoords -> - {RealCoords, lists:append(Rest, Opts)} - end; -pickout_coords([Opt | Rest], Opts) -> - pickout_coords(Rest, [Opt|Opts]); -pickout_coords([], _Opts) -> - {error, "A line must have at least four coordinates"}. - -%% ----- Done ----- - diff --git a/lib/gs/src/gstk_listbox.erl b/lib/gs/src/gstk_listbox.erl deleted file mode 100644 index 50d0503629..0000000000 --- a/lib/gs/src/gstk_listbox.erl +++ /dev/null @@ -1,324 +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% -%% - -%% -%% ----------------------------------------------------------- -%% Basic Listbox Type -%% ------------------------------------------------------------ - --module(gstk_listbox). - -%%----------------------------------------------------------------------------- -%% LISTBOX OPTIONS -%% -%% Attributes: -%% activebg Color -%% anchor n,w,s,e,nw,se,ne,sw,center -%% bc Color -%% bg Color -%% bw Wth -%% data Data -%% fg Color -%% height Int -%% highlightbg Color -%% highlightbw Wth -%% highlightfg Color -%% hscroll Bool | top | bottom -%% items [String, String, ... String] -%% relief Relief -%% scrollbg Color -%% scrollfg Color -%% selectbg Color -%% selectbw Width -%% selectfg Color -%% selection Index | clear -%% selectmode single|browse|multiple|extended -%% vscroll Bool | left | right -%% width Int -%% x Int -%% xselection Bool (Good name?????) -%% y Int -%% -%% Commands: -%% add {Index, String} | String -%% change {Index, String} -%% clear -%% del Index | {FromIdx, ToIdx} -%% get Index -%% see Index -%% selection => [Idx1,Idx2,Idx3...] -%% setfocus Bool -%% size Int -%% -%% Events: -%% buttonpress [Bool | {Bool, Data}] -%% buttonrelease [Bool | {Bool, Data}] -%% click [Bool | {Bool, Data}] -%% configure [Bool | {Bool, Data}] -%% destroy [Bool | {Bool, Data}] -%% doubleclick [Bool | {Bool, Data}] -%% enter [Bool | {Bool, Data}] -%% focus [Bool | {Bool, Data}] -%% keypress [Bool | {Bool, Data}] -%% keyrelease [Bool | {Bool, Data}] -%% leave [Bool | {Bool, Data}] -%% motion [Bool | {Bool, Data}] -%% -%% Read Options: -%% children -%% id -%% parent -%% type -%% - --export([create/3,config/3,read/3,delete/2,event/5,wid_event/5,option/5, - read_option/5]). - --include("gstk.hrl"). - -%%----------------------------------------------------------------------------- -%% MANDATORY INTERFACE FUNCTIONS -%%----------------------------------------------------------------------------- -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : create/7 -%% Purpose : Create a widget of the type defined in this module. -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -create(DB, GstkId, Opts) -> - MainW = gstk_generic:mk_tkw_child(DB,GstkId), - Listbox = lists:append(MainW,".z"), - {Vscroll, Hscroll, NewOpts} = gstk_generic:parse_scrolls(Opts), - WidgetD = #so{main=MainW, object=Listbox, - hscroll=Hscroll, vscroll=Vscroll}, - Gstkid=GstkId#gstkid{widget=MainW, widget_data=WidgetD}, - MandatoryCmd = ["so_create listbox ", MainW], - case gstk:call(MandatoryCmd) of - {result, _} -> - SimplePreCmd = [MainW, " conf"], - PlacePreCmd = [";place ", MainW], - case gstk_generic:make_command(NewOpts, Gstkid, MainW,SimplePreCmd, - PlacePreCmd, DB,Listbox) of - {error,Reason} -> {error,Reason}; - Cmd when is_list(Cmd) -> - gstk:exec(Cmd), - gstk:exec([MainW,".sy conf -rel sunken -bo 2;", - MainW,".pad.sx conf -rel sunken -bo 2;",Listbox, - " conf -bo 2 -relief sunken -highlightth 2 -expo 0;"]), - Gstkid - end; - Bad_Result -> - {error, Bad_Result} - end. - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : config/3 -%% Purpose : Configure a widget of the type defined in this module. -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% Opts - A list of options for configuring the widget -%% -%% Return : [true | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -config(DB, Gstkid, Options) -> - SO = Gstkid#gstkid.widget_data, - MainW = Gstkid#gstkid.widget, - Listbox = SO#so.object, - NewOpts = gstk_generic:parse_scrolls(Gstkid, Options), - SimplePreCmd = [MainW, " conf"], - PlacePreCmd = [";place ", MainW], - gstk_generic:mk_cmd_and_exec(NewOpts, Gstkid, MainW, - SimplePreCmd, PlacePreCmd, DB,Listbox). - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : read/3 -%% Purpose : Read one option from a widget -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% Opt - An option to read -%% -%% Return : [OptionValue | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -read(DB, Gstkid, Opt) -> - SO = Gstkid#gstkid.widget_data, - gstk_generic:read_option(DB, Gstkid, Opt,SO#so.object). - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : delete/2 -%% Purpose : Delete widget from databas and return tkwidget to destroy -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% -%% Return : TkWidget to destroy -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -delete(DB, Gstkid) -> - gstk_db:delete_widget(DB, Gstkid), - Gstkid#gstkid.widget. - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : event/5 -%% Purpose : Construct the event and send it to the owner of the widget -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% Etype - The event type -%% Edata - The event data -%% Args - The data from tcl/tk -%% -%% Return : [true | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -event(DB, Gstkid, click, Edata, Args) -> - wid_event(DB, Gstkid, click, Edata, Args); -event(DB, Gstkid, doubleclick, Edata, Args) -> - wid_event(DB, Gstkid, doubleclick, Edata, Args); -event(DB, Gstkid, Etype, Edata, Args) -> - gstk_generic:event(DB, Gstkid, Etype, Edata, Args). - - -%% widget specific events -wid_event(DB, Gstkid, Etype, Edata, _Args) -> - SO = Gstkid#gstkid.widget_data, - TkW = SO#so.object, - CurIdx = tcl2erl:ret_int([TkW," index active;"]), - CurTxt = tcl2erl:ret_str([TkW," get active;"]), - CurSel = tcl2erl:ret_list([TkW," curselection;"]), - Arg2 = [CurIdx,CurTxt,lists:member(CurIdx,CurSel)], - gstk_generic:event(DB, Gstkid, Etype, Edata, Arg2). - - -%%----------------------------------------------------------------------------- -%% MANDATORY FUNCTIONS -%%----------------------------------------------------------------------------- -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : option/5 -%% Purpose : Take care of options -%% Args : Option - An option tuple -%% Gstkid - The gstkid of the widget -%% MainW - The main tk-widget -%% Listbox - The listbox tk-widget -%% DB - The Database -%% -%% Return : A tuple {OptionType, OptionCmd} -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -option(Option, Gstkid, MainW,DB, Listbox) -> - case Option of - {items, Items} when is_list(Items) -> - {c, [Listbox," del 0 end ;", Listbox," ins 0 ",item_list(Items)]}; - {selection, {From, To}} when is_integer(From),is_integer(To) -> - {c,[Listbox," sel set ",gstk:to_ascii(From)," " ,gstk:to_ascii(To)]}; - {font, Font} when is_tuple(Font) -> - gstk_db:insert_opt(DB,Gstkid,Option), - {c, [Listbox," conf -font ",gstk_font:choose_ascii(DB,Font)]}; - {selection, clear} -> - {c, [Listbox," sel clear 0 end"]}; - {selection, Idx} when is_integer(Idx) -> - {c, [Listbox, " select set ", gstk:to_ascii(Idx)]}; - {selectmode, Mode} -> - {c, [Listbox, " conf -selectm ", gstk:to_ascii(Mode)]}; - {xselection, Bool} -> - {c, [Listbox, " conf -exportse ", gstk:to_ascii(Bool)]}; - {fg, Color} -> - {c, [Listbox, " conf -fg ", gstk:to_color(Color)]}; - - {del, {From, To}} -> - {c, [Listbox, " del ", integer_to_list(From), " ", - integer_to_list(To)]}; - {del, Idx} -> - {c, [Listbox, " del ", integer_to_list(Idx)]}; - clear -> {c, [Listbox," del 0 end"]}; - {add, {Idx, Str}} -> - {c, [Listbox, " ins ", integer_to_list(Idx), " ", - gstk:to_ascii(Str)]}; - {add, Str} -> - {c, [Listbox," ins end ",gstk:to_ascii(Str)]}; - {change, {Idx, Str}} -> - {c, [Listbox, " del ", integer_to_list(Idx), $;, - Listbox, " ins ", integer_to_list(Idx), " " , - gstk:to_ascii(Str)]}; - {see, Idx} -> - {c, [Listbox," see ",gstk:to_ascii(Idx)]}; - - {setfocus, true} -> {c, ["focus ", MainW]}; - {setfocus, false} -> {c, ["focus ."]}; - - {click, On} -> cbind(DB, Gstkid, Listbox, click, On); - {doubleclick, On} -> cbind(DB, Gstkid, Listbox, doubleclick, On); - _ -> invalid_option - end. - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : read_option/3 -%% Purpose : Take care of a read option -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% Option - An option -%% -%% Return : The value of the option or invalid_option -%% [OptionValue | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -read_option(Option,GstkId,_MainW,DB,Listbox) -> - case Option of - fg -> tcl2erl:ret_color([Listbox," cg -fg"]); - font -> gstk_db:opt(DB,GstkId,font,undefined); - selection -> tcl2erl:ret_list([Listbox, " curselection"]); - setfocus -> tcl2erl:ret_focus(Listbox, "focus"); - - items -> tcl2erl:ret_str_list([Listbox, " get 0 end"]); - selectmode -> tcl2erl:ret_atom([Listbox, " cg -selectmode"]); - size -> tcl2erl:ret_int([Listbox, " size"]); - xselection -> tcl2erl:ret_bool([Listbox, " cg -exportsel"]); - {get, Idx} -> tcl2erl:ret_str([Listbox, " get ",gstk:to_ascii(Idx)]); - click -> gstk_db:is_inserted(DB, GstkId, click); - doubleclick -> gstk_db:is_inserted(DB, GstkId, doubleclick); - - _ -> {bad_result, {GstkId#gstkid.objtype, invalid_option, Option}} - end. - - -%%----------------------------------------------------------------------------- -%% PRIMITIVES -%%----------------------------------------------------------------------------- - -item_list([H|T]) -> - [gstk:to_ascii(H),$ |item_list(T)]; -item_list([]) -> - []. - -cbind(DB, Gstkid, Listbox, Etype, {true, Edata}) -> - Button = case Etype of - click -> " <ButtonRelease-1> "; - doubleclick -> " <Double-ButtonRelease-1> " - end, - Eref = gstk_db:insert_event(DB, Gstkid, Etype, Edata), - {c, ["bind " ,Listbox, Button, "{erlsend ", Eref," }"]}; - -cbind(DB, Gstkid, Listbox, Etype, true) -> - cbind(DB, Gstkid, Listbox, Etype, {true, []}); - -cbind(DB, Gstkid, Listbox, Etype, _On) -> - Button = case Etype of - click -> " <Button-1> {}"; - doubleclick -> " <Double-Button-1> {}" - end, - gstk_db:delete_event(DB, Gstkid, Etype), - {c, ["bind ",Listbox, Button]}. - - -%%% ----- Done ----- diff --git a/lib/gs/src/gstk_menu.erl b/lib/gs/src/gstk_menu.erl deleted file mode 100644 index 2f12a20a7d..0000000000 --- a/lib/gs/src/gstk_menu.erl +++ /dev/null @@ -1,268 +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% -%% - -%% -%%----------------------------------------------------------------------------- -%% BASIC MENU TYPE -%%------------------------------------------------------------------------------ - --module(gstk_menu). --compile([{nowarn_deprecated_function,{gs,error,2}}]). - -%%------------------------------------------------------------------------------ -%% MENU OPTIONS -%% -%% Attribute: -%% activebg Color -%% activebw Int -%% activefg Color -%% bg Color -%% bw Int -%% data Data -%% disabledfg Color -%% fg Color -%% relief Relief [flat|raised|sunken|ridge|groove] -%% selectcolor Color -%% -%% Commands: -%% setfocus [Bool | {Bool, Data}] -%% -%% Events: -%% buttonpress [Bool | {Bool, Data}] -%% buttonrelease [Bool | {Bool, Data}] -%% configure [Bool | {Bool, Data}] -%% destroy [Bool | {Bool, Data}] -%% enter [Bool | {Bool, Data}] -%% focus [Bool | {Bool, Data}] -%% keypress [Bool | {Bool, Data}] -%% keyrelease [Bool | {Bool, Data}] -%% leave [Bool | {Bool, Data}] -%% motion [Bool | {Bool, Data}] -%% -%% Read Options: -%% children -%% id -%% parent -%% type -%% -%% Not Implemented: -%% post {X,Y} -%% unpost -%% align n,w,s,e,nw,se,ne,sw,center -%% anchor n,w,s,e,nw,se,ne,sw,center -%% cursor ?????? -%% focus ?????? (-takefocus) -%% height Int -%% justify left|right|center (multiline text only) -%% width Int -%% x Int (valid only for popup menus) -%% y Int (valid only for popup menus) -%% - --export([create/3, config/3, read/3, delete/2, event/5,option/5,read_option/5]). --export([delete_menuitem/3, insert_menuitem/4, lookup_menuitem_pos/3, - mk_create_opts_for_child/4]). - --include("gstk.hrl"). - -%%------------------------------------------------------------------------------ -%% MANDATORY INTERFACE FUNCTIONS -%%------------------------------------------------------------------------------ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : create/3 -%% Purpose : Create a widget of the type defined in this module. -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -create(DB, GstkId, Opts) -> - #gstkid{parent=Parent,owner=Owner,objtype=Objtype}=GstkId, - Pgstkid = gstk_db:lookup_gstkid(DB, Parent, Owner), - Oref = gstk_db:counter(DB, Objtype), - PF = gstk_widgets:suffix(Objtype), - case Pgstkid#gstkid.objtype of - menuitem -> - PMenu = Pgstkid#gstkid.parent, - PMgstkid = gstk_db:lookup_gstkid(DB, PMenu, Owner), - PMW = PMgstkid#gstkid.widget, - Index = gstk_menu:lookup_menuitem_pos(DB, PMgstkid, Pgstkid#gstkid.id), - TkW = lists:concat([PMW, PF, Oref]), - Gstkid=GstkId#gstkid{widget=TkW, widget_data=[]}, - MPreCmd = ["menu ", TkW, " -tearoff 0 -relief raised -bo 2"], - MPostCmd = [$;,PMW," entryco ",gstk:to_ascii(Index)," -menu ",TkW], - case gstk_generic:make_command(Opts, Gstkid, TkW, "", "", DB) of - {error,Reason} -> {error,Reason}; - Cmd when is_list(Cmd) -> - gstk:exec([MPreCmd,Cmd,MPostCmd]), - Gstkid - end; - OtherParent -> - true = lists:member(OtherParent, - %% grid+canvas har skumma coord system - [menubutton,window,frame]), - PW = Pgstkid#gstkid.widget, - TkW = lists:concat([PW, PF, Oref]), - Gstkid=GstkId#gstkid{widget=TkW, widget_data=[]}, - MPreCmd = ["menu ", TkW, " -tearoff 0 -relief raised -bo 2 "], - MPostCmd = if OtherParent == menubutton -> - [$;, PW, " conf -menu ", TkW]; - true -> [] - end, - case gstk_generic:make_command(Opts, Gstkid, TkW, "","", DB) of - {error,Reason} -> {error,Reason}; - Cmd when is_list(Cmd) -> - gstk:exec([MPreCmd,Cmd,MPostCmd]), - Gstkid - end - end. - -mk_create_opts_for_child(DB,Cgstkid, Pgstkid, Opts) -> - gstk_generic:mk_create_opts_for_child(DB,Cgstkid,Pgstkid,Opts). - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : config/3 -%% Purpose : Configure a widget of the type defined in this module. -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% Opts - A list of options for configuring the widget -%% -%% Return : [true | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -config(DB, Gstkid, Opts) -> - TkW = Gstkid#gstkid.widget, - PreCmd = [TkW, " conf"], - gstk_generic:mk_cmd_and_exec(Opts, Gstkid, TkW, PreCmd, "", DB). - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : read/3 -%% Purpose : Read one option from a widget -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% Opt - An option to read -%% -%% Return : [OptionValue | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -read(DB, Gstkid, Opt) -> - gstk_generic:read_option(DB, Gstkid, Opt). - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : delete/2 -%% Purpose : Delete widget from databas and return tkwidget to destroy -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% -%% Return : TkWidget to destroy -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -delete(DB, Gstkid) -> - gstk_db:delete_widget(DB, Gstkid), - Gstkid#gstkid.widget. - -event(DB, Gstkid, Etype, Edata, Args) -> - gstk_generic:event(DB, Gstkid, Etype, Edata, Args). - -%%------------------------------------------------------------------------------ -%% MANDATORY FUNCTIONS -%%------------------------------------------------------------------------------ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : option/4 -%% Purpose : Take care of options -%% Args : Option - An option tuple -%% Gstkid - The gstkid of the widget -%% TkW - The tk-widget -%% DB - The Database -%% -%% Return : A tuple {OptionType, OptionCmd} -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -option(Option, Gstkid, TkW, DB,_) -> - case Option of - {activebw, Int} -> {s, [" -activebo ", gstk:to_ascii(Int)]}; - {disabledfg, Color} -> {s, [" -disabledf ", gstk:to_color(Color)]}; - {selectcolor, Color} -> {s, [" -selectc ", gstk:to_color(Color)]}; - {post_at, {X,Y}} -> post_at(X,Y,Gstkid,TkW,DB); - _ -> invalid_option - end. - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : read_option/5 -%% Purpose : Take care of a read option -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% Option - An option -%% -%% Return : The value of the option or invalid_option -%% [OptionValue | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -read_option(Option, Gstkid, TkW, _DB, _AItem) -> - case Option of - activebw -> tcl2erl:ret_int([TkW," cg -activebo"]); - disabledfg -> tcl2erl:ret_color([TkW," cg -disabledfo"]); - selectcolor -> tcl2erl:ret_color([TkW," cg -selectc"]); - _ -> {error,{invalid_option,Option, Gstkid#gstkid.objtype}} - end. - -post_at(X,Y,Gstkid,TkW,DB) -> - Pgstkid = gstk_db:lookup_gstkid(DB, Gstkid#gstkid.parent), - PtkW = Pgstkid#gstkid.widget, - RootX = tcl2erl:ret_int(["winfo rootx ",PtkW]), - RootY = tcl2erl:ret_int(["winfo rooty ",PtkW]), - {c,[" tk_popup ",TkW," ",gstk:to_ascii(RootX+X)," ",gstk:to_ascii(RootY+Y)]}. - - -%%----------------------------------------------------------------------------- -%% PRIMITIVES -%%----------------------------------------------------------------------------- -%%---------------------------------------------------------------------- -%% gstk_db functions for menuitem handling -%% Tk menuitems are numbered from 0, thus we have to recalc the position. -%%---------------------------------------------------------------------- -insert_menuitem(DB, MenuId, ItemId, Pos) -> - Mgstkid = gstk_db:lookup_gstkid(DB, MenuId), - Items = Mgstkid#gstkid.widget_data, - NewItems = insert_at(ItemId, Pos+1, Items), - gstk_db:update_widget(DB, Mgstkid#gstkid{widget_data=NewItems}). - - -delete_menuitem(DB, MenuId, ItemId) -> - Mgstkid = gstk_db:lookup_gstkid(DB, MenuId), - Items = Mgstkid#gstkid.widget_data, - NewItems = lists:delete(ItemId, Items), - gstk_db:insert_widget(DB, Mgstkid#gstkid{widget_data=NewItems}). - - -lookup_menuitem_pos(_DB, Mgstkid, ItemId) -> - Items = Mgstkid#gstkid.widget_data, - find_pos(ItemId, Items) - 1. - -%%---------------------------------------------------------------------- -%% Generic list processing -%%---------------------------------------------------------------------- -find_pos(ItemId, Items) -> - find_pos(ItemId, Items, 1). - -find_pos(_ItemId, [], _N) -> gs:error("Couldn't find item in menu~n", []); -find_pos(ItemId, [ItemId|_Items], N) -> N; -find_pos(ItemId, [_|Items], N) -> - find_pos(ItemId, Items, N + 1). - -insert_at(Elem, 1, L) -> [Elem | L]; -insert_at(Elem, N, [H|T]) -> - [H|insert_at(Elem, N-1, T)]. - -%% ----- Done ----- diff --git a/lib/gs/src/gstk_menubar.erl b/lib/gs/src/gstk_menubar.erl deleted file mode 100644 index 9916f64e00..0000000000 --- a/lib/gs/src/gstk_menubar.erl +++ /dev/null @@ -1,176 +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% -%% - -%% -%% ------------------------------------------------------------ -%% Basic Menubar Type -%% ------------------------------------------------------------ - --module(gstk_menubar). - -%%------------------------------------------------------------------------------ -%% MENUBAR OPTIONS -%% -%% Attributes: -%% bg Color -%% bw Int -%% data Data -%% height Int -%% highlightbg Color -%% highlightbw Int -%% highlightfg Color -%% relief Relief [flat|raised|sunken|ridge|groove] -%% -%% Commands: -%% setfocus [Bool | {Bool, Data}] -%% -%% Events: -%% buttonpress [Bool | {Bool, Data}] -%% buttonrelease [Bool | {Bool, Data}] -%% configure [Bool | {Bool, Data}] -%% destroy [Bool | {Bool, Data}] -%% enter [Bool | {Bool, Data}] -%% focus [Bool | {Bool, Data}] -%% keypress [Bool | {Bool, Data}] -%% keyrelease [Bool | {Bool, Data}] -%% leave [Bool | {Bool, Data}] -%% motion [Bool | {Bool, Data}] -%% -%% Read Options: -%% children -%% id -%% parent -%% type -%% -%% Not Implemented: -%% align How -%% - --export([create/3,config/3,read/3,delete/2,event/5,option/5,read_option/5, - mk_create_opts_for_child/4]). - --include("gstk.hrl"). - -%%----------------------------------------------------------------------------- -%% MANDATORY INTERFACE FUNCTIONS -%%----------------------------------------------------------------------------- -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : create/7 -%% Purpose : Create a widget of the type defined in this module. -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -create(DB, GstkId, Opts) -> - TkW = gstk_generic:mk_tkw_child(DB,GstkId), - MPreCmd = ["frame ", TkW], - PlaceCmd = [";place ", TkW], - Ngstkid = GstkId#gstkid{widget=TkW}, - case gstk_generic:make_command(Opts, Ngstkid,TkW, MPreCmd, PlaceCmd, DB) of - {error,Reason} -> {error,Reason}; - Cmd when is_list(Cmd) -> - gstk:exec([Cmd,";pack ", TkW, " -side top -fill x;"]), - Ngstkid - end. - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : config/3 -%% Purpose : Configure a widget of the type defined in this module. -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% Opts - A list of options for configuring the widget -%% -%% Return : [true | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -config(DB, Gstkid, Opts) -> - TkW = Gstkid#gstkid.widget, - SimplePreCmd = [TkW, " conf"], - PlacePreCmd = ["place ", TkW], - gstk_generic:mk_cmd_and_exec(Opts,Gstkid,TkW,SimplePreCmd,PlacePreCmd,DB). - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : read/3 -%% Purpose : Read one option from a widget -%% Args : Opt - An option to read -%% Return : [OptionValue | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -read(DB, Gstkid, Opt) -> - gstk_generic:read_option(DB, Gstkid, Opt). - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : delete/2 -%% Purpose : Delete widget from databas and return tkwidget to destroy -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% -%% Return : TkWidget to destroy -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -delete(DB, Gstkid) -> - gstk_db:delete_widget(DB, Gstkid), - Gstkid#gstkid.widget. - -event(DB, Gstkid, Etype, Edata, Args) -> - gstk_generic:event(DB, Gstkid, Etype, Edata, Args). - -mk_create_opts_for_child(DB,Cgstkid, Pgstkid, Opts) -when Cgstkid#gstkid.objtype==menubutton -> - case gstk_db:lookup_def(Pgstkid,menubutton,bg) of - false -> - MbarTkW=Pgstkid#gstkid.widget, - Color=tcl2erl:ret_color([MbarTkW," cg -bg"]), - gstk_db:insert_def(Pgstkid,menubutton,{bg,Color}); - _ -> done - end, - gstk_generic:mk_create_opts_for_child(DB,Cgstkid,Pgstkid,Opts). - - -%%----------------------------------------------------------------------------- -%% MANDATORY FUNCTIONS -%%----------------------------------------------------------------------------- -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : option/4 -%% Purpose : Take care of options -%% Args : Option - An option tuple -%% TkW - The tk-widget -%% Return : A tuple {OptionType, OptionCmd} -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -option(Option,_Gstkid,_TkW,_DB,_) -> - case Option of - {bg, Color} -> {s, [" -bg ", gstk:to_color(Color)]}; - {height, Height} -> {s, [" -height ", gstk:to_ascii(Height)]}; - _ -> invalid_option - end. - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : read_option/5 -%% Purpose : Take care of a read option -%% Return : The value of the option or invalid_option -%% [OptionValue | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -read_option(Option,GstkId,TkW,_DB,_) -> - case Option of - bg -> tcl2erl:ret_color([TkW," cg -bg"]); - height -> tcl2erl:ret_int(["update idletasks;winfo he ",TkW]); - _ -> {bad_result, {GstkId#gstkid.objtype, invalid_option, Option}} - end. - - -%% ----- Done ----- - - diff --git a/lib/gs/src/gstk_menubutton.erl b/lib/gs/src/gstk_menubutton.erl deleted file mode 100644 index 3f51a9df99..0000000000 --- a/lib/gs/src/gstk_menubutton.erl +++ /dev/null @@ -1,238 +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% -%% - -%% -%% ------------------------------------------------------------ -%% Basic Menubutton Type -%% ------------------------------------------------------------ - --module(gstk_menubutton). - -%%------------------------------------------------------------------------------ -%% MENUBUTTON OPTIONS -%% -%% Attributes: -%% activebg Color -%% activefg Color -%% align n,w,s,e,nw,se,ne,sw,center -%% anchor n,w,s,e,nw,se,ne,sw,center -%% bg Color -%% bw Int -%% data Data -%% disabledfg Color -%% fg Color -%% font Font -%% height Int -%% highlightbg Color -%% highlightbw Int -%% highlightfg Color -%% justify left|right|center (multiline text only) -%% label {text, String} | {image, BitmapFile} -%% padx Int (Pixels) -%% pady Int (Pixels) -%% relief Relief [flat|raised| sunken | ridge | groove] -%% side left | right (valid only in menubars) -%% underline Int -%% width Int -%% wraplength Int -%% x Int (not valid in menubars) -%% y Int (not valid in menubars) -%% -%% Commands: -%% enable Bool -%% setfocus Bool -%% -%% Events: -%% buttonpress [Bool | {Bool, Data}] -%% buttonrelease [Bool | {Bool, Data}] -%% configure [Bool | {Bool, Data}] -%% destroy [Bool | {Bool, Data}] -%% enter [Bool | {Bool, Data}] -%% focus [Bool | {Bool, Data}] -%% keypress [Bool | {Bool, Data}] -%% keyrelease [Bool | {Bool, Data}] -%% leave [Bool | {Bool, Data}] -%% motion [Bool | {Bool, Data}] -%% -%% Read Options: -%% children -%% id -%% parent -%% type -%% -%% Not Implemented: -%% activate ?????? (kontra enable, true) -%% state ?????? -%% cursor ?????? -%% image ?????? -%% focus ?????? (-takefocus) -%% - --export([create/3,config/3,read/3,delete/2,event/5,option/5,read_option/5, - mk_create_opts_for_child/4]). - --include("gstk.hrl"). - -%%----------------------------------------------------------------------------- -%% MANDATORY INTERFACE FUNCTIONS -%%----------------------------------------------------------------------------- -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : create/7 -%% Purpose : Create a widget of the type defined in this module. -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -create(DB, GstkId, Opts) -> - TkW = gstk_generic:mk_tkw_child(DB,GstkId), - NGstkId=GstkId#gstkid{widget=TkW}, - PlacePreCmd = [";place ", TkW], - case gstk_generic:make_command(Opts, NGstkId, TkW, "", PlacePreCmd, DB) of - {error,Reason} -> {error,Reason}; - Cmd when is_list(Cmd) -> - gstk:exec(["menubutton ", TkW," -padx 4 -pady 3",Cmd]), - NGstkId - end. - -mk_create_opts_for_child(DB,Cgstkid, Pgstkid, Opts) -> - gstk_generic:mk_create_opts_for_child(DB,Cgstkid,Pgstkid,Opts). - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : config/3 -%% Purpose : Configure a widget of the type defined in this module. -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% Opts - A list of options for configuring the widget -%% -%% Return : [true | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -config(DB, Gstkid, Opts) -> - TkW = Gstkid#gstkid.widget, - SimplePreCmd = [TkW, " conf"], - PlacePreCmd = [";place ", TkW], - gstk_generic:mk_cmd_and_exec(Opts,Gstkid,TkW,SimplePreCmd,PlacePreCmd,DB). - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : read/3 -%% Purpose : Read one option from a widget -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% Opt - An option to read -%% -%% Return : [OptionValue | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -read(DB, Gstkid, Opt) -> - gstk_generic:read_option(DB, Gstkid, Opt). - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : delete/2 -%% Purpose : Delete widget from databas and return tkwidget to destroy -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% -%% Return : TkWidget to destroy -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -delete(DB, Gstkid) -> - gstk_db:delete_widget(DB, Gstkid), - Gstkid#gstkid.widget. - -event(DB, Gstkid, Etype, Edata, Args) -> - gstk_generic:event(DB, Gstkid, Etype, Edata, Args). - -%%----------------------------------------------------------------------------- -%% MANDATORY FUNCTIONS -%%----------------------------------------------------------------------------- -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : option/4 -%% Purpose : Take care of options -%% Args : Option - An option tuple -%% Gstkid - The gstkid of the widget -%% TkW - The tk-widget -%% DB - The Database -%% -%% Return : A tuple {OptionType, OptionCmd} -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -option(Option, Gstkid, TkW, DB,_) -> - case Option of - {anchor, How} -> fix_anchor(How, Gstkid, TkW, DB); - {disabledfg, Color} -> {s, [" -disabledf ", gstk:to_color(Color)]}; - {height, Height} -> {s, [" -he ", gstk:to_ascii(Height)]}; - {side, Side} -> fix_side(Side, Gstkid, TkW, DB); - {underline, Int} -> {s, [" -und ", gstk:to_ascii(Int)]}; - {width, Width} -> {s, [" -wi ", gstk:to_ascii(Width)]}; - {wraplength, Int} -> {s, [" -wr ", gstk:to_ascii(Int)]}; - {x, X} -> fix_placement(x, X, Gstkid, TkW, DB); - {y, Y} -> fix_placement(y, Y, Gstkid, TkW, DB); - _ -> invalid_option - end. - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : read_option/3 -%% Purpose : Take care of a read option -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% Option - An option -%% -%% Return : The value of the option or invalid_option -%% [OptionValue | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -read_option(Option,GstkId,TkW,_DB,_) -> - case Option of - anchor -> tcl2erl:ret_place(anchor, TkW); - disabledfg -> tcl2erl:ret_color([TkW," cg -disabledfo"]); - height -> tcl2erl:ret_int([TkW," cg -he"]); - side -> tcl2erl:ret_pack(side, TkW); - underline -> tcl2erl:ret_int([TkW," cg -underl"]); - width -> tcl2erl:ret_int([TkW," cg -wi"]); - wraplength -> tcl2erl:ret_int([TkW," cg -wr"]); - x -> tcl2erl:ret_place(x, TkW); - y -> tcl2erl:ret_place(y, TkW); - _ -> {error,{invalid_option,Option, GstkId#gstkid.objtype}} - end. - -%%----------------------------------------------------------------------------- -%% PRIMITIVES -%%----------------------------------------------------------------------------- - -fix_placement(Attr, Value, Gstkid, _TkW, DB) -> - Pgstkid = gstk_db:lookup_gstkid(DB, Gstkid#gstkid.parent), - case Pgstkid#gstkid.objtype of - menubar -> invalid_option; - _ -> {p, [" -", atom_to_list(Attr), " ", gstk:to_ascii(Value)]} - end. - - -fix_anchor(How, Gstkid, TkW, DB) -> - Pgstkid = gstk_db:lookup_gstkid(DB, Gstkid#gstkid.parent), - case Pgstkid#gstkid.objtype of - menubar -> {c, ["pack ", TkW, " -an ", gstk:to_ascii(How)]}; - _ -> {p, [" -anch ", gstk:to_ascii(How)]} - end. - - -fix_side(Side, Gstkid, TkW, DB) -> - Pgstkid = gstk_db:lookup_gstkid(DB, Gstkid#gstkid.parent), - case Pgstkid#gstkid.objtype of - menubar -> {c, ["pack ", TkW, " -fill y -si ", gstk:to_ascii(Side)]}; - _ -> none - end. - - -%% ----- Done ----- - diff --git a/lib/gs/src/gstk_menuitem.erl b/lib/gs/src/gstk_menuitem.erl deleted file mode 100644 index 968568a9a7..0000000000 --- a/lib/gs/src/gstk_menuitem.erl +++ /dev/null @@ -1,584 +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% -%% - -%% -%% ------------------------------------------------------------ -%% Basic Menuitem Type -%% ------------------------------------------------------------ - --module(gstk_menuitem). --compile([{nowarn_deprecated_function,{gs,error,2}}]). - -%%----------------------------------------------------------------------------- -%% MENUITEM OPTIONS -%% -%% Attribute: -%% accelerator String -%% activebg Color -%% activefg Color -%% bg Color -%% color Color (same as fg) -%% data Data -%% fg Color -%% font Font -%% group Atom (valid only for radio type) -%% index Int -%% itemtype normal|check|radio|separator|cascade (|tearoff) -%% label {text, String} | {image, BitmapFile} -%% menu Menu (valid only for cascade type) -%% selectbg Color -%% underline Int -%% value Atom -%% -%% Commands: -%% activate -%% enable Bool -%% invoke -%% -%% Events: -%% click [Bool | {Bool, Data}] -%% -%% Read Options: -%% children -%% id -%% parent -%% type -%% -%% Not Implemented: -%% font Font -%% read menu on cascades -%% - --export([create/3, config/3, read/3, delete/2, destroy/3, event/5, - option/5,read_option/5,mk_create_opts_for_child/4]). --include("gstk.hrl"). - -%%----------------------------------------------------------------------------- -%% MANDATORY INTERFACE FUNCTIONS -%%----------------------------------------------------------------------------- -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : create/3 -%% Purpose : Create a widget of the type defined in this module. -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -create(DB, GstkId, Opts) -> - #gstkid{parent=Parent,owner=Owner,id=Id}=GstkId, - Pgstkid = gstk_db:lookup_gstkid(DB, Parent), - TkMenu = Pgstkid#gstkid.widget, - Widget = "", - {Index, Type, Options} = parse_opts(Opts, TkMenu), - PreCmd = [TkMenu, " insert ", gstk:to_ascii(Index)], - InsertArgs = [DB, Parent,Id, Index], - case Type of - check -> - {G, GID, NOpts} = fix_group(Options, DB, Owner), - TypeCmd = " ch", - Ngstkid=GstkId#gstkid{widget=Widget,widget_data={Type, G, GID}}, - GenArgs = [NOpts,Ngstkid,TkMenu,"","",DB,{Type,Index}], - CallArgs = [PreCmd,TypeCmd], - mk_it(GenArgs,CallArgs,InsertArgs,Ngstkid); - radio -> - {G, GID, V, NOpts} = fix_group_and_value(Options, DB, Owner), - Ngstkid=GstkId#gstkid{widget=Widget, widget_data={Type,G,GID,V}}, - TypeCmd = " ra", - GenArgs = [NOpts,Ngstkid,TkMenu,"", "",DB,{Type,Index}], - CallArgs = [PreCmd,TypeCmd], - mk_it(GenArgs,CallArgs,InsertArgs,Ngstkid); - _ -> - Ngstkid=GstkId#gstkid{widget=Widget, widget_data=Type}, - TypeCmd = case Type of - normal -> " co"; - separator -> " se"; - cascade -> " ca" - end, - GenArgs = [Options,Ngstkid,TkMenu,"","",DB,{Type,Index}], - CallArgs = [PreCmd,TypeCmd], - mk_it(GenArgs,CallArgs,InsertArgs,Ngstkid) - end. - -mk_it(GenArgs,CallArgs,InsertArgs,Ngstkid) -> - case apply(gstk_generic,make_command,GenArgs) of - {error,Reason} -> {error,Reason}; - Cmd when is_list(Cmd) -> - case apply(gstk,call,[[CallArgs|Cmd]]) of - {result,_} -> - apply(gstk_menu,insert_menuitem,InsertArgs), - Ngstkid; - Bad_Result -> {error,Bad_Result} - end - end. - -mk_create_opts_for_child(DB,Cgstkid, Pgstkid, Opts) -> - gstk_generic:mk_create_opts_for_child(DB,Cgstkid,Pgstkid,Opts). - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : config/3 -%% Purpose : Configure a widget of the type defined in this module. -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% Options - A list of options for configuring the widget -%% -%% Return : [true | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -% FIXME: Could we really trust Index? If we create a menu and put one -% entry in the middle of the meny, don't the entrys after that one -% renumber? - -config(DB, Gstkid, Options) -> - Parent = Gstkid#gstkid.parent, - Pgstkid = gstk_db:lookup_gstkid(DB, Parent), - TkMenu = Pgstkid#gstkid.widget, - case Gstkid#gstkid.widget_data of - {Type, _, _, _} -> - Owner = Gstkid#gstkid.owner, - {NOpts, NGstkid} = fix_group_and_value(Options, DB, Owner, Gstkid), - Index = gstk_menu:lookup_menuitem_pos(DB, Pgstkid, NGstkid#gstkid.id), - PreCmd = [TkMenu, " entryco ", gstk:to_ascii(Index)], - gstk_generic:mk_cmd_and_exec(NOpts,NGstkid,TkMenu,PreCmd,"",DB, - {Type,Index}); - {Type, _, _} -> - Owner = Gstkid#gstkid.owner, - {NOpts, NGstkid} = fix_group(Options, DB, Owner, Gstkid), - Index = gstk_menu:lookup_menuitem_pos(DB, Pgstkid, NGstkid#gstkid.id), - PreCmd = [TkMenu, " entryco ", gstk:to_ascii(Index)], - gstk_generic:mk_cmd_and_exec(NOpts,NGstkid,TkMenu,PreCmd,"",DB, - {Type,Index}); - Type -> - Index = gstk_menu:lookup_menuitem_pos(DB, Pgstkid, Gstkid#gstkid.id), - PreCmd = [TkMenu, " entryco ", gstk:to_ascii(Index)], - gstk_generic:mk_cmd_and_exec(Options,Gstkid,TkMenu,PreCmd,"", - DB, {Type,Index}) - end. - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : read/3 -%% Purpose : Read one option from a widget -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% Opt - An option to read -%% -%% Return : [OptionValue | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -read(DB, Gstkid, Opt) -> - gstk_generic:read_option(DB, Gstkid, Opt). - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : delete/2 -%% Purpose : Delete widget from databas and return tkwidget to destroy -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% -%% Return : TkWidget to destroy -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -delete(DB, Gstkid) -> - Parent = Gstkid#gstkid.parent, - Id = Gstkid#gstkid.id, - gstk_db:delete_widget(DB, Gstkid), - case Gstkid#gstkid.widget_data of - {radio, _, Gid, _} -> gstk_db:delete_bgrp(DB, Gid); - {check, _, Gid} -> gstk_db:delete_bgrp(DB, Gid); - _Other -> true - end, - {Parent, Id, gstk_menuitem, [Id, Parent]}. - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : destroy/3 -%% Purpose : Destroy a widget -%% Args : Menu - The menu tk widget -%% Item - The index of the menuitem to destroy -%% Return : [true | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -destroy(DB, Id, Parent) -> - Pgstkid = gstk_db:lookup_gstkid(DB, Parent), - PW = Pgstkid#gstkid.widget, - Idx = gstk_menu:lookup_menuitem_pos(DB, Pgstkid, Id), - gstk_menu:delete_menuitem(DB, Parent, Id), - gstk:exec([PW, " delete ", gstk:to_ascii(Idx)]). - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : event/5 -%% Purpose : Construct the event and send it to the owner of the widget -%% Args : Etype - The event type -%% Edata - The event data -%% Args - The data from tcl/tk -%% -%% Return : [true | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -event(DB, Gstkid, Etype, Edata, Args) -> - Arg2 = - case Gstkid#gstkid.widget_data of - {radio, G, _GID, V} -> - [_Grp, Text, Idx | Args1] = Args, - [Text, Idx, G, V | Args1]; - {check, G, _Gid} -> - [Bool, Text, Idx | Args1] = Args, - RBool = case Bool of - 0 -> false; - 1 -> true - end, - [Text, Idx, G, RBool | Args1]; - _Other2 -> - Args - end, - gstk_generic:event(DB, Gstkid, Etype, Edata, Arg2). - - - -%%----------------------------------------------------------------------------- -%% MANDATORY FUNCTIONS -%%----------------------------------------------------------------------------- -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : option/4 -%% Purpose : Take care of options -%% Args : Option - An option tuple -%% TkW - The tk-widget -%% Return : A tuple {OptionType, OptionCmd} -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -option({click,true}, _Gstkid, _TkW, _DB, {separator,_Index}) -> - none; % workaround to be able to have {click,true} as default. -option(_Option, _Gstkid, _TkW, _DB, {separator,_Index}) -> - invalid_option; - -option({menu,{Menu,_RestOfExternalId}}, _Gstkid, _TkW, DB, {cascade,_Index}) -> - Mgstkid = gstk_db:lookup_gstkid(DB, Menu), - MenuW = Mgstkid#gstkid.widget, - {s, [" -menu ", MenuW]}; - -option({select,false}, _Gstkid, TkW, _DB, {check,Index}) -> - {c, ["set x [", TkW, " entrycg ", gstk:to_ascii(Index), - " -var];global $x;set $x 0"]}; -option({select,true}, _Gstkid, TkW, _DB, {check,Index}) -> - {c, ["set x [", TkW, " entrycg ", gstk:to_ascii(Index), - " -var];global $x;set $x 1"]}; - -option({value,Val}, _Gstkid, _TkW, _DB, {radio,_Index}) -> - {s, [" -val ", gstk:to_ascii(Val)]}; -option({select,false}, _Gstkid, TkW, _DB, {radio,Index}) -> - {c, ["set x [", TkW, " entrycg ", gstk:to_ascii(Index), - " -var];global $x;set $x {}"]}; -option({select,true}, _Gstkid, TkW, _DB, {radio,Index}) -> - {c, ["set x [", TkW, " entrycg ", gstk:to_ascii(Index), - " -var]; set y [", TkW, " entrycg ", gstk:to_ascii(Index), - " -val]; global $x; set $x $y"]}; - -option(Option, Gstkid, TkW, DB, {Kind,Index}) -> - case Option of - activate -> {c, [TkW, " act ", gstk:to_ascii(Index)]}; - invoke -> {c, [TkW, " inv ", gstk:to_ascii(Index)]}; - {accelerator, Acc} -> {s, [" -acc ", gstk:to_ascii(Acc)]}; - {click, On} -> cbind(On, Gstkid, TkW, Index, Kind, DB); - {font, Font} when is_tuple(Font) -> - gstk_db:insert_opt(DB,Gstkid,Option), - {s, [" -font ", gstk_font:choose_ascii(DB,Font)]}; - {label, {image,Img}} -> {s, [" -bitm @", Img, " -lab {}"]}; - % FIXME: insert -command here..... - % FIXME: how to get value from image entry??? - {label, {text,Text}} -> {s, [" -lab ",gstk:to_ascii(Text)," -bitm {}"]}; - {underline, Int} -> {s, [" -underl ", gstk:to_ascii(Int)]}; - {activebg, Color} -> {s, [" -activeba ", gstk:to_color(Color)]}; - {activefg, Color} -> {s, [" -activefo ", gstk:to_color(Color)]}; - {bg, Color} -> {s, [" -backg ", gstk:to_color(Color)]}; - {enable, true} -> {s, " -st normal"}; - {enable, false} -> {s, " -st disabled"}; - {fg, Color} -> {s, [" -foreg ", gstk:to_color(Color)]}; - _Other -> - case lists:member(Kind,[radio,check]) of - true -> - case Option of - {group,Group} -> {s, [" -var ", gstk:to_ascii(Group)]}; - {selectbg,Col} -> {s,[" -selectc ",gstk:to_color(Col)]}; - _ -> invalid_option - end; - _ -> invalid_option - end - end. - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : read_option/5 -%% Purpose : Take care of a read option -%% Return : The value of the option or invalid_option -%% [OptionValue | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -read_option(Option,GstkId,_TkW,DB,_) -> - ItemId = GstkId#gstkid.id, - MenuId = GstkId#gstkid.parent, - MenuGstkid = gstk_db:lookup_gstkid(DB, MenuId), - MenuW = MenuGstkid#gstkid.widget, - Idx = gstk_menu:lookup_menuitem_pos(DB, MenuGstkid, ItemId), - PreCmd = [MenuW, " entrycg ", gstk:to_ascii(Idx)], - case Option of - accelerator -> tcl2erl:ret_str([PreCmd, " -acc"]); - activebg -> tcl2erl:ret_color([PreCmd, " -activeba"]); - activefg -> tcl2erl:ret_color([PreCmd, " -activefo"]); - bg -> tcl2erl:ret_color([PreCmd, " -backg"]); - fg -> tcl2erl:ret_color([PreCmd, " -foreg"]); - group -> read_group(GstkId, Option); - groupid -> read_groupid(GstkId, Option); - index -> Idx; - itemtype -> case GstkId#gstkid.widget_data of - {Type, _, _, _} -> Type; - {Type, _, _} -> Type; - Type -> Type - end; - enable -> tcl2erl:ret_enable([PreCmd, " -st"]); - font -> gstk_db:opt(DB,GstkId,font,undefined); - label -> tcl2erl:ret_label(["list [", PreCmd, " -lab] [", - PreCmd, " -bit]"]); - selectbg -> tcl2erl:ret_color([PreCmd, " -selectco"]); - underline -> tcl2erl:ret_int([PreCmd, " -underl"]); - value -> tcl2erl:ret_atom([PreCmd, " -val"]); - select -> read_select(MenuW, Idx, GstkId); - click -> gstk_db:is_inserted(DB, GstkId, click); - _ -> {bad_result, {GstkId#gstkid.objtype, invalid_option, Option}} - end. - -read_group(Gstkid, Option) -> - case Gstkid#gstkid.widget_data of - {_, G, _, _} -> G; - {_, G, _} -> G; - _Other -> {bad_result,{Gstkid#gstkid.objtype, invalid_option, Option}} - end. - -read_groupid(Gstkid, Option) -> - case Gstkid#gstkid.widget_data of - {_, _, Gid, _} -> Gid; - {_, _, Gid} -> Gid; - _Other -> {bad_result,{Gstkid#gstkid.objtype, invalid_option, Option}} - end. - - - - -read_select(TkMenu, Idx, Gstkid) -> - case Gstkid#gstkid.widget_data of - {radio, _, _, _} -> - Cmd = ["list [set x [", TkMenu, " entrycg ", gstk:to_ascii(Idx), - " -var];global $x;set $x] [", TkMenu, - " entrycg ", gstk:to_ascii(Idx)," -val]"], - case tcl2erl:ret_tuple(Cmd) of - {X, X} -> true; - _Other -> false - end; - {check, _, _} -> - Cmd = ["set x [", TkMenu, " entrycg ", gstk:to_ascii(Idx), - " -var];global $x;set $x"], - tcl2erl:ret_bool(Cmd); - _Other -> - {error,{invalid_option,menuitem,select}} - end. - - - -%%----------------------------------------------------------------------------- -%% PRIMITIVES -%%----------------------------------------------------------------------------- - -%% create version -fix_group_and_value(Opts, DB, Owner) -> - {G, GID, V, NOpts} = fgav(Opts, erlNIL, erlNIL, erlNIL, []), - RV = case V of - erlNIL -> - list_to_atom(lists:concat([v,gstk_db:counter(DB,value)])); - Other0 -> Other0 - end, - NG = case G of - erlNIL -> mrb; - Other1 -> Other1 - end, - RGID = case GID of - erlNIL -> {mrbgrp, NG, Owner}; - Other2 -> Other2 - end, - RG = gstk_db:insert_bgrp(DB, RGID), - {NG, RGID, RV, [{group, RG}, {value, RV} | NOpts]}. - -%% config version -fix_group_and_value(Opts, DB, Owner, Gstkid) -> - {Type, RG, RGID, RV} = Gstkid#gstkid.widget_data, - {G, GID, V, NOpts} = fgav(Opts, RG, RGID, RV, []), - case {G, GID, V} of - {RG, RGID, RV} -> - {NOpts, Gstkid}; - {NG, RGID, RV} -> - NGID = {rbgrp, NG, Owner}, - gstk_db:delete_bgrp(DB, RGID), - NRG = gstk_db:insert_bgrp(DB, NGID), - NGstkid = Gstkid#gstkid{widget_data={Type,NG,NGID,RV}}, - gstk_db:insert_widget(DB, NGstkid), - {[{group, NRG} | NOpts], NGstkid}; - {RG, RGID, NRV} -> - NGstkid = Gstkid#gstkid{widget_data={Type,RG,RGID,NRV}}, - gstk_db:insert_widget(DB, NGstkid), - {[{value,NRV} | NOpts], NGstkid}; - {_, NGID, RV} when NGID =/= RGID -> - gstk_db:delete_bgrp(DB, RGID), - NRG = gstk_db:insert_bgrp(DB, NGID), - NGstkid = Gstkid#gstkid{widget_data={Type,RG,NGID,RV}}, - gstk_db:insert_widget(DB, NGstkid), - {[{group, NRG} | NOpts], NGstkid}; - {_, NGID, NRV} when NGID =/= RGID -> - gstk_db:delete_bgrp(DB, RGID), - NRG = gstk_db:insert_bgrp(DB, NGID), - NGstkid = Gstkid#gstkid{widget_data={Type,RG,NGID,NRV}}, - gstk_db:insert_widget(DB, NGstkid), - {[{group, NRG}, {value,NRV} | NOpts], NGstkid}; - {NG, RGID, NRV} -> - NGID = {rbgrp, NG, Owner}, - gstk_db:delete_bgrp(DB, RGID), - NRG = gstk_db:insert_bgrp(DB, NGID), - NGstkid = Gstkid#gstkid{widget_data={Type,NG,NGID,NRV}}, - gstk_db:insert_widget(DB, NGstkid), - {[{group, NRG}, {value,NRV} | NOpts], NGstkid} - end. - - - -fgav([{group, G} | Opts], _, GID, V, Nopts) -> - fgav(Opts, G, GID, V, Nopts); - -fgav([{groupid, GID} | Opts], G, _, V, Nopts) -> - fgav(Opts, G, GID, V, Nopts); - -fgav([{value, V} | Opts], G, GID, _, Nopts) -> - fgav(Opts, G, GID, V, Nopts); - -fgav([Opt | Opts], G, GID, V, Nopts) -> - fgav(Opts, G, GID, V, [Opt | Nopts]); - -fgav([], Group, GID, Value, Opts) -> - {Group, GID, Value, Opts}. - - -%% check button version -%% create version -fix_group(Opts, DB, Owner) -> - {G, GID, NOpts} = fg(Opts, erlNIL, erlNIL, []), - NG = case G of - erlNIL -> - Vref = gstk_db:counter(DB, variable), - list_to_atom(lists:flatten(["mcb", gstk:to_ascii(Vref)])); - Other1 -> Other1 - end, - RGID = case GID of - erlNIL -> {mcbgrp, NG, Owner}; - Other2 -> Other2 - end, - RG = gstk_db:insert_bgrp(DB, RGID), - {NG, RGID, [{group, RG} | NOpts]}. - -%% config version -fix_group(Opts, DB, Owner, Gstkid) -> - {Type, RG, RGID} = Gstkid#gstkid.widget_data, - {G, GID, NOpts} = fg(Opts, RG, RGID, []), - case {G, GID} of - {RG, RGID} -> - {NOpts, Gstkid}; - {NG, RGID} -> - NGID = {cbgrp, NG, Owner}, - gstk_db:delete_bgrp(DB, RGID), - NRG = gstk_db:insert_bgrp(DB, NGID), - NGstkid = Gstkid#gstkid{widget_data={Type,NG,NGID}}, - gstk_db:insert_widget(DB, NGstkid), - {[{group, NRG} | NOpts], NGstkid}; - {_, NGID} when NGID =/= RGID -> - gstk_db:delete_bgrp(DB, RGID), - NRG = gstk_db:insert_bgrp(DB, NGID), - NGstkid = Gstkid#gstkid{widget_data={Type,RG,NGID}}, - gstk_db:insert_widget(DB, NGstkid), - {[{group, NRG} | NOpts], NGstkid} - end. - - - -fg([{group, G} | Opts], _, GID, Nopts) -> - fg(Opts, G, GID, Nopts); - -fg([{groupid, GID} | Opts], G, _, Nopts) -> - fg(Opts, G, GID, Nopts); - -fg([Opt | Opts], G, GID, Nopts) -> - fg(Opts, G, GID, [Opt | Nopts]); - -fg([], Group, GID, Opts) -> - {Group, GID, Opts}. - - - -parse_opts(Opts, TkMenu) -> - parse_opts(Opts, TkMenu, none, none, []). - - -parse_opts([Option | Rest], TkMenu, Idx, Type, Options) -> - case Option of - {index, I} -> parse_opts(Rest, TkMenu, I, Type, Options); - {itemtype, T} -> parse_opts(Rest, TkMenu, Idx, T, Options); - _Other -> parse_opts(Rest, TkMenu, Idx, Type,[Option | Options]) - end; -parse_opts([], TkMenu, Index, Type, Options) -> - RealIdx = - case Index of - Idx when is_integer(Idx) -> Idx; - last -> find_last_index(TkMenu); - Other -> gs:error("Invalid index ~p~n",[Other]) - end, - {RealIdx, Type, Options}. - -find_last_index(TkMenu) -> - case tcl2erl:ret_int([TkMenu, " index last"]) of - Last when is_integer(Last) -> Last+1; - none -> 0; - Other -> gs:error("Couldn't find index ~p~n",[Other]) - end. - -cbind({true, Edata}, Gstkid, TkMenu, Index, Type, DB) -> - Eref = gstk_db:insert_event(DB, Gstkid, click, Edata), - IdxStr = gstk:to_ascii(Index), - case Type of - normal -> - Cmd = [" -command {erlsend ", Eref, - " \\\"[",TkMenu," entrycg ",IdxStr," -label]\\\" ", - IdxStr,"}"], - {s, Cmd}; - check -> - Cmd = [" -command {erlsend ", Eref, - " \[expr \$[", TkMenu, " entrycg ",IdxStr," -var]\] \\\"[", - TkMenu, " entrycg ",IdxStr," -label]\\\" ",IdxStr,"}"], - {s, Cmd}; - radio -> - Cmd = [" -command {erlsend ", Eref, - " [", TkMenu, " entrycg ",IdxStr," -var] \\\"[", - TkMenu, " entrycg ",IdxStr," -label]\\\" ",IdxStr,"}"], - {s, Cmd}; - _Other -> - none - end; - -cbind({false, _}, Gstkid, _TkMenu, _Index, _Type, DB) -> - gstk_db:delete_event(DB, Gstkid, click), - none; - -cbind(On, Gstkid, TkMenu, Index, Type, DB) when is_atom(On) -> - cbind({On, []}, Gstkid, TkMenu, Index, Type, DB). - - -%%% ----- Done ----- - diff --git a/lib/gs/src/gstk_oval.erl b/lib/gs/src/gstk_oval.erl deleted file mode 100644 index 8e06378c0b..0000000000 --- a/lib/gs/src/gstk_oval.erl +++ /dev/null @@ -1,189 +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% -%% - -%% -%% ------------------------------------------------------------ -%% Basic Oval Type -%% ------------------------------------------------------------ - --module(gstk_oval). - -%%----------------------------------------------------------------------------- -%% OVAL OPTIONS -%% -%% Options: -%% bw Int -%% coords [{X1,Y1}, {X2,Y2}] -%% data Data -%% fg Color -%% fill Color -%% stipple Bool -%% -%% Commands: -%% lower -%% move {Dx, Dy} -%% raise -%% scale {Xo, Yo, Sx, Sy} -%% setfocus Bool -%% -%% Events: -%% buttonpress [Bool | {Bool, Data}] -%% buttonrelease [Bool | {Bool, Data}] -%% enter [Bool | {Bool, Data}] -%% keypress [Bool | {Bool, Data}] -%% keyrelease [Bool | {Bool, Data}] -%% leave [Bool | {Bool, Data}] -%% motion [Bool | {Bool, Data}] -%% -%% Read Options: -%% children -%% id -%% parent -%% type -%% -%% Not Implemented: -%% - --export([create/3, config/3, read/3, delete/2, destroy/3, event/5, - option/5,read_option/5]). - --include("gstk.hrl"). - -%%----------------------------------------------------------------------------- -%% MANDATORY INTERFACE FUNCTIONS -%%----------------------------------------------------------------------------- -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : create/3 -%% Purpose : Create a widget of the type defined in this module. -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -create(DB, Gstkid, Opts) -> - case gstk_canvas:pickout_coords(Opts, [],oval,2) of - {error, Error} -> - {bad_result, Error}; - {Coords, NewOpts} -> - Ngstkid=gstk_canvas:upd_gstkid(DB, Gstkid, Opts), - #gstkid{widget=CanvasTkW}=Ngstkid, - MCmd = [CanvasTkW, " create ov ", Coords], - gstk_canvas:mk_cmd_and_call(NewOpts,Ngstkid, CanvasTkW, MCmd, DB) - end. - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : config/3 -%% Purpose : Configure a widget of the type defined in this module. -%% Return : [true | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -config(DB, Gstkid, Opts) -> - gstk_canvas:item_config(DB, Gstkid, Opts). - - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : read/3 -%% Purpose : Read one option from a widget -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% Opt - An option to read -%% -%% Return : [OptionValue | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -read(DB, Gstkid, Opt) -> - Item = Gstkid#gstkid.widget_data, - gstk_generic:read_option(DB,Gstkid,Opt,[gstk:to_ascii(Item)]). - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : delete/2 -%% Purpose : Delete widget from databas and return tkwidget to destroy -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% -%% Return : TkWidget to destroy | {Parent, Objmod, Args}. -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -delete(DB, Gstkid) -> - gstk_canvas:item_delete_impl(DB,Gstkid). - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : destroy/3 -%% Purpose : Destroy a widget -%% Args : DB - The Database -%% Canvas - The canvas tk widget -%% Item - The item number to destroy -%% -%% Return : [true | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -destroy(_DB, Canvas, Item) -> - gstk:exec([Canvas, " delete ", gstk:to_ascii(Item)]). - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : event/5 -%% Purpose : Construct the event and send it to the owner of the widget -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% Etype - The event type -%% Edata - The event data -%% Args - The data from tcl/tk -%% -%% Return : [true | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -event(DB, Gstkid, Etype, Edata, Args) -> - gstk_generic:event(DB, Gstkid, Etype, Edata, Args). - - -%%----------------------------------------------------------------------------- -%% MANDATORY FUNCTIONS -%%----------------------------------------------------------------------------- -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : option/5 -%% Purpose : Take care of options -%% Args : Option - An option tuple -%% Gstkid - The gstkid of the widget -%% MainW - The main tk-widget -%% Return : A tuple {OptionType, OptionCmd} -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -option(Option, _Gstkid, _Canvas, _DB, _AItem) -> - case Option of - {fg, Color} -> {s, [" -outline ", gstk:to_color(Color)]}; - {bw, Int} -> {s, [" -w ", gstk:to_ascii(Int)]}; - _ -> invalid_option - end. - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : read_option/5 -%% Purpose : Take care of a read option -%% Args : DB - The Database -%% Option - An option -%% -%% Return : The value of the option or invalid_option -%% [OptionValue | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -read_option(Option, Gstkid, Canvas, _DB, AItem) -> - case Option of - bw -> tcl2erl:ret_int([Canvas, " itemcg ", AItem, " -w"]); - fg -> tcl2erl:ret_color([Canvas, " itemcg ", AItem," -outline"]); - stipple -> tcl2erl:ret_stipple([Canvas," itemcg ",AItem," -stipple"]); - _ -> {bad_result, {Gstkid#gstkid.objtype, invalid_option, Option}} - end. - - - -%% ----- Done ----- - diff --git a/lib/gs/src/gstk_polygon.erl b/lib/gs/src/gstk_polygon.erl deleted file mode 100644 index 013682d353..0000000000 --- a/lib/gs/src/gstk_polygon.erl +++ /dev/null @@ -1,196 +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% -%% - -%% -%% ------------------------------------------------------------ -%% Basic Polygon Type -%% ------------------------------------------------------------ - --module(gstk_polygon). - - -%%----------------------------------------------------------------------------- -%% POLYGON OPTIONS -%% -%% Attributes: -%% bw Int -%% coords [{X1,Y1}, {X2,Y2} | {Xn,Yn}] -%% data Data -%% fg Color -%% fill Color -%% smooth Bool -%% splinesteps Int -%% stipple Bool -%% -%% Commands: -%% lower -%% move {Dx, Dy} -%% raise -%% scale {Xo, Yo, Sx, Sy} -%% setfocus Bool -%% -%% Events: -%% buttonpress [Bool | {Bool, Data}] -%% buttonrelease [Bool | {Bool, Data}] -%% enter [Bool | {Bool, Data}] -%% keypress [Bool | {Bool, Data}] -%% keyrelease [Bool | {Bool, Data}] -%% leave [Bool | {Bool, Data}] -%% motion [Bool | {Bool, Data}] -%% -%% Read Options: -%% children -%% id -%% parent -%% type -%% - --export([create/3, config/3, read/3, delete/2, destroy/3, event/5, - option/5,read_option/5]). - --include("gstk.hrl"). - -%%----------------------------------------------------------------------------- -%% MANDATORY INTERFACE FUNCTIONS -%%----------------------------------------------------------------------------- -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : create/7 -%% Purpose : Create a widget of the type defined in this module. -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -create(DB, Gstkid, Opts) -> - case pickout_coords(Opts, []) of - {error, Error} -> - {bad_result, Error}; - {Coords, NewOpts} -> - Ngstkid=gstk_canvas:upd_gstkid(DB, Gstkid, Opts), - #gstkid{widget=CanvasTkW}=Ngstkid, - MCmd = [CanvasTkW, " create po ", Coords], - gstk_canvas:mk_cmd_and_call(NewOpts, Ngstkid,CanvasTkW, MCmd, DB) - end. - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : config/3 -%% Purpose : Configure a widget of the type defined in this module. -%% Return : [true | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -config(DB, Gstkid, Opts) -> - gstk_canvas:item_config(DB, Gstkid, Opts). - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : read/3 -%% Purpose : Read one option from a widget -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% Opt - An option to read -%% -%% Return : [OptionValue | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -read(DB, Gstkid, Opt) -> - Item = Gstkid#gstkid.widget_data, - gstk_generic:read_option(DB,Gstkid,Opt,[gstk:to_ascii(Item)]). - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : delete/2 -%% Purpose : Delete widget from databas and return tkwidget to destroy -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% -%% Return : TkWidget to destroy | {Parent, Objmod, Args}. -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -delete(DB, Gstkid) -> - gstk_canvas:item_delete_impl(DB,Gstkid). - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : destroy/3 -%% Purpose : Destroy a widget -%% Args : DB - The Database -%% Canvas - The canvas tk widget -%% Item - The item number to destroy -%% -%% Return : [true | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -destroy(_DB, Canvas, Item) -> - gstk:exec([Canvas, " delete ", gstk:to_ascii(Item)]). - - -event(DB, Gstkid, Etype, Edata, Args) -> - gstk_generic:event(DB, Gstkid, Etype, Edata, Args). - -%%----------------------------------------------------------------------------- -%% MANDATORY FUNCTIONS -%%----------------------------------------------------------------------------- -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : option/5 -%% Purpose : Take care of options -%% Args : Option - An option tuple -%% Gstkid - The gstkid of the widget -%% MainW - The main tk-widget -%% Canvas - The canvas tk-widget -%% DB - The Database -%% -%% Return : A tuple {OptionType, OptionCmd} -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -option(Option, _Gstkid, _Canvas, _DB, _AItem) -> - case Option of - {fg, Color} -> {s, [" -outline ", gstk:to_color(Color)]}; - {bw, Int} -> {s, [" -w ", gstk:to_ascii(Int)]}; - {smooth, Bool} -> {s, [" -sm ", gstk:to_ascii(Bool)]}; - {splinesteps, Int} -> {s, [" -sp ", gstk:to_ascii(Int)]}; - _ -> invalid_option - end. - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : read_option/5 -%% Purpose : Take care of a read option -%% Return : The value of the option or invalid_option -%% [OptionValue | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -read_option(Option, Gstkid, Canvas, _DB, AItem) -> - case Option of - bw -> tcl2erl:ret_int([Canvas, " itemcg ", AItem, " -w"]); - fg -> - tcl2erl:ret_color([Canvas, " itemcg ", AItem, " -outline"]); - smooth -> tcl2erl:ret_bool([Canvas, " itemcg ", AItem, " -sm"]); - splinesteps -> tcl2erl:ret_int([Canvas, " itemcg ", AItem, " -sp"]); - stipple -> - tcl2erl:ret_stipple([Canvas," itemcg ",AItem," -stipple"]); - - _ -> {bad_result, {Gstkid#gstkid.objtype, invalid_option, Option}} - end. - -%%----------------------------------------------------------------------------- -%% PRIMITIVES -%%----------------------------------------------------------------------------- - -pickout_coords([{coords,Coords} | Rest], Opts) when length(Coords) >= 2 -> - case gstk_canvas:coords(Coords) of - invalid -> - {error, "A polygon must have at least four coordinates"}; - RealCoords -> - {RealCoords, lists:append(Rest, Opts)} - end; -pickout_coords([Opt | Rest], Opts) -> - pickout_coords(Rest, [Opt|Opts]); -pickout_coords([], _Opts) -> - {error, "A polygon must have at least four coordinates"}. -%% ----- Done ----- - diff --git a/lib/gs/src/gstk_port_handler.erl b/lib/gs/src/gstk_port_handler.erl deleted file mode 100644 index fee3dc7dac..0000000000 --- a/lib/gs/src/gstk_port_handler.erl +++ /dev/null @@ -1,467 +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% -%% - -%% -%% ------------------------------------------------------------ -%% -%% This is a driver for the 'gstk' application modified to -%% handle events for gs. 'gstk' is a modified standalone wish. -%% -%% FIXME -%% mkdir tcl ; cd tcl -%% ( cd /usr/local/pgm/tcl-8.3.3 ; tar -cf - * ) | tar -xf - -%% ( cd /usr/local/pgm/tk-8.3.3 ; tar -cf - * ) | tar -xf - -%% rm -fr include man bin/tclsh -%% cd .. -%% tar -cf tcl.tar * -%% -%% ------------------------------------------------------------ - --module(gstk_port_handler). --compile([{nowarn_deprecated_function,{gs,error,2}}]). - --include("gstk.hrl"). - -% The executable can have many names. There is not always -% a plain "wish" program. -% FIXME There has to be a better solution.... -% FIXME Add option in app file or environmen variable. - --define(WISHNAMES, ["wish85","wish8.5", - "wish84","wish8.4", - "wish83","wish8.3", - "wish82","wish8.2", - "wish"]). - -%% ------------------------------------------------------------ -%% DEBUG FUNCTIONS -%% ------------------------------------------------------------ --export([exec/1,call/2, - start_link/1,init/2,ping/1,stop/1]). --export([wait_for_connection/2]). - --define(START_TIMEOUT , 1000 * 30). --define(ACCEPT_TIMEOUT, 1000 * 20). - --define(DEBUGLEVEL, 4). - --ifdef(DEBUG). - --define(DBG(DbgLvl,Format, Data),dbg(DbgLvl, Format, Data)). --define(DBG_STR(DbgLvl, What, Str),dbg_str(DbgLvl, What, Str)). - -dbg(DbgLvl, Format, Data) when DbgLvl =< ?DEBUGLEVEL -> - ok = io:format("DBG: " ++ Format, Data); -dbg(_DbgLvl, _Format, _Data) -> ok. - -dbg_str(DbgLvl, What, Str) when DbgLvl =< ?DEBUGLEVEL -> - ok = io:format("DBG: ~s~s\n", [What,dbg_s(Str)]); -dbg_str(_DbgLvl, _What, _Data) -> ok. - -dbg_s([]) -> - []; -dbg_s([C | Str]) when list(C) -> - [dbg_s(C) | dbg_s(Str)]; -dbg_s([C | Str]) when C >= 20, C < 255 -> - [C | dbg_s(Str)]; -dbg_s([$\n | Str]) -> - ["\\n" | dbg_s(Str)]; -dbg_s([$\r | Str]) -> - ["\\r" | dbg_s(Str)]; -dbg_s([$\t | Str]) -> - ["\\t" | dbg_s(Str)]; -dbg_s([C | Str]) when integer(C) -> - [io_lib:format("\\~.3.0w",[C]) | dbg_s(Str)]. - --else. - --define(DBG(DbgLvl,Format, Data), true). --define(DBG_STR(DbgLvl, What, Str), true). - --endif. - -%% ------------------------------------------------------------ -%% INTERFACE FUNCTIONS -%% ------------------------------------------------------------ - -% Note: gs is not a true application so this doesn't work :-( -% Communication protocol between Erlang backend and wish program -% that can be set in the application environment, e.i. tested -% with "erl -gs backend_comm socket" -% -% backend_comm = socket | port -% -% We fake reading the application variables from the command line. -% Note that multiple -gs arguments can't be used. - -get_env(App, KeyAtom) -> - KeyStr = atom_to_list(KeyAtom), - ?DBG(1,"Result from init:get_argument(~w): ~p\n", - [KeyAtom,init:get_argument(App)]), - case init:get_argument(App) of - {ok,[[KeyStr,ValStr]]} -> - {ok,list_to_atom(ValStr)}; - _ -> - undefined - end. - -start_link(Gstk) -> - ?DBG(1, "start_link(~w)~n", [Gstk]), -% io:format("STARTS ~p\n",[erlang:localtime()]), - Mode = - % FIXME: Want to use application:get_env() if we where an true app - case {os:type(),get_env(gs,backend_comm)} of - {{win32,_Flavor},undefined} -> - use_socket; - {_OS,undefined} -> - use_port; - {_OS,{ok,socket}} -> - use_socket; - {_OS,{ok,port}} -> - use_port - end, - ?DBG(1,"We use mode: ~w (~w)\n",[Mode,get_env(gs,backend_comm)]), - Pid = spawn_link(gstk_port_handler, init, [Gstk,Mode]), - receive - {Pid, ok} -> - {ok, Pid}; - {Pid, error, Reason} -> - {error, Reason} - after ?START_TIMEOUT -> - {error, timeout} - end. - -call(PortHandler, Cmd) -> - PortHandler ! {call, ["erlcall {",Cmd,$}]}, - receive - {result, Result} -> - ?DBG(1, "call reply: ~p~n", [Result]), - {result, Result}; - {bad_result, Bad_Result} -> - ?DBG(1, "bad call reply: ~p~n", [Bad_Result]), - {bad_result, Bad_Result} - end. - -ping(PortHandler) -> - ?DBG(1, "ping~n", []), - PortHandler ! {ping, self()}, - receive - {pong,_From,PortOrSock} -> {ok,PortOrSock} - end. - -stop(PortHandler) -> - ?DBG(1, "stop~n", []), - PortHandler ! {stop,self()}, - receive - {stopped,PortHandler} -> ok - end. - -%% Purpose: asyncron call to tk -%% too expensive -% FIXME -exec(Cmd) -> - get(port_handler) ! {exec, ["erlexec {",Cmd,$}]}, - ok. - -% in gstk context, but I don't want "ifndef nt40" in other -% modules than this one. -%exec(Cmd) -> -% ?DBG_STR(1, "", ["erlexec {",Cmd,"}"]), -% case get(port) of -% {socket,Sock} -> -% gen_tcp:send(Sock, ["erlexec {",Cmd,$}]); -% {port,Port} -> -% Port ! {get(port_handler),{command,["erlexec {",Cmd,$}]}} -% end, -% ok. - -%% =========================================================================== -%% The server -%% =========================================================================== - -%% --------------------------------------------------------------------- -%% We initiate by starting the wish port program and use the pipe -%% or a socket to communicate with it. -%% -%% gstk: is the pid of the gstk process that started me. -%% all my input (from the port) is forwarded to it. -%%---------------------------------------------------------------------- --record(state,{out,gstk}). - -init(Gstk, Mode) -> - process_flag(trap_exit,true), - - % ------------------------------------------------------------ - % Set up paths - % ------------------------------------------------------------ - - PrivDir = code:priv_dir(gs), - TclDir = filename:join(PrivDir,"tcl"), - TclBinDir = filename:join(TclDir,"bin"), - TclLibDir = filename:join(TclDir,"lib"), - - InitScript = filename:nativename(filename:join(PrivDir,"gstk.tcl")), - - ?DBG(1, "TclBinDir : ~s\n", [TclBinDir]), - ?DBG(1, "TclLibDir : ~s\n", [TclLibDir]), - ?DBG(1, "InitScript : ~s\n", [InitScript]), - - % ------------------------------------------------------------ - % Search for wish in priv and in system search path - % ------------------------------------------------------------ - - {Wish,Options} = - case filelib:wildcard(filename:join(TclBinDir,"wish*")) of - % If more than one wish in priv we assume they are the same - [PrivWish | _] -> - % ------------------------------------------------ - % We have to set TCL_LIBRARY and TK_LIBRARY because else - % 'wish' will search in the original installation directory - % for 'tclIndex' and this may be an incompatible version on - % the host we run on. - % ------------------------------------------------ - - [TclLibrary] = - filelib:wildcard(filename:join(PrivDir, - "tcl/lib/tcl[1-9]*")), - [TkLibrary] = - filelib:wildcard(filename:join(PrivDir, - "tcl/lib/tk[1-9]*")), - - Opts = [{env,[{"TCL_LIBRARY", TclLibrary}, - {"TK_LIBRARY", TkLibrary}, - {"LD_LIBRARY_PATH",TclLibDir}]}, - {packet,4}], - {PrivWish,Opts}; - _ -> - % We use the system wish program - {search_wish(?WISHNAMES, Gstk),[{packet,4}]} - end, - - - ?DBG(1, "Wish : ~s\n", [Wish]), - - Cmd = - case Mode of - use_socket -> - % ------------------------------------------------------------ - % Set up a listening socket and call accept in another process - % ------------------------------------------------------------ - SocketOpts = - [ - {nodelay, true}, - {packet,4}, - {reuseaddr,true} - ], - % Let OS pick a number - {ok,ListenSocket} = gen_tcp:listen(0, SocketOpts), - {ok,ListenPort} = inet:port(ListenSocket), - - % Wait in another process - spawn_link(?MODULE,wait_for_connection,[self(),ListenSocket]), - lists:concat([Wish," ",InitScript," -- ",PrivDir," ", - ListenPort]); - use_port -> - lists:concat([Wish," ",InitScript," -- ",PrivDir]) - end, - - ?DBG(1, "Port opts :\n~p\n", [Options]), - - % FIXME remove timing if not debugging - Port = - case timer:tc(erlang,open_port,[{spawn, Cmd}, Options]) of - {_T,Port1} when is_port(Port1) -> - ?DBG(1,"open_port takes ~p milliseconds\n",[_T/1000]), - link(Port1), - Port1; - {_T,{error,_Reason1}} -> % FIXME: Why throw away reason?! - ?DBG(1,"ERROR: ~p\n",[_Reason1]), - Gstk ! {self(), error, backend_died}, - exit(normal) - end, - - State = - case Mode of - use_socket -> - % ------------------------------------------------------------ - % Wait for a connection - % ------------------------------------------------------------ - Sock = - receive - {connected,Socket} -> - Socket; - % FIXME: Why throw away reason?! - {'EXIT', _Pid, _Reason2} -> - Gstk ! {self(), error, backend_died}, - exit(normal) - end, - - ?DBG(1,"Got socket ~p~n",[Sock]), - #state{out={socket,Sock}, gstk=Gstk}; - use_port -> - #state{out={port,Port}, gstk=Gstk} - end, - - Gstk ! {self(), ok}, % Tell caller we are prepared - idle(State). - -search_wish([], Gstk) -> - Gstk ! {self(), error, backend_died}, - exit(normal); -search_wish([WishName | WishNames], Gstk) -> - case os:find_executable(WishName) of - false -> - search_wish(WishNames, Gstk); - Wish -> - Wish - end. - -%%---------------------------------------------------------------------- -%% If we use sockets we wait for connection from port prog -%%---------------------------------------------------------------------- - -wait_for_connection(CallerPid, ListenSocket) -> - {ok,Sock} = gen_tcp:accept(ListenSocket, ?ACCEPT_TIMEOUT), - ?DBG(1,"Got accept ~p~p~n",[self(),Sock]), - ok = gen_tcp:controlling_process(Sock,CallerPid), - CallerPid ! {connected,Sock}. - -%% =========================================================================== -%% The main loop -%% =========================================================================== - -idle(State) -> - ?DBG(1, "idle~n", []), -% io:format("IDLE ~p\n",[erlang:localtime()]), - receive - - {call, Cmd} -> - output(State, Cmd), - idle(State); - - {exec, Cmd} -> - collect_exec_calls(Cmd, [], 0, State), - idle(State); - - {_Port, {data, Input}} -> - ?DBG_STR(2, "INPUT[port]: ", [Input]), - handle_input(State, Input), - idle(State); - - {tcp, _Sock, Input} -> - ?DBG_STR(2, "INPUT[sock]: ", [Input]), - handle_input(State, Input), - idle(State); - - {ping,From} -> - From ! {pong,self(),State#state.out}, - idle(State); - - {stop,From} -> - From ! {stopped,self()}; - - % FIXME: We are we not to terminate if watforsocket - % terminated but what about the port??????? - {'EXIT',_Pid,normal} -> - ?DBG(1, "EXIT[~w]: normal~n", [_Pid]), - idle(State); - - {'EXIT',Pid,Reason} -> - %%io:format("Port died when in idle loop!~n"), - ?DBG(1,"EXIT[~w]~n~p~n",[Pid,Reason]), - exit({port_handler,Pid,Reason}); - - Other -> - ?DBG(1,"OTHER: ~p~n",[Other]), - gs:error("gstk_port_handler: got other: ~w~n",[Other]), - idle(State) - end. - -%% ---------------------------------------------------------------------- - --define(MAXQUEUE, 4). % FIXME find value... - -collect_exec_calls(Cmd, Queue, QueueLen, State) when QueueLen < ?MAXQUEUE -> - receive - {exec, NewCmd} -> -% io:format("collect~p~n", [NewCmd]), - collect_exec_calls(NewCmd, [Cmd | Queue], QueueLen+1, State) - after 0 -> - if - QueueLen == 0 -> - output(State, Cmd); - true -> - output(State, join_cmd_reverse(Cmd, Queue, [])) - end - end; -collect_exec_calls(Cmd, Queue, _QueueLen, State) -> % Queue is full, output - String = join_cmd_reverse(Cmd, Queue, []), -% io:format("queue full: ~p~n", [String]), - output(State, String). - - -join_cmd_reverse(Cmd, [], DeepStr) -> - [DeepStr | Cmd]; -join_cmd_reverse(Cmd, [Cmd1 | Cmds], DeepStr) -> - join_cmd_reverse(Cmd, Cmds, [Cmd1,$; | DeepStr]). - -%% ---------------------------------------------------------------------- -%% -%% Handle incoming data -%% 1 - Event -%% 2 - Reply from call -%% 3 - Bad reply from call -%% 4 - Error -%% 5 - End of message -%% - -handle_input(State,[Type | Data]) -> - GstkPid = State#state.gstk, - case Type of - 1 -> - handle_event(GstkPid,Data); - - 2 -> - GstkPid ! {result, Data}; - - 3 -> - GstkPid ! {bad_result, Data}; - - 4 -> - gs:error("gstk_port_handler: error in input : ~s~n",[Data]) - end. - -%% ---------------------------------------------------------------------- -%% output a command to the port -%% buffer several incoming execs -%% -output(#state{out = {socket,Sock}}, Cmd) -> - ?DBG_STR(1, "OUTPUT[sock]: ", [Cmd]), - ok = gen_tcp:send(Sock, Cmd); - -output(#state{out = {port,Port}}, Cmd) -> - ?DBG_STR(1, "OUTPUT[port]: ", [Cmd]), - Port ! {self(), {command, Cmd}}. - -% FIXME why test list? -handle_event(GstkPid, Bytes) when is_list(Bytes) -> - Event = tcl2erl:parse_event(Bytes), - ?DBG(1,"Event = ~p\n",[Event]), - gstk:event(GstkPid, Event). %% Event is {ID, Etag, Args} diff --git a/lib/gs/src/gstk_radiobutton.erl b/lib/gs/src/gstk_radiobutton.erl deleted file mode 100644 index a778f46038..0000000000 --- a/lib/gs/src/gstk_radiobutton.erl +++ /dev/null @@ -1,343 +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% -%% - -%% -%% ------------------------------------------------------------ -%% Basic Radiobutton Type -%% ------------------------------------------------------------ - --module(gstk_radiobutton). - -%%------------------------------------------------------------------------------ -%% RADIOBUTTON OPTIONS -%% -%% Attributes: -%% activebg Color -%% activefg Color -%% align n,w,s,e,nw,se,ne,sw,center -%% anchor n,w,s,e,nw,se,ne,sw,center -%% bg Color -%% bw Int -%% data Data -%% disabledfg Color -%% enable Bool -%% fg Color -%% group Atom -%% groupid Groupid -%% height Int -%% highlightbg Color -%% highlightbw Int -%% highlightfg Color -%% justify left|right|center -%% label {text, String} | {image, BitmapFile} -%% padx Int (Pixels) -%% pady Int (Pixels) -%% relief Relief [flat|raised|sunken|ridge|groove] -%% selectbg Color -%% underline Int -%% value Atom -%% width Int -%% wraplength Int -%% x Int -%% y Int -%% -%% Commands: -%% flash -%% invoke -%% select Bool -%% setfocus Bool -%% -%% Events: -%% buttonpress [Bool | {Bool, Data}] -%% buttonrelease [Bool | {Bool, Data}] -%% click [Bool | {Bool, Data}] -%% configure [Bool | {Bool, Data}] -%% destroy [Bool | {Bool, Data}] -%% enter [Bool | {Bool, Data}] -%% focus [Bool | {Bool, Data}] -%% keypress [Bool | {Bool, Data}] -%% keyrelease [Bool | {Bool, Data}] -%% leave [Bool | {Bool, Data}] -%% motion [Bool | {Bool, Data}] -%% -%% Read Options: -%% children -%% id -%% parent -%% type -%% -%% Not Implemented: -%% cursor ?????? -%% focus ?????? (-takefocus) -%% font ?????? -%% - --export([create/3,config/3,read/3,delete/2,event/5,option/5,read_option/5]). - --include("gstk.hrl"). - -%%------------------------------------------------------------------------------ -%% MANDATORY INTERFACE FUNCTIONS -%%------------------------------------------------------------------------------ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : create/3 -%% Purpose : Create a widget of the type defined in this module. -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -create(DB, GstkId, Opts) -> - TkW = gstk_generic:mk_tkw_child(DB,GstkId), - {G, GID, V, NOpts} = fix_group_and_value(Opts, DB, GstkId#gstkid.owner), - NGstkId=GstkId#gstkid{widget=TkW,widget_data={G, GID, V}}, - PlacePreCmd = [";place ", TkW], - case gstk_generic:make_command(NOpts, NGstkId, TkW, "", PlacePreCmd, DB) of - {error,Reason} -> {error,Reason}; - Cmd when is_list(Cmd) -> - gstk:exec(["radiobutton ", TkW," -bo 2 -indi true ",Cmd]), - NGstkId - end. - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : config/3 -%% Purpose : Configure a widget of the type defined in this module. -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% Opts - A list of options for configuring the widget -%% -%% Return : [true | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -config(DB, Gstkid, Opts) -> - TkW = Gstkid#gstkid.widget, - {NOpts, NGstkid} = fix_group_and_value(Opts, DB, Gstkid#gstkid.owner, Gstkid), - SimplePreCmd = [TkW, " conf"], - PlacePreCmd = [";place ", TkW], - gstk_generic:mk_cmd_and_exec(NOpts,NGstkid,TkW,SimplePreCmd,PlacePreCmd,DB). - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : read/3 -%% Purpose : Read one option from a widget -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% Opt - An option to read -%% -%% Return : [OptionValue | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -read(DB, Gstkid, Opt) -> - gstk_generic:read_option(DB, Gstkid, Opt). - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : delete/2 -%% Purpose : Delete widget from databas and return tkwidget to destroy -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% -%% Return : TkWidget to destroy -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -delete(DB, Gstkid) -> - gstk_db:delete_widget(DB, Gstkid), - {_, Gid, _} = Gstkid#gstkid.widget_data, - gstk_db:delete_bgrp(DB, Gid), - Gstkid#gstkid.widget. - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : event/5 -%% Purpose : Construct the event and send it to the owner of the widget -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% Etype - The event type -%% Edata - The event data -%% Args - The data from tcl/tk -%% -%% Return : [true | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -event(DB, Gstkid, Etype, Edata, Args) -> - Arg2 = case Etype of - click -> - [Text, _Grp | Rest] = Args, - {G, _Gid, V} = Gstkid#gstkid.widget_data, - [Text, G, V | Rest]; - _Other -> - Args - end, - gstk_generic:event(DB, Gstkid, Etype, Edata, Arg2). - - - -%%------------------------------------------------------------------------------ -%% MANDATORY FUNCTIONS -%%------------------------------------------------------------------------------ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : option/4 -%% Purpose : Take care of options -%% Args : Option - An option tuple -%% Gstkid - The gstkid of the widget -%% TkW - The tk-widget -%% DB - The Database -%% -%% Return : A tuple {OptionType, OptionCmd} -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -option(Option, Gstkid, TkW, DB,_) -> - case Option of - {disabledfg, Color} -> {s, [" -disabledforegr ", gstk:to_color(Color)]}; - {group, Group} -> {s, [" -var ", gstk:to_ascii(Group)]}; - {selectbg, Color} -> {s, [" -selectc ", gstk:to_color(Color)]}; - {underline, Int} -> {s, [" -un ", gstk:to_ascii(Int)]}; - {value, V} -> {s, [" -val ", gstk:to_ascii(V)]}; - {wraplength, Int} -> {s, [" -wr ", gstk:to_ascii(Int)]}; - flash -> {c, [TkW, " f;"]}; - invoke -> {c, [TkW, " i;"]}; - {select, true} -> {c, [TkW, " se;"]}; - {select, false} -> {c, [TkW, " des;"]}; - {click, On} -> cbind(DB, Gstkid, click, On); - _ -> invalid_option - end. - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : read_option/4 -%% Purpose : Take care of a read option -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% Option - An option -%% -%% Return : The value of the option or invalid_option -%% [OptionValue | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -read_option(Option,Gstkid, TkW,DB,_) -> - case Option of - disabledfg -> tcl2erl:ret_color([TkW," cg -disabledforegr"]); - group -> {G, _, _} = Gstkid#gstkid.widget_data, G; - groupid -> {_, Gid, _} = Gstkid#gstkid.widget_data, Gid; - selectbg -> tcl2erl:ret_color([TkW," cg -selectc"]); - underline -> tcl2erl:ret_int([TkW," cg -un"]); - value -> {_, _, V} = Gstkid#gstkid.widget_data, V; - wraplength -> tcl2erl:ret_int([TkW," cg -wr"]); - - select -> - Cmd = ["list [set x [",TkW," cg -var];global $x;set $x] [", - TkW," cg -val]"], - case tcl2erl:ret_tuple(Cmd) of - {X, X} -> true; - _Other -> false - end; - - click -> gstk_db:is_inserted(DB, Gstkid, click); - _ -> {bad_result, {Gstkid#gstkid.objtype, invalid_option, Option}} - end. - -%%------------------------------------------------------------------------------ -%% PRIMITIVES -%%------------------------------------------------------------------------------ - -%% create version -fix_group_and_value(Opts, DB, Owner) -> - {G, GID, V, NOpts} = fgav(Opts, erlNIL, erlNIL, erlNIL, []), - RV = case V of - erlNIL -> list_to_atom(lists:concat([v,gstk_db:counter(DB,value)])); - Other0 -> Other0 - end, - NG = case G of - erlNIL -> rb; - Other1 -> Other1 - end, - RGID = case GID of - erlNIL -> {rbgrp, NG, Owner}; - Other2 -> Other2 - end, - RG = gstk_db:insert_bgrp(DB, RGID), - {NG, RGID, RV, [{group, RG}, {value, RV} | NOpts]}. - -%% config version -fix_group_and_value(Opts, DB, Owner, Gstkid) -> - {RG, RGID, RV} = Gstkid#gstkid.widget_data, - {G, GID, V, NOpts} = fgav(Opts, RG, RGID, RV, []), - case {G, GID, V} of - {RG, RGID, RV} -> - {NOpts, Gstkid}; - {NG, RGID, RV} -> - NGID = {rbgrp, NG, Owner}, - gstk_db:delete_bgrp(DB, RGID), - NRG = gstk_db:insert_bgrp(DB, NGID), - NGstkid = Gstkid#gstkid{widget_data={NG,NGID,RV}}, - gstk_db:insert_widget(DB, NGstkid), - {[{group, NRG} | NOpts], NGstkid}; - {RG, RGID, NRV} -> - NGstkid = Gstkid#gstkid{widget_data={RG,RGID,NRV}}, - gstk_db:insert_widget(DB, NGstkid), - {[{value,NRV} | NOpts], NGstkid}; - {_, NGID, RV} when NGID =/= RGID -> - gstk_db:delete_bgrp(DB, RGID), - NRG = gstk_db:insert_bgrp(DB, NGID), - NGstkid = Gstkid#gstkid{widget_data={RG,NGID,RV}}, - gstk_db:insert_widget(DB, NGstkid), - {[{group, NRG} | NOpts], NGstkid}; - {_, NGID, NRV} when NGID =/= RGID -> - gstk_db:delete_bgrp(DB, RGID), - NRG = gstk_db:insert_bgrp(DB, NGID), - NGstkid = Gstkid#gstkid{widget_data={RG,NGID,NRV}}, - gstk_db:insert_widget(DB, NGstkid), - {[{group, NRG}, {value,NRV} | NOpts], NGstkid}; - {NG, RGID, NRV} -> - NGID = {rbgrp, NG, Owner}, - gstk_db:delete_bgrp(DB, RGID), - NRG = gstk_db:insert_bgrp(DB, NGID), - NGstkid = Gstkid#gstkid{widget_data={NG,NGID,NRV}}, - gstk_db:insert_widget(DB, NGstkid), - {[{group, NRG}, {value,NRV} | NOpts], NGstkid} - end. - - - -fgav([{group, G} | Opts], _, GID, V, Nopts) -> - fgav(Opts, G, GID, V, Nopts); - -fgav([{groupid, GID} | Opts], G, _, V, Nopts) -> - fgav(Opts, G, GID, V, Nopts); - -fgav([{value, V} | Opts], G, GID, _, Nopts) -> - fgav(Opts, G, GID, V, Nopts); - -fgav([Opt | Opts], G, GID, V, Nopts) -> - fgav(Opts, G, GID, V, [Opt | Nopts]); - -fgav([], Group, GID, Value, Opts) -> - {Group, GID, Value, Opts}. - -%% -%% Config bind -%% -cbind(DB, Gstkid, Etype, On) -> - TkW = Gstkid#gstkid.widget, - Cmd = case On of - {true, Edata} -> - Eref = gstk_db:insert_event(DB, Gstkid, Etype, Edata), - [" -command {erlsend ", Eref, - " \\\"[", TkW, " cg -text]\\\" [", TkW, " cg -var]}"]; - true -> - Eref = gstk_db:insert_event(DB, Gstkid, Etype, ""), - [" -command {erlsend ", Eref, - " \\\"[", TkW, " cg -text]\\\" [", TkW, " cg -var]}"]; - _Other -> - gstk_db:delete_event(DB, Gstkid, Etype), - " -command {}" - end, - {s, Cmd}. - -%% ----- Done ----- - diff --git a/lib/gs/src/gstk_rectangle.erl b/lib/gs/src/gstk_rectangle.erl deleted file mode 100644 index 21e2a06cb4..0000000000 --- a/lib/gs/src/gstk_rectangle.erl +++ /dev/null @@ -1,186 +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% -%% - -%% -%% ------------------------------------------------------------ -%% Basic Rectangle Type -%% ------------------------------------------------------------ - --module(gstk_rectangle). --compile([{nowarn_deprecated_function,{gs,pair,2}}]). - -%%----------------------------------------------------------------------------- -%% RECTANGLE OPTIONS -%% -%% Attributes: -%% bw Int -%% coords [{X1,Y1}, {X2,Y2}] -%% data Data -%% fg Color -%% fill Color -%% stipple Bool -%% -%% Commands: -%% lower -%% move {Dx, Dy} -%% raise -%% scale {Xo, Yo, Sx, Sy} -%% setfocus Bool -%% -%% Events: -%% buttonpress [Bool | {Bool, Data}] -%% buttonrelease [Bool | {Bool, Data}] -%% enter [Bool | {Bool, Data}] -%% keypress [Bool | {Bool, Data}] -%% keyrelease [Bool | {Bool, Data}] -%% leave [Bool | {Bool, Data}] -%% motion [Bool | {Bool, Data}] -%% -%% Read Options: -%% children -%% id -%% parent -%% type -%% - - --export([create/3, config/3, read/3, delete/2, destroy/3, event/5, - option/5,read_option/5]). - --include("gstk.hrl"). - -%%----------------------------------------------------------------------------- -%% MANDATORY INTERFACE FUNCTIONS -%%----------------------------------------------------------------------------- -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : create/7 -%% Purpose : Create a widget of the type defined in this module. -%% Args : DB - The Database -%% Objmod - An atom, this module -%% Objtype - An atom, the logical widget type -%% Owner - Pid of the creator -%% Name - An atom naming the widget -%% Parent - Gsid of the parent -%% Opts - A list of options for configuring the widget -%% -%% Return : [Gsid_of_new_widget | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -create(DB,Gstkid, Opts) -> - case gstk_canvas:pickout_coords(Opts, [],rectangle,2) of - {error, Error} -> - {bad_result, Error}; - {Coords, NewOpts} -> - gstk_db:insert_opt(DB,Gstkid,gs:pair(coords,Opts)), - Ngstkid=gstk_canvas:upd_gstkid(DB, Gstkid, Opts), - #gstkid{widget=CanvasTkW}=Ngstkid, - MCmd = [CanvasTkW, " create re ", Coords], - gstk_canvas:mk_cmd_and_call(NewOpts, Ngstkid,CanvasTkW, MCmd, DB) - end. - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : config/3 -%% Purpose : Configure a widget of the type defined in this module. -%% Return : [true | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -config(DB, Gstkid, Opts) -> - gstk_canvas:item_config(DB, Gstkid, Opts). - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : read/3 -%% Purpose : Read one option from a widget -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% Opt - An option to read -%% -%% Return : [OptionValue | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -read(DB, Gstkid, Opt) -> - Item = Gstkid#gstkid.widget_data, - gstk_generic:read_option(DB,Gstkid,Opt,[gstk:to_ascii(Item)]). - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : delete/2 -%% Purpose : Delete widget from databas and return tkwidget to destroy -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% -%% Return : TkWidget to destroy | {Parent, Objmod, Args}. -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -delete(DB, Gstkid) -> - gstk_canvas:item_delete_impl(DB,Gstkid). - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : destroy/3 -%% Purpose : Destroy a widget -%% Args : DB - The Database -%% Canvas - The canvas tk widget -%% Item - The item number to destroy -%% -%% Return : [true | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -destroy(_DB, Canvas, Item) -> - gstk:exec([Canvas, " delete ", gstk:to_ascii(Item)]). - - -event(DB, Gstkid, Etype, Edata, Args) -> - gstk_generic:event(DB, Gstkid, Etype, Edata, Args). - -%%------------------------------------------------------------------------------ -%% MANDATORY FUNCTIONS -%%------------------------------------------------------------------------------ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : option/5 -%% Purpose : Take care of options -%% Args : Option - An option tuple -%% Gstkid - The gstkid of the widget -%% MainW - The main tk-widget -%% Canvas - The canvas tk-widget -%% DB - The Database -%% -%% Return : A tuple {OptionType, OptionCmd} -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -option(Option, _Gstkid, _Canvas, _DB, _AItem) -> - case Option of - {bw, Int} -> {s, [" -w ", gstk:to_ascii(Int)]}; - {fg, Color} -> {s, [" -outline ", gstk:to_color(Color)]}; - _ -> invalid_option - end. - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : read_option/5 -%% Purpose : Take care of a read option -%% Args : DB - The Database -%% Option - An option -%% -%% Return : The value of the option or invalid_option -%% [OptionValue | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -read_option(Option, Gstkid, Canvas, _DB, AItem) -> - case Option of - bw -> tcl2erl:ret_int([Canvas, " itemcg ", AItem, " -w"]); - fg -> tcl2erl:ret_color([Canvas," itemcg ", AItem, " -outline"]); - stipple -> - tcl2erl:ret_stipple([Canvas, " itemcg ", AItem, " -stipple"]); - _ -> {bad_result, {Gstkid#gstkid.objtype, invalid_option, Option}} - end. - -%% ----- Done ----- diff --git a/lib/gs/src/gstk_scale.erl b/lib/gs/src/gstk_scale.erl deleted file mode 100644 index 3512304867..0000000000 --- a/lib/gs/src/gstk_scale.erl +++ /dev/null @@ -1,215 +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% -%% - -%% -%% ------------------------------------------------------------ -%% Basic Scale Type -%% ------------------------------------------------------------ - --module(gstk_scale). - -%%------------------------------------------------------------------------- -%% SCALE OPTIONS -%% -%% Attributes: -%% activebg Color -%% anchor n,w,s,e,nw,se,ne,sw,center -%% bg Color -%% bw Int -%% data Data -%% fg Color -%% height Int -%% highlightbg Color -%% highlightbw Int -%% highlightfg Color -%% orient vertical | horizontal -%% range {From, To} -%% relief Relief [flat|raised|sunken|ridge|groove] -%% showvalue Bool -%% text String -%% width Int -%% x Int -%% y Int -%% -%% Commands: -%% enable Bool -%% pos Int -%% setfocus Bool -%% -%% Events: -%% buttonpress [Bool | {Bool, Data}] -%% buttonrelease [Bool | {Bool, Data}] -%% click [Bool | {Bool, Data}] -%% destroy [Bool | {Bool, Data}] -%% enter [Bool | {Bool, Data}] -%% focus [Bool | {Bool, Data}] -%% keypress [Bool | {Bool, Data}] -%% keyrelease [Bool | {Bool, Data}] -%% leave [Bool | {Bool, Data}] -%% motion [Bool | {Bool, Data}] -%% -%% Read Options: -%% children -%% id -%% parent -%% type -%% - --export([create/3,config/3,read/3,delete/2,event/5, - option/5,read_option/5]). - --include("gstk.hrl"). - -%%------------------------------------------------------------------------------ -%% MANDATORY INTERFACE FUNCTIONS -%%------------------------------------------------------------------------------ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : create/7 -%% Purpose : Create a widget of the type defined in this module. -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -create(DB, GstkId, Opts) -> - TkW = gstk_generic:mk_tkw_child(DB,GstkId), - PlacePreCmd = [";place ", TkW], - Ngstkid = GstkId#gstkid{widget=TkW}, - case gstk_generic:make_command(Opts, Ngstkid, TkW,"", PlacePreCmd, DB) of - {error,Reason} -> {error,Reason}; - Cmd when is_list(Cmd) -> - gstk:exec(["scale ", TkW,Cmd,$;,TkW, - " conf -bo 2 -sliderrelief raised -highlightth 2"]), - Ngstkid - end. - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : config/3 -%% Purpose : Configure a widget of the type defined in this module. -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% Opts - A list of options for configuring the widget -%% -%% Return : [true | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -config(DB, Gstkid, Opts) -> - TkW = Gstkid#gstkid.widget, - SimplePreCmd = [TkW, " conf"], - PlacePreCmd = [";place ", TkW], - gstk_generic:mk_cmd_and_exec(Opts,Gstkid,TkW,SimplePreCmd,PlacePreCmd,DB). - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : read/3 -%% Purpose : Read one option from a widget -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% Opt - An option to read -%% -%% Return : [OptionValue | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -read(DB, Gstkid, Opt) -> - gstk_generic:read_option(DB, Gstkid, Opt). - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : delete/2 -%% Purpose : Delete widget from databas and return tkwidget to destroy -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% -%% Return : TkWidget to destroy -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -delete(DB, Gstkid) -> - gstk_db:delete_widget(DB, Gstkid), - Gstkid#gstkid.widget. - -event(DB, Gstkid, Etype, Edata, Args) -> - gstk_generic:event(DB, Gstkid, Etype, Edata, Args). - -%%----------------------------------------------------------------------------- -%% MANDATORY FUNCTIONS -%%----------------------------------------------------------------------------- -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : option/4 -%% Purpose : Take care of options -%% Args : Option - An option tuple -%% TkW - The tk-widget -%% -%% Return : A tuple {OptionType, OptionCmd} -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -option(Option, Gstkid, TkW, DB,_) -> - case Option of - {activebg, Color} -> {s, [" -activeb ", gstk:to_color(Color)]}; - {orient, How} -> {s, [" -or ", gstk:to_ascii(How)]}; - {range, {From, To}} -> {s, [" -fr ", gstk:to_ascii(From), - " -to ", gstk:to_ascii(To)]}; - {relief, Relief} -> {s, [" -rel ", gstk:to_ascii(Relief)]}; - {bw, Wth} -> {s, [" -bd ", gstk:to_ascii(Wth)]}; - {text, String} -> {s, [" -la ",gstk:to_ascii(String)]}; - {showvalue, Bool} -> {s, [" -showvalue ",gstk:to_ascii(Bool)]}; - {pos, Pos} -> {c, [TkW, " set ", gstk:to_ascii(Pos)]}; - {click, On} -> cbind(DB, Gstkid, click, On); - _ -> invalid_option - end. - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : read_option/5 -%% Purpose : Take care of a read option -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% Option - An option -%% -%% Return : The value of the option or invalid_option -%% [OptionValue | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -read_option(Option,Gstkid,TkW,DB,_) -> - case Option of - activebg -> tcl2erl:ret_color([TkW," cg -activeb"]); - orient -> tcl2erl:ret_atom([TkW," cg -ori"]); - range -> - tcl2erl:ret_tuple(["list [",TkW," cg -fr] [",TkW," cg -to]"]); - bw -> tcl2erl:ret_int([TkW," cg -bd"]); - relief -> tcl2erl:ret_atom([TkW, " cg -reli"]); - text -> tcl2erl:ret_str([TkW," cg -lab"]); - showvalue -> tcl2erl:ret_bool([TkW," cg -showvalue"]); - pos -> tcl2erl:ret_int([TkW," get"]); - click -> gstk_db:is_inserted(DB, Gstkid, click); - _ -> {bad_result, {Gstkid#gstkid.objtype, invalid_option, Option}} - end. - -%%----------------------------------------------------------------------------- -%% PRIMITIVES -%%----------------------------------------------------------------------------- - - -%% -%% Config bind -%% -cbind(DB, Gstkid, Etype, On) -> - Cmd = case On of - {true, Edata} -> - Eref = gstk_db:insert_event(DB, Gstkid, Etype, Edata), - [" -command {erlsend ", Eref, "}"]; - true -> - Eref = gstk_db:insert_event(DB, Gstkid, Etype, ""), - [" -command {erlsend ", Eref, "}"]; - _Other -> - gstk_db:delete_event(DB, Gstkid, Etype), - " -command {}" - end, - {s, Cmd}. - -%% ----- Done ----- diff --git a/lib/gs/src/gstk_text.erl b/lib/gs/src/gstk_text.erl deleted file mode 100644 index b931030a3f..0000000000 --- a/lib/gs/src/gstk_text.erl +++ /dev/null @@ -1,190 +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% -%% - -%% -%% ------------------------------------------------------------ -%% Basic Text Type -%% ------------------------------------------------------------ - --module(gstk_text). - -%%----------------------------------------------------------------------------- -%% TEXT OPTIONS -%% -%% Attributes: -%% anchor n|w|e|s|nw|sw|ne|se|center -%% coords [{X,Y}] -%% data Data -%% fg Color -%% font Font -%% justify left | center | right -%% stipple Bool -%% text String -%% width Int (line length in characters) -%% -%% Commands: -%% lower -%% move {Dx, Dy} -%% raise -%% scale {Xo, Yo, Sx, Sy} -%% setfocus Bool -%% -%% Events: -%% buttonpress [Bool | {Bool, Data}] -%% buttonrelease [Bool | {Bool, Data}] -%% enter [Bool | {Bool, Data}] -%% keypress [Bool | {Bool, Data}] -%% keyrelease [Bool | {Bool, Data}] -%% leave [Bool | {Bool, Data}] -%% motion [Bool | {Bool, Data}] -%% -%% Read Options: -%% children -%% id -%% parent -%% type -%% -%% Not Implemented: -%% fontfamily ?????? Family -%% fontsize ?????? Size -%% style ?????? [bold,italic] -%% - --export([create/3, config/3, read/3, delete/2, destroy/3, event/5, - option/5,read_option/5]). - --include("gstk.hrl"). - -%%----------------------------------------------------------------------------- -%% MANDATORY INTERFACE FUNCTIONS -%%---------------------------------------------------------------------------- -create(DB, Gstkid, Opts) -> - case gstk_canvas:pickout_coords(Opts, [],text,1) of - {error, Error} -> - {bad_result, Error}; - {Coords, NewOpts} -> - Ngstkid=gstk_canvas:upd_gstkid(DB, Gstkid, Opts), - #gstkid{widget=CanvasTkW}=Ngstkid, - MCmd = [CanvasTkW, " create te ", Coords], - gstk_canvas:mk_cmd_and_call(NewOpts,Ngstkid,CanvasTkW, MCmd, DB) - end. - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : config/3 -%% Purpose : Configure a widget of the type defined in this module. -%% Return : [true | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -config(DB, Gstkid, Opts) -> - gstk_canvas:item_config(DB, Gstkid, Opts). - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : read/3 -%% Purpose : Read one option from a widget -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% Opt - An option to read -%% -%% Return : [OptionValue | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -read(DB, Gstkid, Opt) -> - Item = Gstkid#gstkid.widget_data, - gstk_generic:read_option(DB,Gstkid,Opt,[gstk:to_ascii(Item)]). - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : delete/2 -%% Purpose : Delete widget from databas and return tkwidget to destroy -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% -%% Return : TkWidget to destroy | {Parent, Objmod, Args}. -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -delete(DB, Gstkid) -> - gstk_canvas:item_delete_impl(DB,Gstkid). - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : destroy/3 -%% Purpose : Destroy a widget -%% Args : DB - The Database -%% Canvas - The canvas tk widget -%% Item - The item number to destroy -%% -%% Return : [true | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -destroy(_DB, Canvas, Item) -> - gstk:exec([Canvas, " delete ", gstk:to_ascii(Item)]). - - -event(DB, Gstkid, Etype, Edata, Args) -> - gstk_generic:event(DB, Gstkid, Etype, Edata, Args). - - -%%----------------------------------------------------------------------------- -%% MANDATORY FUNCTIONS -%%----------------------------------------------------------------------------- -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : option/5 -%% Purpose : Take care of options -%% Args : Option - An option tuple -%% MainW - The main tk-widget -%% -%% Return : A tuple {OptionType, OptionCmd} -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -option(Option, Gstkid, _Canvas, DB, _AItem) -> - case Option of - {anchor, How} -> {s, [" -anchor ", gstk:to_ascii(How)]}; - {fg, Color} -> {s, [" -fi ", gstk:to_color(Color)]}; - {font, Font} when is_tuple(Font) -> - gstk_db:insert_opt(DB,Gstkid,Option), - {s, [" -fo ", gstk_font:choose_ascii(DB,Font)]}; - {justify, How} -> {s, [" -j ", gstk:to_ascii(How)]}; - {text, Text} -> {s, [" -te ", gstk:to_ascii(Text)]}; - {width, Width} -> {s, [" -w ", gstk:to_ascii(Width)]}; - _ -> invalid_option - end. - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : read_option/5 -%% Purpose : Take care of a read option -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% Option - An option -%% -%% Return : The value of the option or invalid_option -%% [OptionValue | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -read_option(Option, Gstkid, Canvas, DB, AItem) -> - case Option of - anchor -> tcl2erl:ret_atom([Canvas, " itemcg ", AItem, " -anchor"]); - fg -> tcl2erl:ret_color([Canvas, " itemcg ", AItem, " -fi"]); - font -> gstk_db:opt(DB,Gstkid,font,undefined); - justify -> tcl2erl:ret_atom([Canvas, " itemcg ", AItem, " -j"]); - stipple -> tcl2erl:ret_stipple([Canvas," itemcg ",AItem," -stipple"]); - text -> tcl2erl:ret_str([Canvas, " itemcg ", AItem, " -te"]); - width -> tcl2erl:ret_int([Canvas, " itemcg ", AItem, " -w"]); - _ -> {bad_result, {Gstkid#gstkid.objtype, invalid_option, Option}} - end. - - -%% ----- Done ----- diff --git a/lib/gs/src/gstk_widgets.erl b/lib/gs/src/gstk_widgets.erl deleted file mode 100644 index 52c955af50..0000000000 --- a/lib/gs/src/gstk_widgets.erl +++ /dev/null @@ -1,94 +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% -%% - -%% -%% ------------------------------------------------------------ -%% Widget specific data -%% ------------------------------------------------------------ -%% - --module(gstk_widgets). - --export([type2mod/1, objmod/1, suffix/1]). - --include("gstk.hrl"). - - - - -%% -%% Map primitive types to modules or false (false should not be a module!) -%% -%% ordered for efficiency - -type2mod(window) -> gstk_window; -type2mod(frame) -> gstk_frame; -type2mod(button) -> gstk_button; -type2mod(canvas) -> gstk_canvas; -type2mod(checkbutton) -> gstk_checkbutton; -type2mod(rectangle) -> gstk_rectangle; -type2mod(gs) -> gstk_gs; -type2mod(grid) -> gstk_grid; -type2mod(gridline) -> gstk_gridline; -type2mod(text) -> gstk_text; -type2mod(image) -> gstk_image; -type2mod(label) -> gstk_label; -type2mod(line) -> gstk_line; -type2mod(entry) -> gstk_entry; -type2mod(listbox) -> gstk_listbox; -type2mod(editor) -> gstk_editor; -type2mod(menu) -> gstk_menu; -type2mod(menubar) -> gstk_menubar; -type2mod(menubutton) -> gstk_menubutton; -type2mod(menuitem) -> gstk_menuitem; -type2mod(message) -> gstk_message; -type2mod(oval) -> gstk_oval; -type2mod(polygon) -> gstk_polygon; -type2mod(prompter) -> gstk_prompter; -type2mod(radiobutton) -> gstk_radiobutton; -type2mod(scale) -> gstk_scale; -type2mod(scrollbar) -> gstk_scrollbar; -type2mod(arc) -> gstk_arc; -type2mod(Type) -> {error,{unknown_type, Type}}. - -objmod(#gstkid{objtype=OT}) -> type2mod(OT). - -%% -%% The suffix to add to the parent tk widget -%% -suffix(button) -> ".b"; -suffix(canvas) -> ".c"; -suffix(checkbutton) -> ".cb"; -suffix(editor) -> ".ed"; -suffix(entry) -> ".e"; -suffix(frame) -> ".f"; -suffix(label) -> ".l"; -suffix(listbox) -> ".lb"; -suffix(menu) -> ".m"; -suffix(menubar) -> ".bar"; -suffix(menubutton) -> ".mb"; -suffix(message) -> ".ms"; -suffix(prompter) -> ".p"; -suffix(radiobutton) -> ".rb"; -suffix(scale) -> ".sc"; -suffix(window) -> ".w"; -suffix(Objtype) -> apply(type2mod(Objtype), suffix, []). - - diff --git a/lib/gs/src/gstk_window.erl b/lib/gs/src/gstk_window.erl deleted file mode 100644 index c14cf2fd81..0000000000 --- a/lib/gs/src/gstk_window.erl +++ /dev/null @@ -1,371 +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% -%% - -%% -%% ------------------------------------------------------------ -%% Basic Window Type. -%% ------------------------------------------------------------ - --module(gstk_window). --compile([{nowarn_deprecated_function,{gs,destroy,1}}]). - -%%------------------------------------------------------------------------------ -%% WINDOW OPTIONS -%% -%% Attributes: -%% x Int -%% y Int -%% width Int -%% height Int -%% bg Color -%% bw Int -%% relief Relief [flat|raised|sunken|ridge|groove] -%% highlightbw Int -%% highlightbg Color -%% highlightfg Color -%% map Bool -%% iconify Bool -%% title String -%% iconname String -%% iconbitmap Bitmap -%% iconmask Bitmap -%% data Data -%% cursor arrow|busy|cross|hand|help|resize|text -%% -%% Commands: -%% raise -%% lower -%% setfocus Bool -%% -%% Events: -%% configure [Bool | {Bool, Data}] -%% enter [Bool | {Bool, Data}] -%% leave [Bool | {Bool, Data}] -%% motion [Bool | {Bool, Data}] -%% keypress [Bool | {Bool, Data}] -%% keyrelease [Bool | {Bool, Data}] -%% buttonpress [Bool | {Bool, Data}] -%% buttonrelease [Bool | {Bool, Data}] -%% focus [Bool | {Bool, Data}] -%% destroy [Bool | {Bool, Data}] -%% -%% Read options: -%% children -%% id -%% parent -%% type -%% -%% Not Implemented: -%% screen ????????? -%% map -%% unmap -%% iconify -%% deiconify -%% focusmodel [active|passive] (wm focusmodel) -%% - --export([create/3, config/3, read/3, delete/2, event/5,destroy_win/1]). --export([option/5,read_option/5,mk_create_opts_for_child/4]). - --include("gstk.hrl"). -% bind . <1> {puts "x: [expr %X - [winfo rootx .]] y: [expr %Y - [wi rooty .]]"} - -%%----------------------------------------------------------------------------- -%% MANDATORY INTERFACE FUNCTIONS -%%----------------------------------------------------------------------------- -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : create/3 -%% Purpose : Create a widget of the type defined in this module. -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -create(DB, Gstkid, Opts) -> - TkW = gstk_generic:mk_tkw_child(DB,Gstkid), - NGstkid=Gstkid#gstkid{widget=TkW}, - case gstk_generic:make_command(transform_geometry_opts(Opts), - NGstkid, TkW, "", ";", DB) of - {error,Reason} -> {error,Reason}; - Cmd when is_list(Cmd) -> - BindCmd = gstk_generic:bind(DB, Gstkid, TkW, configure, true), -% io:format("\nWINDOW1: ~p\n",[TkW]), -% io:format("\nWINDOW1: ~p\n",[Cmd]), -% io:format("\nWINDOW1: ~p\n",[BindCmd]), - gstk:exec(["toplevel ", TkW,Cmd,$;,BindCmd]), - NGstkid - end. - -mk_create_opts_for_child(DB,Cgstkid, Pgstkid, Opts) -> - gstk_generic:mk_create_opts_for_child(DB,Cgstkid,Pgstkid,Opts). - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : config/3 -%% Purpose : Configure a widget of the type defined in this module. -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% Opts - A list of options for configuring the widget -%% -%% Return : [true | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -config(DB, Gstkid, Opts) -> - TkW = Gstkid#gstkid.widget, - SimplePreCmd = [TkW, " conf"], - gstk_generic:mk_cmd_and_exec(transform_geometry_opts(Opts), - Gstkid,TkW,SimplePreCmd,"",DB). - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : read/3 -%% Purpose : Read one option from a widget -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% Opt - An option to read -%% -%% Return : [OptionValue | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -read(DB, Gstkid, Opt) -> - gstk_generic:read_option(DB, Gstkid, Opt). - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : delete/2 -%% Purpose : Delete widget from databas and return tkwidget to destroy -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% -%% Return : TkWidget to destroy -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -delete(DB, Gstkid) -> - gstk_db:delete_widget(DB, Gstkid), - Gstkid#gstkid.widget. - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : event/5 -%% Purpose : Construct the event and send it to the owner of the widget -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% Etype - The event type -%% Edata - The event data -%% Args - The data from tcl/tk -%% -%% Return : [true | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -event(DB, Gstkid, configure, Edata, Args) -> - [W,H|_] = Args, - gstk_db:insert_opt(DB,Gstkid,{width,W}), - gstk_db:insert_opt(DB,Gstkid,{height,H}), - case gstk_db:opt(DB,Gstkid,configure) of - true -> - apply(gstk_generic,event,[DB,Gstkid,configure,Edata,Args]); - false -> - ok - end; -event(DB, Gstkid, destroy, Edata, Args) -> - spawn(gstk_window,destroy_win,[gstk:make_extern_id(Gstkid#gstkid.id,DB)]), - gstk_generic:event(DB, Gstkid, destroy, Edata, Args); -event(DB, Gstkid, Etype, Edata, Args) -> - gstk_generic:event(DB, Gstkid, Etype, Edata, Args). - -destroy_win(ID) -> - gs:destroy(ID). -%%------------------------------------------------------------------------------ -%% MANDATORY FUNCTIONS -%%------------------------------------------------------------------------------ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : option/4 -%% Purpose : Take care of options -%% Args : Option - An option tuple -%% Gstkid - The gstkid of the widget -%% TkW - The tk-widget -%% DB - The Database -%% -%% Return : A tuple {OptionType, OptionCmd} -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%-define(REGEXP,"regexp {(\\d+)x(\\d+)\\+?(-?\\d+)\\+?(-?\\d+)} "). -% FIXME: Is this ok? Always positive? --define(REGEXP,"regexp {(\\d+)x(\\d+)\\+(\\d+)\\+(\\d+)} "). - -option(Option, Gstkid, TkW, DB,_) -> - case Option of -%% Bug in tcl/tk complicates setting of a single x,y,width,height. - {x, X} -> - {c, - [?REGEXP,"[wm ge ",TkW, "] g w h x y;wm ge ", TkW, - " ${w}x$h",signed(X),"+$y;update idletasks"]}; - {y, Y} -> - {c,[?REGEXP,"[wm ge ",TkW, "] g w h x y;wm ge ", TkW, - " ${w}x$h+$x",signed(Y),"; update idletasks"]}; - {width, Width} when Width >= 0 -> % FIXME: Needed test? - case gstk_db:opt_or_not(DB,Gstkid,width) of - {value,Width} -> none; - _Q -> - gstk_db:insert_opt(DB,Gstkid,{width,Width}), - {c,[?REGEXP,"[wm ge ",TkW, "] g w h x y;wm ge ", TkW," ", - gstk:to_ascii(Width),"x$h+$x+$y;update idletasks"]} - end; - {height, Height} when Height >= 0 -> % FIXME: Needed test? - case gstk_db:opt_or_not(DB,Gstkid,height) of - {value,Height} -> none; - _Q -> % FIXME: Why different? - gstk_db:insert_opt(DB,Gstkid,{height,Height}), - {c, - ["wm ge ",TkW, - " [winfo w ", TkW, "]x",gstk:to_ascii(Height), - ";update idletasks"]} - end; - {width_height, {W,H}} when W >= 0, H >= 0 -> - case {gstk_db:opt_or_not(DB,Gstkid,width), - gstk_db:opt_or_not(DB,Gstkid,height)} of - {{value,W},{value,H}} -> - none; - _OtherSize -> - gstk_db:insert_opt(DB,Gstkid,{height,H}), - gstk_db:insert_opt(DB,Gstkid,{width,W}), - {c, ["update idletasks;wm ge ", TkW, " ", - gstk:to_ascii(W),"x",gstk:to_ascii(H), - ";update idletasks"]} - end; - {xy, {X,Y}} -> - {c, [?REGEXP,"[wm ge ",TkW, "] g w h x y;wm ge ", TkW, - " ${w}x$h", signed(X),signed(Y), - ";update idletasks"]}; - {bg, Color} -> {s, [" -bg ", gstk:to_color(Color)]}; - {map, true} -> {c, ["wm deiconify ", TkW]}; - {map, false} -> {c, ["wm withdraw ", TkW]}; - {configure, On} -> - gstk_db:insert_opt(DB,Gstkid,{configure,On}), - none; - {iconify, true} -> {c, ["wm iconify ", TkW]}; - {iconify, false} -> {c, ["wm deiconify ", TkW]}; - {title, Title} -> {c, ["wm title ", TkW, " " , - gstk:to_ascii(Title)]}; - {iconname, Name} -> {c, ["wm iconn ",TkW, " ", - gstk:to_ascii(Name)]}; - {iconbitmap, Bitmap} -> {c, ["wm iconb ",TkW, " ", - gstk:to_ascii(Bitmap)]}; - {iconmask, Bitmap} -> {c, ["wm iconm ",TkW, " ", - gstk:to_ascii(Bitmap)]}; - raise -> {c, ["raise ", TkW]}; - lower -> {c, ["lower ", TkW]}; - {setfocus, true} -> {c, ["focus ", TkW]}; - {setfocus, false} -> {c, ["focus {}"]}; - {buttonpress, On} -> - Eref = mk_eref(On, DB, Gstkid, buttonpress), - {c,["bind ",TkW," <ButtonPress> ", - event_onoff(["{erlsend ",Eref," %b ",xy_abs_str(TkW),"};"],On)]}; - {buttonrelease, On} -> - Eref = mk_eref(On, DB, Gstkid, buttonrelease), - {c,["bind ",TkW," <ButtonRelease> ", - event_onoff(["{erlsend ",Eref," %b ",xy_abs_str(TkW),"};"],On)]}; - {motion, On} -> - Eref = mk_eref(On, DB, Gstkid, motion), - {c,["bind ",TkW," <Motion> ", - event_onoff(["{erlsend ",Eref," ",xy_abs_str(TkW),"};"],On)]}; - _ -> invalid_option - end. - -xy_abs_str(TkW) -> - ["[expr %X-[winfo rootx ",TkW,"]] [expr %Y-[winfo rooty ",TkW,"]]"]. - -event_onoff(Str, true) -> Str; -event_onoff(_,false) -> "{}". - -mk_eref(false, DB, Gstkid, Etype) -> - gstk_db:delete_event(DB, Gstkid, Etype), - dummy; -mk_eref(true,DB,Gstkid,Etype) -> - gstk_db:insert_event(DB, Gstkid, Etype, []). - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : read_option/3 -%% Purpose : Take care of a read option -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% Option - An option -%% -%% Return : The value of the option or invalid_option -%% [OptionValue | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -read_option(Option, Gstkid, TkW, DB,_) -> - case Option of - x -> tcl2erl:ret_x(geo_str(TkW)); - y -> tcl2erl:ret_y(geo_str(TkW)); - width -> tcl2erl:ret_width(geo_str(TkW)); - height -> tcl2erl:ret_height(geo_str(TkW)); - configure -> gstk_db:opt(DB,Gstkid,configure); - bg -> tcl2erl:ret_color([TkW," cg -bg"]); - map -> tcl2erl:ret_mapped(["winfo is ", TkW]); - iconify -> tcl2erl:ret_iconified(["wm st ", TkW]); - title -> tcl2erl:ret_str(["wm ti ", TkW]); - iconname -> tcl2erl:ret_str(["wm iconn ", TkW]); - iconbitmap -> tcl2erl:ret_str(["wm iconb ", TkW]); - iconmask -> tcl2erl:ret_str(["wm iconm ", TkW]); - setfocus -> tcl2erl:ret_focus(TkW, "focus"); - _ -> {bad_result, {Gstkid#gstkid.objtype, invalid_option, Option}} - end. - -geo_str(TkW) -> - ["update idletasks;",?REGEXP,"[wm geometry ", TkW, - "] g w h x y;set tmp \"$w $h $x $y\""]. - - - -%%---------------------------------------------------------------------- -%% PRIMITIVES -%%---------------------------------------------------------------------- - -%% Return {+,-}Int to be used in a geometry option -signed(X) when X>=0 -> - [$+,integer_to_list(X)]; -signed(X) when X<0 -> - integer_to_list(X). - -%%---------------------------------------------------------------------- -%% Purpose: tcl/tk: wm .window geo sets WxH+x+y at one time. -%% flushing every time is expensive. Do (almost) as much as -%% possible in one operation. -%%---------------------------------------------------------------------- -transform_geometry_opts(Opts) -> - {Geo,RestOpts} = collect_geo_opts(Opts,[],[]), - Geo2 = make_atomic(lists:sort(Geo)), - lists:append(Geo2,RestOpts). - -make_atomic([{height,H},{width,W},{x,X},{y,Y}]) -> - [{width_height,{W,H}},{xy,{X,Y}}]; -make_atomic([{height,H},{width,W}|XY]) -> - [{width_height,{W,H}}|XY]; -make_atomic([WH,{x,X},{y,Y}]) -> - [WH,{xy,{X,Y}}]; -make_atomic(L) -> L. - -%%---------------------------------------------------------------------- -%% Returns: {(list of x,y,width,height options),list of other opts} -%%---------------------------------------------------------------------- -collect_geo_opts([{x,X}|Opts],Geo,Rest) -> - collect_geo_opts(Opts,[{x,X}|Geo],Rest); -collect_geo_opts([{y,Y}|Opts],Geo,Rest) -> - collect_geo_opts(Opts,[{y,Y}|Geo],Rest); -collect_geo_opts([{height,H}|Opts],Geo,Rest) -> - collect_geo_opts(Opts,[{height,H}|Geo],Rest); -collect_geo_opts([{width,W}|Opts],Geo,Rest) -> - collect_geo_opts(Opts,[{width,W}|Geo],Rest); -collect_geo_opts([Opt|Opts],Geo,Rest) -> - collect_geo_opts(Opts,Geo,[Opt|Rest]); -collect_geo_opts([],Geo,Rest) -> {Geo,Rest}. - -%%% ----- Done ----- diff --git a/lib/gs/src/tcl2erl.erl b/lib/gs/src/tcl2erl.erl deleted file mode 100644 index 04229ccf49..0000000000 --- a/lib/gs/src/tcl2erl.erl +++ /dev/null @@ -1,459 +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% -%% - -%% -%% ------------------------------------------------------------ -%% -%% Handle conversion from tcl string to erlang terms -%% -%% ------------------------------------------------------------ - --module(tcl2erl). --compile([{nowarn_deprecated_function,{gs,error,2}}]). - --export([parse_event/1, - ret_int/1, - ret_atom/1, - ret_str/1, - ret_tuple/1, - ret_pack/2, - ret_place/2, - ret_x/1, - ret_y/1, - ret_width/1, - ret_height/1, - ret_list/1, - ret_str_list/1, - ret_label/1, - ret_mapped/1, - ret_iconified/1, - ret_focus/2, - ret_file/1, - ret_bool/1, - ret_enable/1, - ret_color/1, - ret_stipple/1]). - --include("gstk.hrl"). - - - -%% ---------------------------------------- -%% Parse an incoming event represented as -%% a list of bytes -%% -parse_event(Bytes) -> - {[$#|ID], Cont1} = first_word(Bytes), - {Etag, Cont} = first_word(Cont1), - {tokens, Toks} = scan(Cont), - {term_seq, Args}= parse_term_seq(Toks), - {list_to_integer(ID), Etag, Args}. - - -%%---first word returns {Word,Cont}---%% -first_word(Bytes) -> - fw(Bytes,[]). - -fw([],Ack) -> - {lists:reverse(Ack),[]}; -fw([$ |R],Ack) -> - {lists:reverse(Ack),R}; -fw([Char|R],Ack) -> - fw(R,[Char|Ack]). - - -%% --------------------------------------------- -%% str_to_term(Str) -%% Transforms a string to the corresponding Erlang -%% term. Note that the string "Hello" will be -%% transformed to an Erlang atom: 'Hello' . -%% If it is impossible to convert the string into -%% a term the original string is just returned. -%% str_to_term(Str) <---> {string, Str} or {term, Term} -%% 'so that we can be able to tell if conversion succeded or not.' -%% - -str_to_term(Str) -> - {tokens,Tokens} = scan(Str), - case catch parse_term(Tokens) of - {_Type, Term,[]} -> {term,Term}; - _ -> {string, Str} - end. - - -%% --------------------------------------------- -%% Simple Parser. ;-) -%% Parses tokens or fails. -%% Better catch result. -%% Tokens should be generated by scan. -%% parse_term(Toks) <----> {term, Term, Cont} -%% parse_call(Toks) <----> {call, Mod, Fun, Args, Cont} -%% parse_list(Toks) <----> {list, ListTerm, Cont} -%% parse_tuple(Toks) <----> {tuple, TupleTerm, Cont} -%% parse_fun_args(Toks) <-> {fun_args, FunArgs, Cont} %% like (arg1, arg2...) -%% parse_term_seq(Toks) <-> {term_seq, Term_Sequence} %% no continuation -%% - -parse_term([{var,Var}|R]) -> {var,Var,R}; -parse_term([{atom,Atom}|R]) -> {atom,Atom,R}; -parse_term([{float,Float}|R]) -> {float,Float,R}; -parse_term([{integer,Integer}|R]) -> {integer,Integer,R}; -parse_term([{string,String}|R]) -> {string,String,R}; -parse_term(['-',{integer,Integer}|R]) -> {integer,-Integer,R}; -parse_term(['-',{float,Float}|R]) -> {float,-Float,R}; -parse_term(['+',{integer,Integer}|R]) -> {integer,Integer,R}; -parse_term(['+',{float,Float}|R]) -> {float,Float,R}; -parse_term(['['|R]) -> {list,_Term,_C}=parse_list(['['|R]); -parse_term(['{'|R]) -> {tuple,_Term,_C}=parse_tuple(['{'|R]); -parse_term([Char|R]) -> {char,Char,R}. - -%%--- parse list --- -parse_list(['[',']'|C]) -> - {list, [], C}; -parse_list(['['|R]) -> - {list,_List,_C}= list_args(R,[]). - -list_args(Toks,Ack) -> - cont_list(parse_term(Toks),Ack). - -cont_list({_Tag, Term,[','|C]},Ack) -> - list_args(C,[Term|Ack]); -cont_list({_Tag, Term,[']'|C]},Ack) -> - {list,lists:reverse([Term|Ack]),C}. - -%%--- parse tuple --- -parse_tuple(['{','}'|C]) -> - {tuple,{}, C}; -parse_tuple(['{'|R]) -> - {tuple,_Tuple,_C}=tuple_args(R,[]). - -tuple_args(Toks,Ack) -> - cont_tuple(parse_term(Toks),Ack). - -cont_tuple({_Tag, Term,[','|C]},Ack) -> - tuple_args(C,[Term|Ack]); -cont_tuple({_Tag, Term,['}'|C]},Ack) -> - {tuple,list_to_tuple(lists:reverse([Term|Ack])),C}. - -%%--- parse sequence of terms --- -parse_term_seq(Toks) -> - p_term_seq(Toks,[]). - -p_term_seq([],Ack) -> - {term_seq, lists:reverse(Ack)}; % never any continuation left -p_term_seq(Toks,Ack) -> - {_Type,Term,C} = parse_term(Toks), - p_term_seq(C,[Term|Ack]). - - - -%% ---------------------------------------- -%% Simple Scanner - -scan(Bytes) -> - {tokens, scan(Bytes,[])}. - -scan([],Ack) -> - lists:reverse(Ack); -scan([$ |R],Ack) -> % delete whitespace - scan(R,Ack); -scan([X|R],Ack) when is_integer(X),X>=$a,X=<$z -> - scan_atom(R,[X],Ack); -scan([X|R],Ack) when is_integer(X),X>=$A,X=<$Z -> - scan_var(R,[X],Ack); -scan([X|R],Ack) when is_integer(X),X>=$0,X=<$9 -> - scan_number(R,[X],Ack); -scan([$"|R],Ack) -> - scan_string(R,[],Ack); -scan([X|R],Ack) when is_integer(X) -> - scan(R,[list_to_atom([X])|Ack]). - -scan_atom([X|R],Ack1,Ack2) when is_integer(X),X>=$a,X=<$z -> - scan_atom(R,[X|Ack1],Ack2); -scan_atom([X|R],Ack1,Ack2) when is_integer(X),X>=$A,X=<$Z -> - scan_atom(R,[X|Ack1],Ack2); -scan_atom([X|R],Ack1,Ack2) when is_integer(X),X>=$0,X=<$9 -> - scan_atom(R,[X|Ack1],Ack2); -scan_atom([$_|R],Ack1,Ack2) -> - scan_atom(R,[$_|Ack1],Ack2); -scan_atom(L,Ack1,Ack2) -> - scan(L,[{atom,list_to_atom(lists:reverse(Ack1))}|Ack2]). - -scan_var([X|R],Ack1,Ack2) when is_integer(X),X>=$a,X=<$z -> - scan_var(R,[X|Ack1],Ack2); -scan_var([X|R],Ack1,Ack2) when is_integer(X),X>=$A,X=<$Z -> - scan_var(R,[X|Ack1],Ack2); -scan_var([X|R],Ack1,Ack2) when is_integer(X),X>=$0,X=<$9 -> - scan_var(R,[X|Ack1],Ack2); -scan_var([$_|R],Ack1,Ack2) -> - scan_var(R,[$_|Ack1],Ack2); -scan_var(L,Ack1,Ack2) -> - scan(L,[{var,list_to_atom(lists:reverse(Ack1))}|Ack2]). - -scan_number([X|R],Ack1,Ack2) when is_integer(X),X>=$0,X=<$9 -> - scan_number(R,[X|Ack1],Ack2); -scan_number([$.|R],Ack1,Ack2) -> - scan_float(R,[$.|Ack1],Ack2); -scan_number(L,Ack1,Ack2) -> - scan(L,[{integer,list_to_integer(lists:reverse(Ack1))}|Ack2]). - -scan_float([X|R],Ack1,Ack2) when is_integer(X),X>=$0,X=<$9 -> - scan_float(R,[X|Ack1],Ack2); -scan_float(L,Ack1,Ack2) -> - Float = list_to_float(lists:reverse(Ack1)), - Int = trunc(Float), - if - Int==Float -> - scan(L,[{integer,Int}|Ack2]); - true -> - scan(L,[{float,Float}|Ack2]) - end. - - -scan_string([$"|R],Ack1,Ack2) -> - scan(R,[{string,lists:reverse(Ack1)}|Ack2]); -scan_string([X|R],Ack1,Ack2) when is_integer(X) -> - scan_string(R,[X|Ack1],Ack2); -scan_string([],_Ack1,_Ack2) -> - throw({error,"unterminated string."}). - - - -%% ---------- Checking Return values ----------- -%% Used by read to return a proper type or fail. - -ret_int(Str) -> - case gstk:call(Str) of - {result, Result} -> - {_,Value} = str_to_term(Result), - Value; - Bad_result -> Bad_result - end. - -ret_atom(Str) -> - case gstk:call(Str) of - {result, Result} -> - {_,Value} = str_to_term(Result), - Value; - Bad_result -> Bad_result - end. - -ret_str(Str) -> - case gstk:call(Str) of - {result, Val} -> Val; - Bad_result -> Bad_result - end. - -ret_tuple(Str) -> - case gstk:call(Str) of - {result,S} -> - {tokens,Toks} = scan(S), - {term_seq,Seq} = parse_term_seq(Toks), - list_to_tuple(Seq); - Bad_result -> Bad_result - end. - -%%---------------------------------------------------------------------- -%% Returns: Coords or error. -%%---------------------------------------------------------------------- -ret_pack(Key, TkW) -> - Str = ret_list(["pack info ", TkW]), - pick_out(Str, Key). - -ret_place(Key, TkW) -> - Str = ret_list(["place info ", TkW]), - pick_out(Str, Key). - -pick_out([Key, Value | _Rest], Key) -> Value; -pick_out([Key, {} | _Rest], Key) -> 0; -pick_out(['-' | Rest], Key) -> pick_out(Rest, Key); -pick_out([_, _ | Rest], Key) -> pick_out(Rest, Key); -pick_out(Other, _Key) -> Other. - - -ret_x(Str) -> - case ret_geometry(Str) of - {_W,_H,X,_Y} -> X; - Other -> Other - end. - -ret_y(Str) -> - case ret_geometry(Str) of - {_W,_H,_X,Y} -> Y; - Other -> Other - end. - -ret_width(Str) -> - case ret_geometry(Str) of - {W,_H,_X,_Y} -> W; - Other -> Other - end. - -ret_height(Str) -> - case ret_geometry(Str) of - {_W,H,_X,_Y} -> H; - Other -> Other - end. - - - -ret_geometry(Str) -> - case ret_tuple(Str) of - {W,H,X,Y} when is_atom(H) -> - [_|Height]=atom_to_list(H), - {W,list_to_integer(Height),X,Y}; - Other -> Other - end. - -ret_list(Str) -> - case gstk:call(Str) of - {result,S} -> - {tokens,Toks} = scan(S), - {term_seq,Seq} = parse_term_seq(Toks), - Seq; - Bad_result -> Bad_result - end. - -ret_str_list(Str) -> - case gstk:call(Str) of - {result,S} -> - mk_quotes0(S,[]); - Bad_result -> Bad_result - end. - - -ret_label(Str) -> - case ret_str_list(Str) of - [[], [$@|Img]] -> {image, Img}; - [Text, []] -> {text, Text}; - Bad_Result -> Bad_Result - end. - - - -ret_mapped(Str) -> - case ret_int(Str) of - 1 -> true; - 0 -> false; - Bad_Result -> Bad_Result - end. - - -ret_iconified(Str) -> - case ret_atom(Str) of - iconic -> true; - normal -> false; - Bad_Result -> Bad_Result - end. - - -ret_focus(W, Str) -> - case gstk:call(Str) of - {result, W} -> true; - _ -> false - end. - - -ret_file(Str) -> - case gstk:call(Str) of - {result, [$@|File]} -> File; - {result, []} -> []; - Bad_result -> Bad_result - end. - - -ret_bool(Str) -> - case ret_int(Str) of - 1 -> true; - 0 -> false; - Bad_Result -> Bad_Result - end. - -ret_enable(Str) -> - case ret_atom(Str) of - normal -> true; - active -> true; - disabled -> false; - Bad_Result -> Bad_Result - end. - - - -ret_color(Str) -> - case gstk:call(Str) of - {result,[$#,R1,G1,B1]} -> - {hex2dec([R1,$0]),hex2dec([G1,$0]),hex2dec([B1,$0])}; - {result,[$#,R1,R2,G1,G2,B1,B2]} -> - {hex2dec([R1,R2]),hex2dec([G1,G2]),hex2dec([B1,B2])}; - {result,[$#,R1,R2,_R3,G1,G2,_G3,B1,B2,_B3]} -> - {hex2dec([R1,R2]),hex2dec([G1,G2]),hex2dec([B1,B2])}; - {result,[$#,R1,R2,_R3,_R4,G1,G2,_G3,_G4,B1,B2,_B3,_B4]} -> - {hex2dec([R1,R2]),hex2dec([G1,G2]),hex2dec([B1,B2])}; - {result,[Char|Word]} when Char>=$A, Char=<$Z -> - list_to_atom([Char+32|Word]); - {result,[Char|Word]} when Char>=$a, Char=<$z -> - list_to_atom([Char|Word]); - {result,Color} -> - gs:error("error in tcl2erl:ret_color got ~w.~n",[Color]); - Bad_result -> Bad_result - end. - - -ret_stipple(Str) -> - case gstk:call(Str) of - {result, _Any} -> true; - _Other -> false - end. - - -%% ------------------------------------------------------------ -%% Hexadecimal to Decimal converter -%% - -hex2dec(Hex) -> hex2dec(Hex,0). - -hex2dec([H|T],N) when H>=$0,H=<$9 -> - hex2dec(T,(N bsl 4) bor (H-$0)); -hex2dec([H|T],N) when H>=$a,H=<$f -> - hex2dec(T,(N bsl 4) bor (H-$a+10)); -hex2dec([H|T],N) when H>=$A,H=<$F -> - hex2dec(T,(N bsl 4) bor (H-$A+10)); -hex2dec([],N) -> N. - - -mk_quotes0([${|T],Res) -> mk_quotes2(T,"",Res); -mk_quotes0([$ |T],Res) -> mk_quotes0(T,Res); -mk_quotes0([$\\,X |T],Res) -> mk_quotes1(T,[X],Res); -mk_quotes0([X|T],Res) -> mk_quotes1(T,[X],Res); -mk_quotes0([],Res) -> lists:reverse(Res). - -mk_quotes1([$}|T],Ack,Res) -> mk_quotes0(T,[lists:reverse(Ack)|Res]); -mk_quotes1([$\\,X |T],Ack,Res) -> mk_quotes1(T,[X|Ack],Res); -mk_quotes1([$ |T],Ack,Res) -> mk_quotes0(T,[lists:reverse(Ack)|Res]); -mk_quotes1([X|T],Ack,Res) -> mk_quotes1(T,[X|Ack],Res); -mk_quotes1([],Ack,Res) -> lists:reverse([lists:reverse(Ack)|Res]). - -%% grouped using {bla bla} syntax -mk_quotes2([$}|T],Ack,Res) -> mk_quotes0(T,[lists:reverse(Ack)|Res]); -mk_quotes2([$\\,X |T],Ack,Res) -> mk_quotes2(T,[X|Ack],Res); -mk_quotes2([X|T],Ack,Res) -> mk_quotes2(T,[X|Ack],Res); -mk_quotes2([],Ack,Res) -> lists:reverse([lists:reverse(Ack)|Res]). - - diff --git a/lib/gs/src/tool_file_dialog.erl b/lib/gs/src/tool_file_dialog.erl deleted file mode 100644 index a6d6f55f1f..0000000000 --- a/lib/gs/src/tool_file_dialog.erl +++ /dev/null @@ -1,456 +0,0 @@ -%% -%% %CopyrightBegin% -%% -%% Copyright Ericsson AB 1997-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(tool_file_dialog). --compile([{nowarn_deprecated_function,{gs,button,3}}, - {nowarn_deprecated_function,{gs,config,2}}, - {nowarn_deprecated_function,{gs,entry,3}}, - {nowarn_deprecated_function,{gs,frame,3}}, - {nowarn_deprecated_function,{gs,label,3}}, - {nowarn_deprecated_function,{gs,listbox,3}}, - {nowarn_deprecated_function,{gs,read,2}}, - {nowarn_deprecated_function,{gs,start,0}}, - {nowarn_deprecated_function,{gs,window,3}}]). - --export([start/1]). - --record(opts, {type, % open | save | multiselect - dir, % string() Current directory - file, % string() Filename, no path - extensions, % [string()] Filtered file extensions - hidden}). % [{Dir, [File]}] Hidden files per dir. - --define(WIDTH, 250). --define(HEIGHT, 400). --define(BTNW, 65). --define(BTNH, 30). - -%% start(Opts) -> {ok, AbsFile, Dir} | {error,cancel} | pid() -%% Opts = [Opt] -%% Opt = {type, open|save|multiselect} -%% | {extensions, [string()]} % For example ".erl" -%% | {dir, string()} % Absolute path -%% ! {file, string() % Filename (no path) -%% AbsFile = string() -%% Dir = string() -%% An open/save dialog returns {ok, AbsFile, Dir} or {error,cancel} -%% (the latter, ridiculous, return value is kept for backwards -%% compatibility reasons only). -%% -%% A multiselect box returns a pid and delivers messages on the form: -%% {select, AbsFile} | {close, Dir} -%% -%% Dir is the current directory displayed and can be used to start a -%% a new filedialog with the same directory. - -start(Opts0) -> - Opts = parse_opts(Opts0), - Self = self(), - case Opts#opts.type of - multiselect -> - spawn_link(fun() -> init(Self, Opts) end); - _Type -> % open | save - spawn_link(fun() -> init(Self, Opts) end), - receive - {fd_result, Res} -> - Res - end - end. - -parse_opts(Opts) -> - {ok, CWD} = file:get_cwd(), - DefOpts = #opts{type=open, dir=CWD, file="NoName", - extensions=[], hidden=[]}, - parse_opts(Opts, DefOpts). - -parse_opts([{type, Type}|Opts], DefOpts) -> - if - Type==open; Type==save; Type==multiselect -> - parse_opts(Opts, DefOpts#opts{type=Type}); - true -> - erlang:error(badarg, [{type,Type}]) - end; -parse_opts([{extensions, Exts}|Opts], DefOpts) -> - case lists:all(fun(Ext) -> is_list(Ext) end, Exts) of - true -> - parse_opts(Opts, DefOpts#opts{extensions=Exts}); - false -> - erlang:error(badarg, [{extension, Exts}]) - end; -parse_opts([{dir, Dir}|Opts], DefOpts) -> - case filelib:is_dir(Dir) of - true -> - case filename:pathtype(Dir) of - absolute -> - parse_opts(Opts, DefOpts#opts{dir=Dir}); - _ -> - parse_opts(Opts, - DefOpts#opts{dir=filename:absname(Dir)}) - end; - false -> - erlang:error(badarg, [{dir, Dir}]) - end; -parse_opts([{file, Name}|Opts], DefOpts) -> - if - is_list(Name) -> - parse_opts(Opts, DefOpts#opts{file=Name}); - true -> - erlang:error(badarg, [{file, Name}]) - end; -parse_opts([_|Opts], DefOpts) -> % ignore unknown options - parse_opts(Opts, DefOpts); -parse_opts([], DefOpts) -> - DefOpts. - -%%--Loop---------------------------------------------------------------- - -init(From, Opts) -> - make_window(Opts), - loop(From, {?WIDTH,?HEIGHT}, Opts). - -loop(From, {OldW,OldH}=Size, Opts) -> - receive - - %% Window is closed - {gs, win, destroy, _, _} when Opts#opts.type==multiselect -> - From ! {close, Opts#opts.dir}; - {gs, win, destroy, _, _} -> - From ! {fd_result, {error, cancel}}; - - %% Window is moved or resized - {gs, win, configure, _, [OldW,OldH|_]} -> - loop(From, Size, Opts); - {gs, win, configure, _, [W,H|_]} -> - gs:config(resizer, [{width,W},{height,H}]), - loop(From, {W,H}, Opts); - - %% Up button is selected - {gs, up, click, _, _} -> - Opts2 = set_dir(up, Opts), - loop(From, Size, Opts2); - - %% A listbox item (dir or file) is selected - {gs, lb, click, _, [_I,Item|_]} -> - Entry = case lists:last(Item) of - $/ -> ""; - _Ch -> Item - end, - gs:config(entry, {text,Entry}), - loop(From, Size, Opts); - - %% A listbox item (dir or file) is double-clicked - {gs, lb, doubleclick, _, [_I,Item|_]} -> - case lists:last(Item) of - $/ -> do_select({dir, Item}, From, Size, Opts); - _Ch -> do_select({file, Item}, From, Size, Opts) - end; - - %% Open/Save/Select button is selected - {gs, select, click, _, _} -> - case gs:read(entry, text) of - "" -> - case gs:read(lb, selection) of - [] -> - gs:config(select, beep), - loop(From, Size, Opts); - [I] -> - Item = gs:read(lb, {get,I}), - case lists:last(Item) of - $/ -> - do_select({dir, Item}, - From, Size, Opts); - _Ch -> - do_select({file, Item}, - From, Size, Opts) - end - end; - Item -> do_select(Item, From, Size, Opts) - end; - - %% 'Return' is pressed - {gs, entry, keypress, _, ['Return'|_]} -> - case gs:read(entry, text) of - "" -> - gs:config(select, beep), - loop(From, Size, Opts); - Item -> - do_select(Item, From, Size, Opts) - end; - - %% All button is selected (multiselect dialog) - {gs, all, click, _, _} -> - {_Dirs, Files} = select_all(), - lists:foreach(fun(File) -> - AbsFile = filename:join(Opts#opts.dir, - File), - From ! {select, AbsFile} - end, - Files), - From ! {close, Opts#opts.dir}; - - %% Cancel button is selected (open/save dialog) - {gs, cancel, click, _, _} -> - From ! {fd_result, {error, cancel}}; - - %% Close button is selected (multiselect dialog) - {gs, close, click, _, _} -> - From ! {close, Opts#opts.dir}; - - Msg -> - io:format("GOT: ~p~n", [Msg]), - loop(From, Size, Opts) - end. - -do_select({dir, Name}, From, Size, Opts) -> - do_select_dir(filename:join(Opts#opts.dir, Name), From, Size, Opts); -do_select({file, Name}, From, Size, Opts) -> - do_select_file(filename:join(Opts#opts.dir, Name), From, Size,Opts); -do_select(Entry, From, Size, Opts) -> - AbsName = case filename:pathtype(Entry) of - absolute -> Entry; - _ -> filename:join(Opts#opts.dir, Entry) - end, - case filelib:is_dir(AbsName) of - true -> do_select_dir(AbsName, From, Size, Opts); - false -> do_select_file(AbsName, From, Size, Opts) - end. - -do_select_dir(Dir, From, Size, Opts) -> - Opts2 = set_dir(Dir, Opts), - loop(From, Size, Opts2). - -do_select_file(File, From, Size, Opts) -> - case filelib:is_file(File) of - true when Opts#opts.type==multiselect -> - From ! {select, File}, - Opts2 = update(File, Opts), - loop(From, Size, Opts2); - true -> % open | save - From ! {fd_result, {ok, File, Opts#opts.dir}}; - false when Opts#opts.type==save -> - case filelib:is_dir(filename:dirname(File)) of - true -> - From ! {fd_result, {ok, File, Opts#opts.dir}}; - false -> - gs:config(select, beep), - loop(From, Size, Opts) - end; - false -> % multiselect | open - gs:config(select, beep), - loop(From, Size, Opts) - end. - -%%--Common GUI functions------------------------------------------------ - --define(UPW, 35). --define(UPH, 30). --define(ENTRYH, 30). - -make_window(Opts) -> - GS = gs:start(), - - Title = case Opts#opts.type of - open -> "Open File"; - save -> "Save File"; - multiselect -> "Select Files" - end, - - Font = case gs:read(GS, {choose_font,{screen,[],12}}) of - Font0 when element(1, Font0)==screen -> - Font0; - _ -> - gs:read(GS, {choose_font,{courier,[],12}}) - end, - - gs:window(win, GS, [{title,Title}, - {width,?WIDTH}, {height,?HEIGHT}, - {configure,true}]), - - Marg = {fixed,5}, - Parent = gs:frame(resizer, win, [{packer_x,[Marg,{stretch,1},Marg]}, - {packer_y,[Marg, - {stretch,10}, - {stretch,1,2*?BTNH}, - Marg]}]), - gs:frame(btnframe, resizer, [{packer_x, [{stretch,1}, - {fixed,?BTNW}, - {stretch,1}, - {fixed,?BTNW}, - {stretch,1}, - {fixed,?BTNW}, - {stretch,1}]}, - {packer_y, [{stretch,1}, - {fixed,?BTNH}, - {stretch,1}]}, - {pack_x,2}, {pack_y,3}]), - - gs:frame(frame, Parent, [{packer_x,[{fixed,?UPW},{stretch,1}]}, - {packer_y,[{fixed,?UPH},{fixed,?ENTRYH}, - {stretch,1}]}, - {pack_x,2}, {pack_y,2}]), - - Fup = filename:join([code:priv_dir(gs),"bitmap","fup.bm"]), - gs:button(up, frame, [{label,{image, Fup}}, - {pack_x,1}, {pack_y,1}]), - gs:label(infodir, frame, [{label,{text," Dir:"}}, {font,Font}, - {pack_x,2}, {pack_y,1}, {align,w}]), - gs:label(l1, frame, [{label,{text,"File:"}}, {font,Font}, {align,e}, - {pack_x,1}, {pack_y,2}]), - - gs:entry(entry, frame, [{font,Font}, {keypress,true}, - {pack_x,2}, {pack_y,2}]), - gs:listbox(lb, frame, [{font,Font}, {pack_x,{1,2}}, {pack_y,3}, - {selectmode,single}, - {vscroll,right}, - {click,true}, {doubleclick,true}]), - - set_dir(Opts#opts.dir, Opts), - - case Opts#opts.type of - multiselect -> - gs:button(select, btnframe, [{label,{text,"Select"}}, - {font,Font}, - {pack_x,2}, {pack_y,2}]), - gs:button(all, btnframe, [{label,{text,"All"}}, {font,Font}, - {pack_x,4}, {pack_y,2}]), - gs:button(close,btnframe,[{label,{text,"Done"}}, - {font,Font}, - {pack_x,6}, {pack_y,2}]); - Type -> - Text = case Type of - open -> "Open"; - save -> "Save" - end, - gs:button(select, btnframe, [{label,{text,Text}}, - {font,Font}, - {pack_x,2}, {pack_y,2}]), - gs:button(cancel, btnframe, [{label,{text,"Cancel"}}, - {font,Font}, - {pack_x,6}, {pack_y,2}]) - end, - - gs:config(resizer, [{width,?WIDTH}, {height,?HEIGHT}]), - gs:config(win, {map,true}). - -%% update(AbsFile, Opts) -> Opts' -update(AbsFile, Opts) -> - Dir = filename:dirname(AbsFile), - File = filename:basename(AbsFile), - - %% Hide the file - Hidden0 = Opts#opts.hidden, - Hidden = case lists:keysearch(Dir, 1, Hidden0) of - {value, {_Dir, Files}} -> - lists:keyreplace(Dir, 1, Hidden0, - {Dir, [File|Files]}); - false -> - [{Dir, [File]} | Hidden0] - end, - Opts2 = Opts#opts{hidden=Hidden}, - set_dir(Dir, Opts2). - -%% select_all() -> {Dirs, Files} -select_all() -> - Is = lists:seq(0, gs:read(lb, size)-1), - sort_selected(Is, [], []). - -sort_selected([I|Is], Dirs, Files) -> - FileOrDir = gs:read(lb, {get,I}), - case lists:last(FileOrDir) of - $/ -> - sort_selected(Is, [drop_last(FileOrDir)|Dirs], Files); - _Ch -> - sort_selected(Is, Dirs, [FileOrDir|Files]) - end; -sort_selected([], Dirs, Files) -> - {Dirs, Files}. - -drop_last(Str) -> - lists:sublist(Str, length(Str)-1). - -%% set_dir(Dir0, Opts) -> Opts' -%% Dir0 = up | string() absolute path only -set_dir(Dir0, Opts) -> - Dir = if - Dir0==up -> filename:dirname(Opts#opts.dir); - true ->Dir0 - end, - - case filelib:is_dir(Dir) of - true -> - gs:config(frame, {cursor,busy}), - gs:config(lb, clear), - Items = get_files(Dir, Opts#opts.hidden, - Opts#opts.extensions), - case Opts#opts.type of - save -> - gs:config(entry, {text,Opts#opts.file}); - _ -> - gs:config(entry, {text,""}) - end, - gs:config(lb, [{items,Items}]), - gs:config(lb, {selection, clear}), - gs:config(infodir, {label,{text,["Dir: "|Dir]}}), - gs:config(frame, {cursor,parent}), - Opts#opts{dir=Dir}; - false -> - gs:config(select, beep), - Opts - end. - -get_files(Dir, Hidden, Exts) -> - {ok, Items0} = file:list_dir(Dir), - - Items = case lists:keysearch(Dir, 1, Hidden) of - {value, {_Dir, HiddenHere}} -> - lists:filter(fun(Item0) -> - not lists:member(Item0, - HiddenHere) - end, - Items0); - false -> - Items0 - end, - - get_files(Dir, Items, [], [], Exts). - -get_files(Dir, [Item0|Items], Dirs, Files, Exts) -> - Item = filename:join(Dir, Item0), - case filelib:is_dir(Item) of - true -> - get_files(Dir, Items, [Item0++"/"|Dirs], Files, Exts); - false -> - case filelib:is_regular(Item) of - true when Exts==[] -> - get_files(Dir, Items, Dirs, [Item0|Files], Exts); - true -> - case lists:member(filename:extension(Item), Exts) of - true -> - get_files(Dir,Items,Dirs,[Item0|Files],Exts); - false -> - get_files(Dir, Items, Dirs, Files, Exts) - end; - false -> - get_files(Dir, Items, Dirs, Files, Exts) - end - end; -get_files(_Dir, [], Dirs, Files, _Exts) -> - lists:sort(Dirs) ++ lists:sort(Files). diff --git a/lib/gs/src/tool_utils.erl b/lib/gs/src/tool_utils.erl deleted file mode 100644 index 841aa926da..0000000000 --- a/lib/gs/src/tool_utils.erl +++ /dev/null @@ -1,438 +0,0 @@ -%% -%% %CopyrightBegin% -%% -%% Copyright Ericsson AB 1997-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(tool_utils). --compile([{nowarn_deprecated_function,{gs,config,2}}, - {nowarn_deprecated_function,{gs,create,3}}, - {nowarn_deprecated_function,{gs,destroy,1}}, - {nowarn_deprecated_function,{gs,read,2}}]). - --include_lib("kernel/include/file.hrl"). - -%%%--------------------------------------------------------------------- -%%% Auxiliary functions to be used by the tools (internal module) -%%%--------------------------------------------------------------------- - -%% External exports --export([open_help/2]). --export([file_dialog/1]). --export([notify/2, confirm/2, confirm_yesno/2, request/2]). - --record(state, {type, % notify | confirm[_yesno] | request - win, % gsobj(), window - entry, % gsobj(), entry - in_focus, % 0 | 1 | undefined Entry is in focus - is_cursor, % bool() | undefined Cursor is over Entry - buttons, % [gsobj()], buttons - highlighted % int() highlighted buttone - }). - - -%%---------------------------------------------------------------------- -%% open_help(Parent, File) -%% Parent = gsobj() (GS root object or parent window) -%% File = string() | nofile -%% View the help file File, which can be an URL, an HTML file or a text -%% file. -%% This function is OS dependant. -%% Unix: Assumes Netscape is up & running, and use Netscape remote -%% commands to display the file. -%% NT: If File is a file, use the NT command 'start' which will open the -%% default tool for viewing the file. -%% If File is an URL, try to view it using Netscape.exe which -%% requires that the path Netscape.exe must be in TBD. -%% (TEMPORARY solution..., can be done better) -%%---------------------------------------------------------------------- -open_help(Parent, nofile) -> - notify(Parent, "Sorry, no help information exists"); -open_help(Parent, File) -> - case application:get_env(kernel, browser_cmd) of - undefined -> - open_help_default(Parent, File); - {ok, Cmd} when is_list(Cmd) -> - spawn(os, cmd, [Cmd ++ " " ++ File]); - {ok, {M, F, A}} -> - apply(M, F, [File|A]); - _Other -> - Str = ["Bad Kernel configuration parameter browser_cmd", - "Do not know how to display help file"], - notify(Parent, Str) - end. - -open_help_default(Parent, File) -> - Cmd = case file_type(File) of - - %% Local file - local -> - case os:type() of - {unix,Type} -> - case Type of - darwin -> "open " ++ File; - _Else -> "netscape -remote \"openURL(file:" ++ File ++ ")\"" - end; - {win32,_AnyType} -> - "start " ++ filename:nativename(File); - - _Other -> - unknown - end; - - %% URL - remote -> - case os:type() of - {unix,Type} -> - case Type of - darwin -> "open " ++ File; - _Else -> "netscape -remote \"openURL(file:" ++ File ++ ")\"" - end; - {win32,_AnyType} -> - "netscape.exe -h " ++ - re:replace(File,"\\\\","/",[global,{return,list}]); - _Other -> - unknown - end; - - Error -> % {error,Reason} - Error - end, - - if - is_list(Cmd) -> - spawn(os, cmd, [Cmd]); - Cmd==unknown -> - Str = ["Sorry, do not know how to", - "display HTML files at this platform"], - notify(Parent, Str); - true -> - {error, Reason} = Cmd, - Str = file:format_error(Reason), - notify(Parent, [File,Str]) - end. - -%% file_type(File) -> local | remote | {error,Reason} -%% File = string() -%% Reason - see file(3) -%% Returns local if File is an existing, readable file -%% Returns remote if File is a remote URL (ie begins with 'http:') -file_type(File) -> - case File of - "http://"++_URL -> - remote; - _ -> - %% HTML files can have a tag (<name>.html#tag), this must be - %% removed when checking if the file exists - File2 = case filename:extension(File) of - ".html#"++_Index -> - filename:rootname(File)++".html"; - _ -> - File - end, - - case file:read_file_info(File2) of - {ok, FileInfo} when FileInfo#file_info.type==regular, - FileInfo#file_info.access/=none -> - local; - {ok, FileInfo} when FileInfo#file_info.type/=regular -> - {error,einval}; - {ok, FileInfo} when FileInfo#file_info.access==none -> - {error,eacces}; - Error -> - Error - end - end. - - -%%---------------------------------------------------------------------- -%% file_dialog(Options) -> tbd -%%---------------------------------------------------------------------- -file_dialog(Options) -> - tool_file_dialog:start(Options). - - -%%---------------------------------------------------------------------- -%% notify(Parent, Strings) -> ok -%% confirm(Parent, Strings) -> ok | cancel -%% confirm_yesno(Parent, Strings) -> yes | no | cancel -%% request(Parent, Strings) -> {ok,string()} | cancel -%% Parent = gsobj() (GS root object or parent window) -%% Strings = string() | [string()] -%% Opens a window with the specified message (Strings) and locks the GUI -%% until the user confirms the message. -%% If the Parent argument is the parent window, the help window will be -%% centered above it, otherwise it can end up anywhere on the screen. -%% A 'notify' window contains an 'Ok' button. -%% A 'confirm' window contains an 'Ok' and a 'Cancel' button. -%% A 'confirm_yesno' window contains a 'Yes', a 'No', and a 'Cancel' -%% button. -%% A 'request' window contains an entry, an 'Ok' and a 'Cancel' button. -%%---------------------------------------------------------------------- --define(Wlbl, 130). --define(Hlbl, 30). --define(Hent, 30). --define(Wbtn, 50). --define(Hbtn, 30). --define(PAD, 10). - -notify(Parent, Strings) -> - help_win(notify, Parent, Strings). -confirm(Parent, Strings) -> - help_win(confirm, Parent, Strings). -confirm_yesno(Parent, Strings) -> - help_win(confirm_yesno, Parent, Strings). -request(Parent, Strings) -> - help_win(request, Parent, Strings). - -help_win(Type, Parent, Strings) -> - GenOpts = [{keypress,true}], - GenOpts2 = [{font,{screen,12}} | GenOpts], - Buttons = buttons(Type), - Nbtn = length(Buttons), - - %% Create the window and its contents - Win = gs:create(window, Parent, [{title,title(Type)} | GenOpts]), - Top = gs:create(frame, Win, GenOpts), - Lbl = gs:create(label, Top, [{align,c}, {justify,center}|GenOpts2]), - Mid = if - Type==request -> gs:create(frame, Win, GenOpts); - true -> ignore - end, - Ent = if - Type==request -> - Events = [{setfocus,true}, - {focus,true},{enter,true},{leave,true}], - gs:create(entry, Mid, GenOpts2++Events); - true -> ignore - end, - Bot = gs:create(frame, Win, GenOpts), - - %% Find out minimum size required for label, entry and buttons - Font = gs:read(Parent, {choose_font, {screen,12}}), - Text = insert_newlines(Strings), - {Wlbl0,Hlbl0} = gs:read(Lbl, {font_wh,{Font,Text}}), - {_Went0,Hent0} = gs:read(Lbl, {font_wh,{Font,"Entry"}}), - {Wbtn0,Hbtn0} = gs:read(Lbl, {font_wh,{Font,"Cancel"}}), - - %% Compute size of the objects and adjust the graphics accordingly - Wbtn = erlang:max(Wbtn0+10, ?Wbtn), - Hbtn = erlang:max(Hbtn0+10, ?Hbtn), - Hent = erlang:max(Hent0+10, ?Hent), - Wlbl = erlang:max(Wlbl0, erlang:max(Nbtn*Wbtn+(Nbtn-1)*?PAD, ?Wlbl)), - Hlbl = erlang:max(Hlbl0, ?Hlbl), - - Wwin = ?PAD+Wlbl+?PAD, - - Htop = ?PAD+Hlbl, - Hmid = if Type==request -> ?PAD+Hent; true -> 0 end, - Hbot = ?PAD+Hbtn+?PAD, - Hwin = Htop+Hmid+Hbot, - - case catch get_coords(Parent, Wwin, Hwin) of - {Xw, Yw} when is_integer(Xw), is_integer(Yw) -> - gs:config(Win, [{x,Xw}, {y,Yw}]); - _ -> - ignore - end, - - gs:config(Win, [ {width,Wwin},{height,Hwin}]), - - gs:config(Top, [{x,0}, {y,0}, {width,Wwin},{height,Htop}]), - gs:config(Lbl, [{x,?PAD},{y,?PAD}, {width,Wlbl},{height,Hlbl}]), - - gs:config(Mid, [{x,0}, {y,Htop}, {width,Wwin},{height,Hmid}]), - gs:config(Ent, [{x,?PAD},{y,?PAD}, {width,Wlbl},{height,Hent}]), - - gs:config(Bot, [{x,0}, {y,Htop+Hmid},{width,Wwin},{height,Hbot}]), - - %% Insert the label text - gs:config(Lbl, {label,{text,Text}}), - - %% Add the buttons - Xbtns = xbuttons(Buttons, Wbtn, Wwin, Wlbl), - BtnObjs = - lists:map(fun({Btext,BX}) -> - gs:create(button, Bot, [{x,BX-1}, {y,?PAD-1}, - {width,Wbtn+2}, - {height,Hbtn+2}, - {label,{text,Btext}}, - {data,data(Btext)} - | GenOpts2]) - end, - Xbtns), - Highlighted = highlight(undef, 1, BtnObjs), - - gs:config(Win, [{map,true}]), - - State = if - Type==request -> - #state{in_focus=1, is_cursor=false}; - true -> - #state{} - end, - event_loop(State#state{type=Type, win=Win, entry=Ent, - buttons=BtnObjs, highlighted=Highlighted}). - -title(notify) -> "Notification"; -title(confirm) -> "Confirmation"; -title(confirm_yesno) -> "Confirmation"; -title(request) -> "Request". - -buttons(notify) -> ["Ok"]; -buttons(confirm) -> ["Ok", "Cancel"]; -buttons(confirm_yesno) -> ["Yes", "No", "Cancel"]; -buttons(request) -> ["Ok", "Cancel"]. - -data("Ok") -> {helpwin,ok}; -data("Yes") -> {helpwin,yes}; -data("No") -> {helpwin,no}; -data("Cancel") -> {helpwin,cancel}. - -get_coords(Parent, W, H) -> - case gs:read(Parent, x) of - X when is_integer(X) -> - case gs:read(Parent, y) of - Y when is_integer(Y) -> - case gs:read(Parent, width) of - W0 when is_integer(W0) -> - case gs:read(Parent, height) of - H0 when is_integer(H0) -> - {round((X+W0/2)-W/2), - round((Y+H0/2)-H/2)}; - _ -> error - end; - _ -> error - end; - _ -> error - end; - _ -> error - end. - -xbuttons([B], Wbtn, Wwin, _Wlbl) -> - [{B, round(Wwin/2-Wbtn/2)}]; -xbuttons([B1,B2], Wbtn, Wwin, Wlbl) -> - Margin = (Wwin-Wlbl)/2, - [{B1,round(Margin)}, {B2,round(Wwin-Margin-Wbtn)}]; -xbuttons([B1,B2,B3], Wbtn, Wwin, Wlbl) -> - Margin = (Wwin-Wlbl)/2, - [{B1,round(Margin)}, - {B2,round(Wwin/2-Wbtn/2)}, - {B3,round(Wwin-Margin-Wbtn)}]. - -highlight(Prev, New, BtnObjs) when New>0, New=<length(BtnObjs) -> - if - Prev==undef -> ignore; - true -> - gs:config(lists:nth(Prev, BtnObjs), [{highlightbw,0}]) - end, - gs:config(lists:nth(New, BtnObjs), [{highlightbw,1}, - {highlightbg,black}]), - New; -highlight(Prev, _New, _BtnObjs) -> % New is outside allowed range - Prev. - -event_loop(State) -> - receive - GsEvent when element(1, GsEvent)==gs -> - case handle_event(GsEvent, State) of - {continue, NewState} -> - event_loop(NewState); - - {return, Result} -> - gs:destroy(State#state.win), - Result - end - end. - -handle_event({gs,_,click,{helpwin,Result},_}, State) -> - if - State#state.type/=request; Result==cancel -> - {return, Result}; - - State#state.type==request, Result==ok -> - case gs:read(State#state.entry, text) of - "" -> - {continue, State}; - Info -> - {return, {ok, Info}} - end - end; - -%% When the entry (Type==request) is in focus and the mouse pointer is -%% over it, don't let 'Left'|'Right' keypresses affect which button is -%% selected -handle_event({gs,Ent,enter,_,_}, #state{entry=Ent}=State) -> - {continue, State#state{is_cursor=true}}; -handle_event({gs,Ent,leave,_,_}, #state{entry=Ent}=State) -> - {continue, State#state{is_cursor=false}}; -handle_event({gs,Ent,focus,_,[Int|_]}, #state{entry=Ent}=State) -> - {continue, State#state{in_focus=Int}}; - -handle_event({gs,Win,keypress,_,['Right'|_]}, #state{win=Win}=State) -> - if - State#state.type==request, - State#state.in_focus==1, State#state.is_cursor==true -> - {continue, State}; - true -> - Prev = State#state.highlighted, - New = highlight(Prev, Prev+1, State#state.buttons), - {continue, State#state{highlighted=New}} - end; -handle_event({gs,Win,keypress,_,['Left'|_]}, #state{win=Win}=State) -> - if - State#state.type==request, - State#state.in_focus==1, State#state.is_cursor==true -> - {continue, State}; - true -> - Prev = State#state.highlighted, - New = highlight(Prev, Prev-1, State#state.buttons), - {continue, State#state{highlighted=New}} - end; - -handle_event({gs,Ent,keypress,_,['Tab'|_]}, #state{entry=Ent}=State) -> - gs:config(hd(State#state.buttons), {setfocus,true}), - gs:config(Ent, {select,clear}), - {continue, State#state{in_focus=0}}; - -handle_event({gs,Win,keypress,_,['Return'|_]}, #state{win=Win}=State) -> - Selected = lists:nth(State#state.highlighted, State#state.buttons), - Data = gs:read(Selected, data), - handle_event({gs,Win,click,Data,undef}, State); - -handle_event({gs,Win,destroy,_,_}, #state{win=Win}=State) -> - if - State#state.type==notify -> {return, ok}; - true -> {return, cancel} - end; - -%% Flush any other GS events -handle_event({gs,_Obj,_Event,_Data,_Arg}, State) -> - {continue, State}. - -%% insert_newlines(Strings) => string() -%% Strings - string() | [string()] -%% If Strings is a list of strings, return a string where all these -%% strings are concatenated with newlines in between,otherwise return -%% Strings. -insert_newlines([String|Rest]) when is_list(String),Rest/=[]-> - String ++ "\n" ++ insert_newlines(Rest); -insert_newlines([Last]) -> - [Last]; -insert_newlines(Other) -> - Other. |