From 84adefa331c4159d432d22840663c38f155cd4c1 Mon Sep 17 00:00:00 2001 From: Erlang/OTP Date: Fri, 20 Nov 2009 14:54:40 +0000 Subject: The R13B03 release. --- lib/gs/src/Makefile | 118 +++++ lib/gs/src/gs.app.src | 13 + lib/gs/src/gs.appup.src | 1 + lib/gs/src/gs.erl | 403 ++++++++++++++ lib/gs/src/gs_frontend.erl | 368 +++++++++++++ lib/gs/src/gs_make.erl | 264 +++++++++ lib/gs/src/gs_packer.erl | 275 ++++++++++ lib/gs/src/gs_widgets.erl | 98 ++++ lib/gs/src/gse.erl | 725 +++++++++++++++++++++++++ lib/gs/src/gstk.erl | 386 ++++++++++++++ lib/gs/src/gstk.hrl | 28 + lib/gs/src/gstk_arc.erl | 190 +++++++ lib/gs/src/gstk_button.erl | 220 ++++++++ lib/gs/src/gstk_canvas.erl | 513 ++++++++++++++++++ lib/gs/src/gstk_checkbutton.erl | 319 +++++++++++ lib/gs/src/gstk_db.erl | 412 +++++++++++++++ lib/gs/src/gstk_editor.erl | 396 ++++++++++++++ lib/gs/src/gstk_entry.erl | 232 ++++++++ lib/gs/src/gstk_font.erl | 254 +++++++++ lib/gs/src/gstk_frame.erl | 281 ++++++++++ lib/gs/src/gstk_generic.erl | 1087 ++++++++++++++++++++++++++++++++++++++ lib/gs/src/gstk_grid.erl | 282 ++++++++++ lib/gs/src/gstk_gridline.erl | 298 +++++++++++ lib/gs/src/gstk_gs.erl | 53 ++ lib/gs/src/gstk_image.erl | 319 +++++++++++ lib/gs/src/gstk_label.erl | 182 +++++++ lib/gs/src/gstk_line.erl | 202 +++++++ lib/gs/src/gstk_listbox.erl | 323 +++++++++++ lib/gs/src/gstk_menu.erl | 266 ++++++++++ lib/gs/src/gstk_menubar.erl | 175 ++++++ lib/gs/src/gstk_menubutton.erl | 237 +++++++++ lib/gs/src/gstk_menuitem.erl | 582 ++++++++++++++++++++ lib/gs/src/gstk_oval.erl | 188 +++++++ lib/gs/src/gstk_polygon.erl | 195 +++++++ lib/gs/src/gstk_port_handler.erl | 465 ++++++++++++++++ lib/gs/src/gstk_radiobutton.erl | 342 ++++++++++++ lib/gs/src/gstk_rectangle.erl | 184 +++++++ lib/gs/src/gstk_scale.erl | 214 ++++++++ lib/gs/src/gstk_text.erl | 189 +++++++ lib/gs/src/gstk_widgets.erl | 93 ++++ lib/gs/src/gstk_window.erl | 369 +++++++++++++ lib/gs/src/tcl2erl.erl | 457 ++++++++++++++++ lib/gs/src/tool_file_dialog.erl | 445 ++++++++++++++++ lib/gs/src/tool_utils.erl | 434 +++++++++++++++ 44 files changed, 13077 insertions(+) create mode 100644 lib/gs/src/Makefile create mode 100644 lib/gs/src/gs.app.src create mode 100644 lib/gs/src/gs.appup.src create mode 100644 lib/gs/src/gs.erl create mode 100644 lib/gs/src/gs_frontend.erl create mode 100644 lib/gs/src/gs_make.erl create mode 100644 lib/gs/src/gs_packer.erl create mode 100644 lib/gs/src/gs_widgets.erl create mode 100644 lib/gs/src/gse.erl create mode 100644 lib/gs/src/gstk.erl create mode 100644 lib/gs/src/gstk.hrl create mode 100644 lib/gs/src/gstk_arc.erl create mode 100644 lib/gs/src/gstk_button.erl create mode 100644 lib/gs/src/gstk_canvas.erl create mode 100644 lib/gs/src/gstk_checkbutton.erl create mode 100644 lib/gs/src/gstk_db.erl create mode 100644 lib/gs/src/gstk_editor.erl create mode 100644 lib/gs/src/gstk_entry.erl create mode 100644 lib/gs/src/gstk_font.erl create mode 100644 lib/gs/src/gstk_frame.erl create mode 100644 lib/gs/src/gstk_generic.erl create mode 100644 lib/gs/src/gstk_grid.erl create mode 100644 lib/gs/src/gstk_gridline.erl create mode 100644 lib/gs/src/gstk_gs.erl create mode 100644 lib/gs/src/gstk_image.erl create mode 100644 lib/gs/src/gstk_label.erl create mode 100644 lib/gs/src/gstk_line.erl create mode 100644 lib/gs/src/gstk_listbox.erl create mode 100644 lib/gs/src/gstk_menu.erl create mode 100644 lib/gs/src/gstk_menubar.erl create mode 100644 lib/gs/src/gstk_menubutton.erl create mode 100644 lib/gs/src/gstk_menuitem.erl create mode 100644 lib/gs/src/gstk_oval.erl create mode 100644 lib/gs/src/gstk_polygon.erl create mode 100644 lib/gs/src/gstk_port_handler.erl create mode 100644 lib/gs/src/gstk_radiobutton.erl create mode 100644 lib/gs/src/gstk_rectangle.erl create mode 100644 lib/gs/src/gstk_scale.erl create mode 100644 lib/gs/src/gstk_text.erl create mode 100644 lib/gs/src/gstk_widgets.erl create mode 100644 lib/gs/src/gstk_window.erl create mode 100644 lib/gs/src/tcl2erl.erl create mode 100644 lib/gs/src/tool_file_dialog.erl create mode 100644 lib/gs/src/tool_utils.erl (limited to 'lib/gs/src') diff --git a/lib/gs/src/Makefile b/lib/gs/src/Makefile new file mode 100644 index 0000000000..a648d3cf13 --- /dev/null +++ b/lib/gs/src/Makefile @@ -0,0 +1,118 @@ +# +# %CopyrightBegin% +# +# Copyright Ericsson AB 1996-2009. All Rights Reserved. +# +# The contents of this file are subject to the Erlang Public License, +# Version 1.1, (the "License"); you may not use this file except in +# compliance with the License. You should have received a copy of the +# Erlang Public License along with this software. If not, it can be +# retrieved online at http://www.erlang.org/. +# +# Software distributed under the License is distributed on an "AS IS" +# basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +# the License for the specific language governing rights and limitations +# under the License. +# +# %CopyrightEnd% +# + +# +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 + +# ---------------------------------------------------- +# Targets +# ---------------------------------------------------- + +debug opt: $(TARGET_FILES) + +docs: + +clean: + rm -f $(TARGET_FILES) + rm -f core *~ + +# ---------------------------------------------------- +# Special Build Targets +# ---------------------------------------------------- + +gstk_generic.hrl: gs_make.erl + $(ERL) -pa $(EBIN) -s gs_make -s erlang halt -noshell + +$(APP_TARGET): $(APP_SRC) ../vsn.mk + sed -e 's;%VSN%;$(VSN);' $< > $@ + +$(APPUP_TARGET): $(APPUP_SRC) ../vsn.mk + sed -e 's;%VSN%;$(VSN);' $< > $@ + +# ---------------------------------------------------- +# 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 new file mode 100644 index 0000000000..c83c9b54d7 --- /dev/null +++ b/lib/gs/src/gs.app.src @@ -0,0 +1,13 @@ +{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]}]}. diff --git a/lib/gs/src/gs.appup.src b/lib/gs/src/gs.appup.src new file mode 100644 index 0000000000..54a63833e6 --- /dev/null +++ b/lib/gs/src/gs.appup.src @@ -0,0 +1 @@ +{"%VSN%",[],[]}. diff --git a/lib/gs/src/gs.erl b/lib/gs/src/gs.erl new file mode 100644 index 0000000000..3e9a1c4b8b --- /dev/null +++ b/lib/gs/src/gs.erl @@ -0,0 +1,403 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1996-2009. All Rights Reserved. +%% +%% The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved online at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% %CopyrightEnd% +%% + +%% +%% ------------------------------------------------------------ +%% Erlang Graphics Interface and front end server +%% ------------------------------------------------------------ +%% + +-module(gs). + + +%% ----- 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 new file mode 100644 index 0000000000..009b264e69 --- /dev/null +++ b/lib/gs/src/gs_frontend.erl @@ -0,0 +1,368 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1996-2009. All Rights Reserved. +%% +%% The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved online at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% %CopyrightEnd% +%% + +%% +%% ------------------------------------------------------------ +%% Erlang Graphics Interface front-end server +%% ------------------------------------------------------------ +%% + +-module(gs_frontend). + +-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 new file mode 100644 index 0000000000..e41183f9bf --- /dev/null +++ b/lib/gs/src/gs_make.erl @@ -0,0 +1,264 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1996-2009. All Rights Reserved. +%% +%% The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved online at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% %CopyrightEnd% +%% + +%% +-module(gs_make). + +-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 new file mode 100644 index 0000000000..a06ec37e5b --- /dev/null +++ b/lib/gs/src/gs_packer.erl @@ -0,0 +1,275 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1997-2009. All Rights Reserved. +%% +%% The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved online at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% %CopyrightEnd% +%% + +%% +%% ------------------------------------------------------------ +%% 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 new file mode 100644 index 0000000000..ffd4530eb4 --- /dev/null +++ b/lib/gs/src/gs_widgets.erl @@ -0,0 +1,98 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1996-2009. All Rights Reserved. +%% +%% The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved online at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% %CopyrightEnd% +%% + +%% +%% ------------------------------------------------------------ +%% 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 new file mode 100644 index 0000000000..b3ea2af4d4 --- /dev/null +++ b/lib/gs/src/gse.erl @@ -0,0 +1,725 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1997-2009. All Rights Reserved. +%% +%% The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved online at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% %CopyrightEnd% +%% + +%% +%%%---------------------------------------------------------------------- +%%% Purpose : Wrapper library for GS to provide proper error handling +%%%---------------------------------------------------------------------- + +-module(gse). + +%%-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 new file mode 100644 index 0000000000..6f83cf8be4 --- /dev/null +++ b/lib/gs/src/gstk.erl @@ -0,0 +1,386 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1996-2009. All Rights Reserved. +%% +%% The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved online at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% %CopyrightEnd% +%% + +%% + +-module(gstk). + +-export([start_link/4, + stop/1, + create/2, + config/2, + read/2, + destroy/2, + pid_died/2, + event/2, + request/2, + init/1, + create_impl/2, + config_impl/3, + read_impl/3, + destroy_impl/2, + worker_init/1, + worker_do/1, + make_extern_id/2, + to_color/1, + to_ascii/1, + exec/1, + call/1]). + +-include("gstk.hrl"). + +start_link(GsId,FrontendNode,Owner,Options) -> + case gs:assq(node,Options) of + false -> + Gstk = spawn_link(gstk, init,[{GsId, FrontendNode, Owner, Options}]), + receive + {ok, _PortHandler} -> + {ok, Gstk}; + {error, Reason} -> + {error, Reason} + end; + {value, Node} -> + rpc:call(Node,gen_server,start_link,[gstk, {Owner,Options},[]]) + end. + +stop(BackendServ) -> + request(BackendServ,stop). + +create(BackendServ,Args) -> + request(BackendServ,{create,Args}). + +config(BackendServ,Args) -> + request(BackendServ,{config,Args}). + +read(BackendServ,Args) -> + request(BackendServ,{read,Args}). + +destroy(BackendServ,Args) -> + request(BackendServ,{destroy,Args}). + +pid_died(BackendServ,Pid) -> + request(BackendServ,{pid_died,Pid}). + +call(Cmd) -> + %%io:format("Call:~p~n",[Cmd]), + gstk_port_handler:call(get(port_handler),Cmd). + +exec(Cmd) -> + gstk_port_handler:exec(Cmd). + +make_extern_id(IntId, DB) -> + [{_,Node}] = ets:lookup(DB,frontend_node), + {IntId,Node}. + +event(BackendServ,Event) -> + BackendServ!{event,Event}. + +%% ----------------------------------------------------------------------------- + +request(Who,Msg) -> + Who ! {self(),Msg}, + receive + {gstk_reply,R} -> R; + {'EXIT',Who,Reason} -> + self() ! {'EXIT',Who,Reason}, + {error,Reason} + end. + + +-record(state,{db,frontendnode,port_handler}). + +%% ------------------------------------------------------------ +%% Initialize +%% +init({GsId,FrontendNode,Owner,Opts}) -> + put(gs_frontend,Owner), + case gstk_port_handler:start_link(self()) of + {error, Reason} -> + FrontendNode ! {error, Reason}, + exit(normal); + {ok, PortHandler} -> + FrontendNode ! {ok, PortHandler}, + put(port_handler,PortHandler), + {ok,Port} = gstk_port_handler:ping(PortHandler), + put(port,Port), + exec("wm withdraw ."), + DB = gstk_db:init(Opts), + ets:insert(DB,{frontend_node,FrontendNode}), + put(worker,spawn_link(gstk,worker_init,[0])), + Gstkid = #gstkid{id=GsId,widget="",owner=Owner,objtype=gs}, + gstk_db:insert_gs(DB,Gstkid), + gstk_font:init(), + loop(#state{db=DB,frontendnode=FrontendNode}) + end. + +loop(State) -> + receive + X -> + case (doit(X,State)) of + done -> loop(State); + stop -> bye + end + end. + +reply(To,Msg) -> + To ! {gstk_reply,Msg}, + done. + +doit({From,{config, {Id, Opts}}},#state{db=DB}) -> + reply(From,config_impl(DB,Id,Opts)); +doit({From,{create, Args}}, #state{db=DB}) -> + reply(From,create_impl(DB,Args)); +doit({From,{read,{Id,Opt}}},#state{db=DB}) -> + reply(From,read_impl(DB,Id,Opt)); +doit({From,{pid_died, Pid}}, #state{db=DB}) -> + pid_died_impl(DB, Pid), + reply(From,gstk_db:get_deleted(DB)); +doit({From,{destroy, Id}}, #state{db=DB}) -> + destroy_impl(DB, gstk_db:lookup_gstkid(DB,Id)), + reply(From,gstk_db:get_deleted(DB)); + +doit({From,dump_db},State) -> + io:format("gstk_db:~p~n",[lists:sort(ets:tab2list(State#state.db))]), + io:format("events:~p~n",[lists:sort(ets:tab2list(get(events)))]), + io:format("options:~p~n",[lists:sort(ets:tab2list(get(options)))]), + io:format("defaults:~p~n",[lists:sort(ets:tab2list(get(defaults)))]), + io:format("kids:~p~n",[lists:sort(ets:tab2list(get(kids)))]), + reply(From,State); + +doit({From,stop},_State) -> + gstk_port_handler:stop(get(port_handler)), + exit(get(worker),kill), + reply(From,stopped), + stop; + +doit({event,{Id, Etag, Args}},#state{db=DB}) -> + case gstk_db:lookup_event(DB, Id, Etag) of + {Etype, Edata} -> + Gstkid = gstk_db:lookup_gstkid(DB, Id), + apply(gstk_widgets:objmod(Gstkid),event,[DB,Gstkid,Etype,Edata,Args]); + _ -> true + end, + done. + + +%%---------------------------------------------------------------------- +%% Implementation of create,config,read,destroy +%% Comment: In the gstk process there is not concept call 'name', only +%% pure oids. Names are stripped of by 'gs' and this simplifies +%% gstk a lot. +%% Comment: For performance reasons gstk.erl ans gs.erl communicats through +%% tuples. This is unfortunate but we don't want to pack the same +%% thing too many times. +%% Pre (for all functions): GS guarantees that the object (and parent if +%% necessary) exists. +%%---------------------------------------------------------------------- + + +create_impl(DB, {Owner, {Objtype, Id, Parent, Opts}}) -> + Pgstkid = gstk_db:lookup_gstkid(DB, Parent), + GstkId=#gstkid{id=Id,owner=Owner,parent=Parent,objtype=Objtype}, + gstk_db:insert_opt(DB,Id,{data,[]}), + RealOpts=apply(gstk_widgets:objmod(Pgstkid), + mk_create_opts_for_child,[DB,GstkId,Pgstkid,Opts]), + case gstk_widgets:type2mod(Objtype) of + {error,Reason} -> {error,Reason}; + ObjMod -> + case apply(ObjMod, create, [DB, GstkId, RealOpts]) of + {bad_result, BR} -> + gstk_db:delete_gstkid(DB,GstkId), + gs:creation_error(GstkId,{bad_result, BR}); + Ngstkid when is_record(Ngstkid,gstkid) -> + gstk_db:insert_widget(DB, Ngstkid), + ok; + {error,Reason} -> {error,Reason}; + ok -> ok + end + end. + +config_impl(DB,Id,Opts) -> + Gstkid = gstk_db:lookup_gstkid(DB, Id), + case apply(gstk_widgets:objmod(Gstkid), config, [DB, Gstkid, Opts]) of + ok -> ok; + {bad_result,R} -> {error,R}; + {error,Reason} -> {error,Reason}; + Q -> {error,Q} + end. + + +read_impl(DB,Id,Opt) -> + Gstkid = gstk_db:lookup_gstkid(DB, Id), + case apply(gstk_widgets:objmod(Gstkid), read, [DB, Gstkid, Opt]) of + {bad_result,R} -> {error,R}; + {error,R} -> {error,R}; + Res -> Res + end. + + + +%%----------------------------------------------------------------------------- +%% DESTROYING A WIDGET +%%----------------------------------------------------------------------------- + +destroy_impl(DB, Gstkid) -> + worker_do({delay_is,50}), + Widget = delete_only_this_widget(DB,Gstkid), + destroy_widgets([Widget], DB), + worker_do({delay_is,5}), + true. + +delete_only_this_widget(DB,Gstkid) -> + #gstkid{id=ID,objtype=OT,parent=P} = Gstkid, + delete_widgets(gstk_db:lookup_kids(DB, ID), DB), + Widget = apply(gstk_widgets:type2mod(OT), delete, [DB, Gstkid]), + gstk_db:delete_kid(DB, P, ID), + Widget. + + +pid_died_impl(DB, Pid) -> + case lists:sort(gstk_db:lookup_ids(DB, Pid)) of + [ID | IDs] -> + Gstkid = gstk_db:lookup_gstkid(DB, ID), + destroy_impl(DB, Gstkid), + Tops = get_tops(IDs, DB), + destroy_widgets(Tops, DB); + _ -> + true + end. + + +get_tops([ID | IDs], DB) -> + case gstk_db:lookup_gstkid(DB, ID) of + undefined -> + get_tops(IDs, DB); + Gstkid -> + Parent = Gstkid#gstkid.parent, + case lists:member(Parent, IDs) of + true -> + delete_widgets([ID], DB), + get_tops(IDs, DB); + false -> + Widget = delete_only_this_widget(DB,Gstkid), + [Widget | get_tops(IDs, DB)] + end + end; +get_tops([], _DB) -> []. + + +delete_widgets([ID | Rest], DB) -> + delete_widgets(gstk_db:lookup_kids(DB, ID), DB), + case gstk_db:lookup_gstkid(DB, ID) of + undefined -> + delete_widgets(Rest, DB); + Gstkid -> + apply(gstk_widgets:objmod(Gstkid), delete, [DB, Gstkid]), + delete_widgets(Rest, DB) + end; +delete_widgets([], _) -> true. + + + +destroy_widgets(Widgets, DB) -> + case destroy_wids(Widgets, DB) of + [] -> true; + Destroys -> exec(["destroy ", Destroys]) + end. + + +destroy_wids([{Parent, ID, Objmod, Args} | Rest], DB) -> + gstk_db:delete_kid(DB, Parent, ID), + apply(Objmod, destroy, [DB | Args]), + destroy_wids(Rest, DB); + +destroy_wids([W | Rest], DB) -> + [W, " "| destroy_wids(Rest, DB)]; + +destroy_wids([], _DB) -> []. + + +%% ----- The Color Model ----- + +to_color({R,G,B}) -> + [$#,dec2hex(2,R),dec2hex(2,G),dec2hex(2,B)]; +to_color(Color) when is_atom(Color) -> atom_to_list(Color). + +%% ------------------------------------------------------------ +%% Decimal to Hex converter +%% M is number of digits we want +%% N is the decimal to be converted + +dec2hex(M,N) -> dec2hex(M,N,[]). + +dec2hex(0,_N,Ack) -> Ack; +dec2hex(M,N,Ack) -> dec2hex(M-1,N bsr 4,[d2h(N band 15)|Ack]). + +d2h(N) when N<10 -> N+$0; +d2h(N) -> N+$a-10. + + +%% ----- Value to String ----- + +to_ascii(V) when is_list(V) -> [$",to_ascii(V,[],[]),$"]; %% it's a string +to_ascii(V) when is_integer(V) -> integer_to_list(V); +to_ascii(V) when is_float(V) -> float_to_list(V); +to_ascii(V) when is_atom(V) -> to_ascii( atom_to_list(V)); +to_ascii(V) when is_tuple(V) -> to_ascii(lists:flatten(io_lib:format("~w",[V]))); +to_ascii(V) when is_pid(V) -> pid_to_list(V). + + % FIXME: Currently we accept newlines in strings and handle this at + % the Tcl side. Is this the best way or should we translate to "\n" + % here? +to_ascii([$[|R], Y, X) -> to_ascii(R, Y, [$[, $\\ | X]); + to_ascii([$]|R], Y, X) -> to_ascii(R, Y, [$], $\\ | X]); +to_ascii([${|R], Y, X) -> to_ascii(R, Y, [${, $\\ | X]); + to_ascii([$}|R], Y, X) -> to_ascii(R, Y, [$}, $\\ | X]); +to_ascii([$"|R], Y, X) -> to_ascii(R, Y, [$", $\\ | X]); +to_ascii([$$|R], Y, X) -> to_ascii(R, Y, [$$, $\\ | X]); +to_ascii([$\\|R], Y, X) -> to_ascii(R, Y, [$\\, $\\ | X]); +to_ascii([C|R], Y, X) when is_list(C) -> to_ascii(C, [R|Y], X); +to_ascii([C|R], Y, X) -> to_ascii(R, Y, [C|X]); +to_ascii([], [Y1|Y], X) -> to_ascii(Y1, Y, X); +to_ascii([], [], X) -> lists:reverse(X). + +worker_do(Msg) -> + get(worker) ! Msg. + +worker_init(Delay) -> + receive + {delay_is,D} -> + worker_init(D); + {match_delete,DBExprs} -> + worker_match(DBExprs), + if Delay > 0 -> + receive + {delay_is,D} -> + worker_init(D) + after Delay -> + worker_init(Delay) + end; + true -> + worker_init(Delay) + end + end. + +worker_match([{DB,[Expr|Exprs]}|DbExprs]) -> + ets:match_delete(DB,Expr), + worker_match([{DB,Exprs}|DbExprs]); +worker_match([{_DB,[]}|DbExprs]) -> + worker_match(DbExprs); +worker_match([]) -> done. diff --git a/lib/gs/src/gstk.hrl b/lib/gs/src/gstk.hrl new file mode 100644 index 0000000000..2754f74b9b --- /dev/null +++ b/lib/gs/src/gstk.hrl @@ -0,0 +1,28 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1996-2009. All Rights Reserved. +%% +%% The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved online at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% %CopyrightEnd% +%% + +%% + +%% *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 new file mode 100644 index 0000000000..8e80ef92b5 --- /dev/null +++ b/lib/gs/src/gstk_arc.erl @@ -0,0 +1,190 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1996-2009. All Rights Reserved. +%% +%% The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved online at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% %CopyrightEnd% +%% + +%% +%% ------------------------------------------------------------ +%% Basic Arc Type +%% ------------------------------------------------------------ + +-module(gstk_arc). + +%%----------------------------------------------------------------------------- +%% 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 new file mode 100644 index 0000000000..0ef6f877b4 --- /dev/null +++ b/lib/gs/src/gstk_button.erl @@ -0,0 +1,220 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1996-2009. All Rights Reserved. +%% +%% The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved online at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% %CopyrightEnd% +%% + +%% +%% ------------------------------------------------------------ +%% 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 new file mode 100644 index 0000000000..868b3020fe --- /dev/null +++ b/lib/gs/src/gstk_canvas.erl @@ -0,0 +1,513 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1996-2009. All Rights Reserved. +%% +%% The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved online at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% %CopyrightEnd% +%% + +%% +%% ------------------------------------------------------------ +%% Basic Canvas Type +%% ------------------------------------------------------------ + +-module(gstk_canvas). + +%%----------------------------------------------------------------------------- +%% 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 {erlsend ", CRef, + " [",Canvas, " find withtag current]};"], + DRef = gstk_db:insert_event(DB, GridGstkid, doubleclick, []), + DclickCmd = [Canvas," bind all {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, " {erlsend ", Eref, " [", + TkW, " canvasx %x] [", TkW, " canvasy %y] %x %y}"]; + keypress -> + [P, " {erlsend ", Eref," %K %N 0 0 [", + TkW, " canvasx %x] [", TkW, " canvasy %y]};", + P, " {erlsend ", Eref, " %K %N 1 0 [", + TkW, " canvasx %x] [", TkW, " canvasy %y]};", + P, " {erlsend ", Eref, " %K %N 0 1 [", + TkW, " canvasx %x] [", TkW, " canvasy %y]};", + P, " {erlsend ", Eref," %K %N 1 1 [", + TkW, " canvasx %x] [", TkW, " canvasy %y]}"]; + keyrelease -> + [P, " {erlsend ", Eref," %K %N 0 0 [", + TkW, " canvasx %x] [", TkW, " canvasy %y]};", + P, " {erlsend ", Eref, " %K %N 1 0 [", + TkW, " canvasx %x] [", TkW, " canvasy %y]};", + P, " {erlsend ", Eref, " %K %N 0 1 [", + TkW, " canvasx %x] [", TkW, " canvasy %y]};", + P," {erlsend ",Eref," %K %N 1 1[", + TkW, " canvasx %x] [", TkW, " canvasy %y]}"]; + buttonpress -> + [P, "