aboutsummaryrefslogtreecommitdiffstats
path: root/lib/gs/src
diff options
context:
space:
mode:
authorBjörn Gustavsson <[email protected]>2016-06-27 11:48:03 +0200
committerBjörn Gustavsson <[email protected]>2016-06-27 11:49:57 +0200
commit6931dce17580d097351dd7be09ce7c9ed3f72827 (patch)
tree2456845e95ed0112c2f08ed8ab6e867686b91d7a /lib/gs/src
parentdfccd57cb2b69fc3ab01acd0ccbfc894a8403358 (diff)
downloadotp-6931dce17580d097351dd7be09ce7c9ed3f72827.tar.gz
otp-6931dce17580d097351dd7be09ce7c9ed3f72827.tar.bz2
otp-6931dce17580d097351dd7be09ce7c9ed3f72827.zip
Remove the gs application
The gs application ws deprecated in R15B01.
Diffstat (limited to 'lib/gs/src')
-rw-r--r--lib/gs/src/Makefile121
-rw-r--r--lib/gs/src/gs.app.src14
-rw-r--r--lib/gs/src/gs.appup.src22
-rw-r--r--lib/gs/src/gs.erl410
-rw-r--r--lib/gs/src/gs_frontend.erl371
-rw-r--r--lib/gs/src/gs_make.erl266
-rw-r--r--lib/gs/src/gs_packer.erl276
-rw-r--r--lib/gs/src/gs_widgets.erl99
-rw-r--r--lib/gs/src/gse.erl788
-rw-r--r--lib/gs/src/gstk.erl389
-rw-r--r--lib/gs/src/gstk.hrl29
-rw-r--r--lib/gs/src/gstk_arc.erl192
-rw-r--r--lib/gs/src/gstk_button.erl221
-rw-r--r--lib/gs/src/gstk_canvas.erl516
-rw-r--r--lib/gs/src/gstk_checkbutton.erl320
-rw-r--r--lib/gs/src/gstk_db.erl413
-rw-r--r--lib/gs/src/gstk_editor.erl400
-rw-r--r--lib/gs/src/gstk_entry.erl234
-rw-r--r--lib/gs/src/gstk_font.erl255
-rw-r--r--lib/gs/src/gstk_frame.erl282
-rw-r--r--lib/gs/src/gstk_generic.erl1089
-rw-r--r--lib/gs/src/gstk_grid.erl284
-rw-r--r--lib/gs/src/gstk_gridline.erl301
-rw-r--r--lib/gs/src/gstk_gs.erl54
-rw-r--r--lib/gs/src/gstk_image.erl321
-rw-r--r--lib/gs/src/gstk_label.erl183
-rw-r--r--lib/gs/src/gstk_line.erl203
-rw-r--r--lib/gs/src/gstk_listbox.erl324
-rw-r--r--lib/gs/src/gstk_menu.erl268
-rw-r--r--lib/gs/src/gstk_menubar.erl176
-rw-r--r--lib/gs/src/gstk_menubutton.erl238
-rw-r--r--lib/gs/src/gstk_menuitem.erl584
-rw-r--r--lib/gs/src/gstk_oval.erl189
-rw-r--r--lib/gs/src/gstk_polygon.erl196
-rw-r--r--lib/gs/src/gstk_port_handler.erl467
-rw-r--r--lib/gs/src/gstk_radiobutton.erl343
-rw-r--r--lib/gs/src/gstk_rectangle.erl186
-rw-r--r--lib/gs/src/gstk_scale.erl215
-rw-r--r--lib/gs/src/gstk_text.erl190
-rw-r--r--lib/gs/src/gstk_widgets.erl94
-rw-r--r--lib/gs/src/gstk_window.erl371
-rw-r--r--lib/gs/src/tcl2erl.erl459
-rw-r--r--lib/gs/src/tool_file_dialog.erl456
-rw-r--r--lib/gs/src/tool_utils.erl438
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.