diff options
Diffstat (limited to 'lib/gs/src')
44 files changed, 13077 insertions, 0 deletions
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 <ButtonRelease-1> {erlsend ", CRef, + " [",Canvas, " find withtag current]};"], + DRef = gstk_db:insert_event(DB, GridGstkid, doubleclick, []), + DclickCmd = [Canvas," bind all <Double-ButtonRelease-1> {erlsend ", + DRef," [",Canvas, " find withtag current]}"], + %% bind all at once for preformance reasons. + {c, [ClickCmd,DclickCmd]}; + {secret_forwarded_grid_event, {Event,On},GridGstkid} -> + bind(DB,GridGstkid,Canvas,Event,On); + _ -> invalid_option + end. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : read_option/5 +%% Purpose : Take care of a read option +%% Return : The value of the option or invalid_option +%% [OptionValue | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +read_option(Option,Gstkid,_MainW,DB,Canvas) -> + case Option of + scrollregion -> gstk_db:opt(DB,Gstkid,scrollregion); + {hit, {X,Y}} -> + hit(DB,Canvas,X,Y,X,Y); + {hit, [{X1,Y1},{X2,Y2}]} -> + hit(DB,Canvas,X1,Y1,X2,Y2); + % {% hidden above, % of total area that is visible + % hidden above} + yscrollpos -> + {PercentOffViewTop,_} = tcl2erl:ret_tuple([Canvas," yvi"]), + {_,Ymin,_,Ymax} = gstk_db:opt(DB,Gstkid,scrollregion), + K = 1/(Ymax-Ymin), + M = -K*Ymin, + _Y = round((PercentOffViewTop - M)/K); + xscrollpos -> + {PercentOffViewLeft,_} = tcl2erl:ret_tuple([Canvas," xvi"]), + {Xmin,_,Xmax,_} = gstk_db:opt(DB,Gstkid,scrollregion), + K = 1/(Xmax-Xmin), + M = -K*Xmin, + _X = round((PercentOffViewLeft-M)/K); + buttonpress -> gstk_db:is_inserted(DB, Gstkid, buttonpress); + buttonrelease -> gstk_db:is_inserted(DB, Gstkid, buttonrelease); + configure -> gstk_db:is_inserted(DB, Gstkid, configure); + destroy -> gstk_db:is_inserted(DB, Gstkid, destroy); + enter -> gstk_db:is_inserted(DB, Gstkid, enter); + focus -> gstk_db:is_inserted(DB, Gstkid, focus); + keypress -> gstk_db:is_inserted(DB, Gstkid, keypress); + keyrelease -> gstk_db:is_inserted(DB, Gstkid, keyrelease); + leave -> gstk_db:is_inserted(DB, Gstkid, leave); + motion -> gstk_db:is_inserted(DB, Gstkid, motion); + + _ -> {bad_result, {Gstkid#gstkid.objtype, invalid_option, Option}} + end. + +hit(DB,Canvas,X1,Y1,X2,Y2) -> + Ax1 = gstk:to_ascii(X1), + Ay1 = gstk:to_ascii(Y1), + Ax2 = gstk:to_ascii(X2), + Ay2 = gstk:to_ascii(Y2), + case tcl2erl:ret_list([Canvas," find overlapping ", + Ax1,$ ,Ay1,$ ,Ax2,$ ,Ay2]) of + Items when is_list(Items) -> + [{_,Node}] = ets:lookup(DB,frontend_node), + fix_ids(Items,DB,Canvas,Node); + Other -> + {bad_result, Other} + end. + +fix_ids([Item|Items],DB,Canvas,Node) -> + [{gstk_db:lookup_item(DB,Canvas,Item),Node}|fix_ids(Items,DB,Canvas,Node)]; +fix_ids([],_,_,_) -> []. + +%%----------------------------------------------------------------------------- +%% PRIMITIVES +%%----------------------------------------------------------------------------- + +%% +%% Event bind main function +%% +%% Should return a list of tcl commands or invalid_option +%% +%% WS = Widget suffix for c widgets +%% +bind(DB, Gstkid, TkW, Etype, On) -> + case bind(DB, Gstkid, TkW, Etype, On, "") of + invalid_option -> invalid_option; + Cmd -> {c, Cmd} + end. + +bind(DB, Gstkid, TkW, Etype, On, WS) -> + case On of + true -> ebind(DB, Gstkid, TkW, Etype, WS, ""); + false -> eunbind(DB, Gstkid, TkW, Etype, WS, ""); + {true, Edata} -> ebind(DB, Gstkid, TkW, Etype, WS, Edata); + {false, Edata} -> eunbind(DB, Gstkid, TkW, Etype, WS, Edata); + _ -> invalid_option + end. + + +%% +%% Event bind on +%% +%% Should return a list of tcl commands or invalid_option +%% +%% WS = Widget suffix for complex widgets +%% +ebind(DB, Gstkid, TkW, Etype, WS, Edata) -> + Eref = gstk_db:insert_event(DB, Gstkid, Etype, Edata), + P = ["bind ", TkW, WS], + Cmd = case Etype of + motion -> [P, " <Motion> {erlsend ", Eref, " [", + TkW, " canvasx %x] [", TkW, " canvasy %y] %x %y}"]; + keypress -> + [P, " <Key> {erlsend ", Eref," %K %N 0 0 [", + TkW, " canvasx %x] [", TkW, " canvasy %y]};", + P, " <Shift-Key> {erlsend ", Eref, " %K %N 1 0 [", + TkW, " canvasx %x] [", TkW, " canvasy %y]};", + P, " <Control-Key> {erlsend ", Eref, " %K %N 0 1 [", + TkW, " canvasx %x] [", TkW, " canvasy %y]};", + P, " <Control-Shift-Key> {erlsend ", Eref," %K %N 1 1 [", + TkW, " canvasx %x] [", TkW, " canvasy %y]}"]; + keyrelease -> + [P, " <KeyRelease> {erlsend ", Eref," %K %N 0 0 [", + TkW, " canvasx %x] [", TkW, " canvasy %y]};", + P, " <Shift-KeyRelease> {erlsend ", Eref, " %K %N 1 0 [", + TkW, " canvasx %x] [", TkW, " canvasy %y]};", + P, " <Control-KeyRelease> {erlsend ", Eref, " %K %N 0 1 [", + TkW, " canvasx %x] [", TkW, " canvasy %y]};", + P," <Control-Shift-KeyRelease> {erlsend ",Eref," %K %N 1 1[", + TkW, " canvasx %x] [", TkW, " canvasy %y]}"]; + buttonpress -> + [P, " <Button> {erlsend ", Eref, " %b [", + TkW, " canvasx %x] [", TkW, " canvasy %y] %x %y}"]; + buttonrelease -> + [P, " <ButtonRelease> {erlsend ", Eref, " %b [", + TkW, " canvasx %x] [", TkW, " canvasy %y] %x %y}"]; + leave -> [P, " <Leave> {erlsend ", Eref, "}"]; + enter -> [P, " <Enter> {erlsend ", Eref, "}"]; + destroy -> + [P, " <Destroy> {if {\"%W\"==\"", [TkW, WS], + "\"} {erlsend ", Eref, "}}"]; + focus -> + [P, " <FocusIn> {erlsend ", Eref, " true};" , + P, " <FocusOut> {erlsend ", Eref, " false}"]; + configure -> + [P, " <Configure> {if {\"%W\"==\"", [TkW, WS], + "\"} {erlsend ", Eref, " %w %h %x %y}}"] + end, + Cmd. + + +%% +%% Unbind event +%% +%% Should return a list of tcl commands +%% Already checked for validation in bind/5 +%% +%% WS = Widget suffix for complex widgets +%% +eunbind(DB, Gstkid, TkW, Etype, WS, _Edata) -> + gstk_db:delete_event(DB, Gstkid, Etype), + P = ["bind ", TkW, WS], + Cmd = case Etype of + motion -> + [P, " <Motion> {}"]; + keypress -> + [P, " <KeyRelease> {};", + P, " <Shift-KeyRelease> {};", + P, " <Control-KeyRelease> {};", + P, " <Control-Shift-KeyRelease> {}"]; + keyrelease -> + [P, " <KeyRelease> {};", + P, " <Shift-KeyRelease> {};", + P, " <Control-KeyRelease> {};", + P, " <Control-Shift-KeyRelease> {}"]; + buttonpress -> + [P, " <ButtonPress> {}"]; + buttonrelease -> + [P, " <ButtonRelease> {}"]; + leave -> + [P, " <Leave> {}"]; + enter -> + [P, " <Enter> {}"]; + destroy -> + [P, " <Destroy> {}"]; + focus -> + [P, " <FocusIn> {};", + P, " <FocusOut> {}"]; + configure -> + [P, " <Configure> {}"] + end, + Cmd. + +%%====================================================================== +%% Item library +%%====================================================================== + +mk_cmd_and_exec(Options, Gstkid, Canvas, AItem, SCmd, DB) -> + case make_command(Options, Gstkid, Canvas, AItem, SCmd, DB) of + {error,Reason} -> {error,Reason}; + Cmd when is_list(Cmd) -> + gstk:exec(Cmd) + end. + +mk_cmd_and_call(Opts,Gstkid, CanvasTkW, MCmd, DB) -> + case make_command(Opts,Gstkid, CanvasTkW, MCmd, DB) of + {error,Reason} -> {error,Reason}; + Cmd when is_list(Cmd) -> + case tcl2erl:ret_int(Cmd) of + Item when is_integer(Item) -> + G2 = gstk_db:lookup_gstkid(DB,Gstkid#gstkid.id), % buu, not nice + NewGstkid = G2#gstkid{widget_data=Item}, + NewGstkid; + Bad_result -> + {error,Bad_result} + end + end. + + +%%---------------------------------------------------------------------- +%% MCmd = Mandatory command +%% Comment: The problem: Create everything in one async command and +%% get the canvas obj integer id no back then. +%% The trick is to do: +%% set w [canvas create rectangle x1 y1 x2 y2 -Option Value ...]; +%% canvas Action $w ;$w +%% Comment: no placer options (we don't have to consider all permutations) +%%---------------------------------------------------------------------- +make_command(Options, Gstkid, Canvas, AItem, SCmd, DB) -> + case gstk_generic:out_opts(Options,Gstkid,Canvas,DB,AItem, [],[],[]) of + {[], [], []} -> []; + {Si, [], []} -> [SCmd, Si]; + {[], [], Co} -> Co; + {Si, [], Co} -> [SCmd, Si, $;, Co]; + {error,Reason} -> {error,Reason} + end. + +make_command(Options, Gstkid, Canvas, MCmd, DB) -> + case gstk_generic:out_opts(Options,Gstkid,Canvas,DB,"$w",[],[],[]) of + {[], [], []} -> MCmd; + {Si, [], []} -> [MCmd, Si]; + {[], [], Co} -> ["set w [", MCmd, "];", Co, "set d $w"]; + {Si, [], Co} -> ["set w [", MCmd, Si, "];", Co, "set d $w"]; + {error,Reason} -> {error,Reason} + end. + +item_config(DB, Gstkid, Opts) -> + #gstkid{widget=Canvas,widget_data=Item}=Gstkid, + AItem = gstk:to_ascii(Item), + SCmd = [Canvas, " itemconf ", AItem], + case make_command(Opts, Gstkid, Canvas, AItem, SCmd, DB) of + {error,Reason} -> {error,Reason}; + Cmd when is_list(Cmd) -> + gstk:exec(Cmd) + end. + +pickout_coords([{coords,Coords} | Rest], Opts, ObjType, NbrOfCoords) + when length(Coords) == NbrOfCoords -> + case coords(Coords) of + invalid -> + {error, io_lib:format("A ~w must have ~w coordinates", + [ObjType,NbrOfCoords])}; + RealCoords -> + {RealCoords, lists:append(Rest, Opts)} + end; +pickout_coords([Opt | Rest], Opts, ObjType, NbrOfCoords) -> + pickout_coords(Rest, [Opt|Opts], ObjType, NbrOfCoords); +pickout_coords([], _Opts, ObjType, NbrOfCoords) -> + {error, io_lib:format("A ~w must have ~w coordinates", + [ObjType,NbrOfCoords])}. + +coords([{X,Y} | R]) when is_number(X),is_number(Y) -> + [gstk:to_ascii(X), " ", gstk:to_ascii(Y), " ", coords(R)]; +coords([_]) -> %% not a pair + invalid; +coords([]) -> + []. + +item_delete_impl(DB,Gstkid) -> + gstk_db:delete_widget(DB, Gstkid), + #gstkid{widget=Canvas,widget_data=Item,parent=P,id=ID,objtype=Type}=Gstkid, + {P,ID,gstk_widgets:type2mod(Type), [Canvas, Item]}. + + +upd_gstkid(DB, Gstkid, Opts) -> + #gstkid{parent=Parent,owner=Owner}=Gstkid, + Pgstkid = gstk_db:lookup_gstkid(DB, Parent, Owner), + SO = Pgstkid#gstkid.widget_data, + CanvasTkW = SO#so.object, + gstk_db:insert_opt(DB,Gstkid,{coords,gs:val(coords,Opts)}), + gstk_db:update_widget(DB,Gstkid#gstkid{widget=CanvasTkW,widget_data=no_item}). + + +%%% ----- Done ----- + + diff --git a/lib/gs/src/gstk_checkbutton.erl b/lib/gs/src/gstk_checkbutton.erl new file mode 100644 index 0000000000..14e1e8ad01 --- /dev/null +++ b/lib/gs/src/gstk_checkbutton.erl @@ -0,0 +1,319 @@ +%% +%% %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 CheckButton Type +%% ------------------------------------------------------------ + +-module(gstk_checkbutton). + +%%------------------------------------------------------------------------------ +%% CHECKBUTTON OPTIONS +%% +%% Attributes: +%% activebg Color +%% activefg Color +%% align n,w,s,e,nw,se,ne,sw,center +%% anchor n,w,s,e,nw,se,ne,sw,center +%% bg Color +%% bw Int +%% data Data +%% disabledfg Color +%% fg Color +%% group Atom +%% groupid Groupid +%% height Int +%% highlightbg Color +%% highlightbw Int +%% highlightfg Color +%% justify left|right|center +%% label {text, String} | {image, BitmapFile} +%% padx Int (Pixels) +%% pady Int (Pixels) +%% relief Relief [flat|raised|sunken|ridge|groove] +%% select Bool +%% selectbg Color +%% underline Int +%% width Int +%% wraplength Int +%% x Int +%% y Int +%% +%% Commands: +%% enable Bool +%% flash +%% invoke +%% setfocus Bool +%% toggle +%% +%% Events: +%% buttonpress [Bool | {Bool, Data}] +%% buttonrelease [Bool | {Bool, Data}] +%% click [Bool | {Bool, Data}] +%% destroy [Bool | {Bool, Data}] +%% enter [Bool | {Bool, Data}] +%% focus [Bool | {Bool, Data}] +%% keypress [Bool | {Bool, Data}] +%% keyrelease [Bool | {Bool, Data}] +%% leave [Bool | {Bool, Data}] +%% motion [Bool | {Bool, Data}] +%% +%% Read Options: +%% children +%% id +%% parent +%% type +%% +%% Not Implemented: +%% cursor ?????? +%% focus ?????? (-takefocus) +%% font ?????? +%% + +-export([create/3,config/3,read/3,delete/2,event/5,option/5,read_option/5]). + +-include("gstk.hrl"). + +%%----------------------------------------------------------------------------- +%% MANDATORY INTERFACE FUNCTIONS +%%----------------------------------------------------------------------------- +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : create/7 +%% Purpose : Create a widget of the type defined in this module. +%% Return : [Gsid_of_new_widget | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +create(DB, GstkId, Opts) -> + TkW = gstk_generic:mk_tkw_child(DB,GstkId), + {G, GID, _NOpts} = fix_group(Opts, DB, GstkId#gstkid.owner), + NGstkId=GstkId#gstkid{widget=TkW,widget_data={G, GID}}, + PlacePreCmd = [";place ", TkW], + case gstk_generic:make_command(Opts,NGstkId,TkW,"",PlacePreCmd,DB) of + {error,Reason} -> {error,Reason}; + Cmd when is_list(Cmd) -> + gstk:exec(["checkbutton ", TkW," -bo 2 -indi true ",Cmd]), + NGstkId + end. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : config/3 +%% Purpose : Configure a widget of the type defined in this module. +%% Args : DB - The Database +%% Gstkid - The gstkid of the widget +%% Opts - A list of options for configuring the widget +%% +%% Return : [true | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +config(DB, Gstkid, Opts) -> + TkW = Gstkid#gstkid.widget, + {NOpts, NGstkid} = fix_group(Opts, DB, Gstkid#gstkid.owner, Gstkid), + SimplePreCmd = [TkW, " conf"], + PlacePreCmd = [";place ", TkW], + gstk_generic:mk_cmd_and_exec(NOpts,NGstkid,TkW,SimplePreCmd,PlacePreCmd,DB). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : read/3 +%% Purpose : Read one option from a widget +%% Args : DB - The Database +%% Gstkid - The gstkid of the widget +%% Opt - An option to read +%% +%% Return : [OptionValue | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +read(DB, Gstkid, Opt) -> + gstk_generic:read_option(DB, Gstkid, Opt). + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : delete/2 +%% Purpose : Delete widget from databas and return tkwidget to destroy +%% Args : DB - The Database +%% Gstkid - The gstkid of the widget +%% +%% Return : TkWidget to destroy +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +delete(DB, Gstkid) -> + gstk_db:delete_widget(DB, Gstkid), + {_, Gid} = Gstkid#gstkid.widget_data, + gstk_db:delete_bgrp(DB, Gid), + Gstkid#gstkid.widget. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : event/5 +%% Purpose : Construct the event and send it to the owner of the widget +%% Args : DB - The Database +%% Gstkid - The gstkid of the widget +%% Etype - The event type +%% Edata - The event data +%% Args - The data from tcl/tk +%% +%% Return : true +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +event(DB, Gstkid, Etype, Edata, Args) -> + Arg2 = case Etype of + click -> + [Text, Bool | Rest] = Args, + RBool = case Bool of + 1 -> true; + _Other2 -> false + end, + {G, _Gid} = Gstkid#gstkid.widget_data, + [Text, G, RBool | Rest]; + _Other3 -> + Args + end, + gstk_generic:event(DB, Gstkid, Etype, Edata, Arg2). + + + +%%------------------------------------------------------------------------------ +%% MANDATORY FUNCTIONS +%%------------------------------------------------------------------------------ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : option/4 +%% Purpose : Take care of options +%% Args : Option - An option tuple +%% Gstkid - The gstkid of the widget +%% TkW - The tk-widget +%% DB - The Database +%% +%% Return : A tuple {OptionType, OptionCmd} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +option(Option, Gstkid, TkW, DB,_) -> + case Option of + {disabledfg, Color} -> {s, [" -disabledforegr ", gstk:to_color(Color)]}; + {group, Group} -> {s, [" -var ", gstk:to_ascii(Group)]}; + {selectbg, Color} -> {s, [" -selectc ", gstk:to_color(Color)]}; + {underline, Int} -> {s, [" -un ", gstk:to_ascii(Int)]}; + {wraplength, Int} -> {s, [" -wr ", gstk:to_ascii(Int)]}; + + flash -> {c, [TkW, " f;"]}; + invoke -> {c, [TkW, " i;"]}; + toggle -> {c, [TkW, " to;"]}; + {select, true} -> {c, [TkW, " se;"]}; + {select, false} -> {c, [TkW, " de;"]}; + {click, On} -> cbind(DB, Gstkid, click, On); + _ -> invalid_option + end. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : read_option/3 +%% Purpose : Take care of a read option +%% Args : DB - The Database +%% Gstkid - The gstkid of the widget +%% Option - An option +%% +%% Return : The value of the option or invalid_option +%% [OptionValue | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +read_option(Option,Gstkid, TkW,DB,_) -> + case Option of + disabledfg -> tcl2erl:ret_color([TkW," cg -disabledforegr"]); + group -> {G, _} = Gstkid#gstkid.widget_data, G; + selectbg -> tcl2erl:ret_color([TkW," cg -selectc"]); + groupid -> {_, Gid} = Gstkid#gstkid.widget_data, Gid; + underline -> tcl2erl:ret_int([TkW," cg -un"]); + wraplength -> tcl2erl:ret_int([TkW," cg -wr"]); + select -> tcl2erl:ret_bool(["set x [", TkW, + " cg -va];global $x;set $x"]); + + click -> gstk_db:is_inserted(DB, Gstkid, click); + _ -> {bad_result, {Gstkid#gstkid.objtype, invalid_option, Option}} + end. + +%%------------------------------------------------------------------------------ +%% PRIMITIVES +%%------------------------------------------------------------------------------ +%% check button version +%% create version +fix_group(Opts, DB, Owner) -> + {G, GID, NOpts} = fg(Opts, erlNIL, erlNIL, []), + NG = case G of + erlNIL -> + Vref = gstk_db:counter(DB, variable), + list_to_atom(lists:flatten(["cb", gstk:to_ascii(Vref)])); + Other1 -> Other1 + end, + RGID = case GID of + erlNIL -> {cbgrp, NG, Owner}; + Other2 -> Other2 + end, + RG = gstk_db:insert_bgrp(DB, RGID), + {NG, RGID, [{group, RG} | NOpts]}. + +%% config version +fix_group(Opts, DB, Owner, Gstkid) -> + {RG, RGID} = Gstkid#gstkid.widget_data, + {G, GID, NOpts} = fg(Opts, RG, RGID, []), + case {G, GID} of + {RG, RGID} -> + {NOpts, Gstkid}; + {NG, RGID} -> + NGID = {cbgrp, NG, Owner}, + gstk_db:delete_bgrp(DB, RGID), + NRG = gstk_db:insert_bgrp(DB, NGID), + NGstkid = Gstkid#gstkid{widget_data={NG,NGID}}, + gstk_db:insert_widget(DB, NGstkid), + {[{group, NRG} | NOpts], NGstkid}; + {_, NGID} when NGID =/= RGID -> + gstk_db:delete_bgrp(DB, RGID), + NRG = gstk_db:insert_bgrp(DB, NGID), + NGstkid = Gstkid#gstkid{widget_data={RG,NGID}}, + gstk_db:insert_widget(DB, NGstkid), + {[{group, NRG} | NOpts], NGstkid} + end. + + + +fg([{group, G} | Opts], _, GID, Nopts) -> + fg(Opts, G, GID, Nopts); + +fg([{groupid, GID} | Opts], G, _, Nopts) -> + fg(Opts, G, GID, Nopts); + +fg([Opt | Opts], G, GID, Nopts) -> + fg(Opts, G, GID, [Opt | Nopts]); + +fg([], Group, GID, Opts) -> + {Group, GID, Opts}. + + +%% +%% Config bind +%% +cbind(DB, Gstkid, Etype, On) -> + TkW = Gstkid#gstkid.widget, + Cmd = case On of + {true, Edata} -> + Eref = gstk_db:insert_event(DB, Gstkid, Etype, Edata), + [" -command {erlsend ", Eref, " \\\"[", TkW, + " cg -text]\\\" \[expr \$[", TkW, " cg -va]\]}"]; + true -> + Eref = gstk_db:insert_event(DB, Gstkid, Etype, ""), + [" -command {erlsend ", Eref, " \\\"[", TkW, + " cg -text]\\\" \[expr \$[", TkW, " cg -va]\]}"]; + _Other -> + gstk_db:delete_event(DB, Gstkid, Etype), + " -command {}" + end, + {s, Cmd}. + +%% ----- Done ----- + diff --git a/lib/gs/src/gstk_db.erl b/lib/gs/src/gstk_db.erl new file mode 100644 index 0000000000..849784574f --- /dev/null +++ b/lib/gs/src/gstk_db.erl @@ -0,0 +1,412 @@ +%% +%% %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% +%% + +%% +%% ------------------------------------------------------------ +%% +%% Database interface for `gstk'. +%% +%% ------------------------------------------------------------ + +-module(gstk_db). + +-export([init/1, + insert/3, + lookup/2, + lookup_event/3, + insert_bgrp/2, + delete_bgrp/2, + insert_gs/2, + insert_widget/2, + delete_kid/3, + insert_opts/3, + lookup_def/3, + opt_or_not/3, + lookup_gstkid/3, + lookup_ids/2, + lookup_item/3, + delete_widget/2, + delete_gstkid/2, + get_deleted/1, + delete_event/3, + insert_event/4, + update_widget/2, + is_inserted/3, + lookup_kids/2, + insert_def/3, + opt/4, + opt/3, + insert_opt/3, + default_container_opts/3, + default_opts/3, + counter/2, + lookup_gstkid/2]). + +-include("gstk.hrl"). + + +%% ------------------------------------------------------------ +%% INITIALIZATION +%% ------------------------------------------------------------ + +init(_Opts) -> + put(events,ets:new(gstk_db, [public, set])), + put(kids,ets:new(gstk_db, [public, bag])), + put(defaults,ets:new(gstk_db, [public, bag])), + put(deleted,ets:new(gstk_db, [public, bag])), + put(options,ets:new(gstk_db, [public, set])), + ets:new(gstk_db, [public, set]). + +%% ----------------------------------------------------------------- +%% PRIMITIVE DB INTERFACE +%% ----------------------------------------------------------------- + +insert(DB, Key, Value) -> + ets:insert(DB, {Key, Value}). + + +lookup(DB, Key) -> + Result = + case ets:lookup(DB, Key) of + [{Key, Value}] -> Value; + _ -> undefined + end, + Result. + + +delete(DB, Key) -> + ets:delete(DB, Key). + + + +%% ----------------------------------------------------------------- +%% NOT SO PRIMITIVE DB INTERFACE +%% ----------------------------------------------------------------- + +%% ----------------------------------------------------------------- +%% HANDLE EVENTS +%% ----------------------------------------------------------------- +insert_event(DB, Gstkid, Etype, Edata) -> + ID = Gstkid#gstkid.id, + Rdata = + case Edata of + [] -> opt(DB,ID,data); + _Other1 -> Edata + end, + Events = lookup_events(DB, ID), + case lists:keysearch(Etype, 2, Events) of + {value, {Etag, _, _}} -> + NewEvents = + lists:keyreplace(Etype, 2, Events, {Etag, Etype, Rdata}), + ets:insert(get(events), {{events, ID}, NewEvents}), + [$#, gstk:to_ascii(ID), " ", Etag]; + _Other2 -> + Etag = etag(Etype), + NewEvents = [{Etag, Etype, Rdata} | Events], + ets:insert(get(events), {{events, ID}, NewEvents}), + [$#, gstk:to_ascii(ID), " ", Etag] + end. + +etag(Etype) -> + case Etype of + click -> "c"; + doubleclick -> "dc"; + configure -> "co"; + enter -> "e"; + leave -> "l"; + motion -> "m"; + buttonpress -> "bp"; + buttonrelease -> "br"; + focus -> "f"; + destroy -> "d"; + keypress -> "kp"; + keyrelease -> "kr" + end. + +lookup_events(_DB, ID) -> + case lookup(get(events), {events, ID}) of + undefined -> []; + Events -> Events + end. + +lookup_event(DB, ID, Etag) -> + case lists:keysearch(Etag, 1, lookup_events(DB, ID)) of + {value, {Etag, Etype, Edata}} -> + {Etype, Edata}; + _Other -> + nonexisting_event + end. + +delete_event(DB, Gstkid, Etype) -> + ID = Gstkid#gstkid.id, + NewEvents = lists:keydelete(Etype, 2, lookup_events(DB, ID)), + ets:insert(get(events), {{events, ID}, NewEvents}). + +%% ----------------------------------------------------------------- +%% HANDLE BUTTON GROUPS +%% ----------------------------------------------------------------- +insert_bgrp(DB, Key) -> + case ets:lookup(DB, Key) of + [] -> + {_Bgrp, RG, _Owner} = Key, + insert(DB, Key, {0, RG}), + RG; + [{_, {Counter, RG}}] -> + insert(DB, Key, {Counter+1, RG}), + RG + end. + + +delete_bgrp(DB, Key) -> + case ets:lookup(DB, Key) of + [] -> + true; + [{_, {0, _RG}}] -> + delete(DB, Key), + true; + [{_, {Counter, RG}}] -> + insert(DB, Key, {Counter-1, RG}), + true + end. + + +%% ----------------------------------------------------------------- +%% insert things + +update_widget(DB, Gstkid) -> + ID = Gstkid#gstkid.id, + insert(DB, ID, Gstkid), + Gstkid. + +insert_gs(DB,Gstkid) -> + update_widget(DB,Gstkid). + +insert_widget(DB, Gstkid) -> + ID = Gstkid#gstkid.id, + insert_kid(DB, Gstkid#gstkid.parent, ID), + insert(DB, ID, Gstkid), + Gstkid. + +insert_kid(_DB, Parent, Kid) -> + ets:insert(get(kids), {{kids, Parent},Kid}). + +delete_kid(_DB, Parent, Kid) -> + ets:match_delete(get(kids), {{kids, Parent},Kid}). + +lookup_kids(_DB, Parent) -> + ril(ets:match(get(kids), {{kids, Parent},'$1'})). + +%%---------------------------------------------------------------------- +%% Options are stored as {{Id,Opt},Val} +%%---------------------------------------------------------------------- +insert_opt(_DB,Id,{default,ObjType,Opt}) -> + insert_def(Id,ObjType,Opt); +insert_opt(_DB,#gstkid{id=Id},{Key,Val}) -> + ets:insert(get(options),{{Id,Key},Val}); +insert_opt(_DB,Id,{Key,Val}) -> + ets:insert(get(options),{{Id,Key},Val}). + +insert_opts(_DB,_Id,[]) -> done; +insert_opts(DB,Id,[Opt|Opts]) -> + insert_opt(DB,Id,Opt), + insert_opts(DB,Id,Opts). + +insert_def(#gstkid{id=ID},ObjType,{Key,Val}) -> + insert_def(ID,ObjType,{Key,Val}); +insert_def(ID,ObjType,{Key,Val}) -> + Def = get(defaults), + ets:match_delete(Def,{{ID,ObjType},{Key,'_'}}), + ets:insert(Def,{{ID,ObjType},{Key,Val}}). + +lookup_def(ID,ObjType,Key) -> + case ets:match(get(defaults),{{ID,ObjType},{Key,'$1'}}) of + [] -> false; + [[Val]] -> {value,Val} + end. + +opt(DB,#gstkid{id=Id},Opt) -> opt(DB,Id,Opt); +opt(_DB,Id,Opt) -> + [{_, Value}] = ets:lookup(get(options), {Id,Opt}), + Value. + +opt_or_not(DB,#gstkid{id=Id},Opt) -> opt_or_not(DB,Id,Opt); +opt_or_not(_DB,Id,Opt) -> + case ets:lookup(get(options), {Id,Opt}) of + [{_, Value}] -> {value, Value}; + _ -> false + end. + +opt(DB,#gstkid{id=Id},Opt,ElseVal) -> opt(DB,Id,Opt,ElseVal); +opt(_DB,Id,Opt,ElseVal) -> + case ets:lookup(get(options), {Id,Opt}) of + [{_, Value}] -> + Value; + _ -> ElseVal + end. + +%%---------------------------------------------------------------------- +%% Returns: list of {Key,Val} +%%---------------------------------------------------------------------- +default_container_opts(_DB,Id,ChildType) -> + L = ets:match(get(defaults),{{Id,'$1'},'$2'}), + lists:sort(fix_def_for_container(L,ChildType)). + +default_opts(_DB,Id,ChildType) -> + L1 = ets:lookup(get(defaults),{Id,ChildType}), + L2 = ets:lookup(get(defaults),{Id,all}), + lists:sort(fix_def(L1,L2)). + +fix_def([{_,Opt}|Opts],Opts2) -> + [Opt|fix_def(Opts,Opts2)]; +fix_def([],[]) -> []; +fix_def([],Opts) -> + fix_def(Opts,[]). + +%%---------------------------------------------------------------------- +%% Purpose: Extracs {default,ObjType,DefsultOpt} for the ChildType +%% and keeps default options since it is a container object. +%% Returns: list of options +%%---------------------------------------------------------------------- +fix_def_for_container([[all,{Key,Val}]|Opts],ChildType) -> + [{{default,all,Key},Val},{Key,Val} + |fix_def_for_container(Opts,ChildType)]; +fix_def_for_container([[ChildType,{Key,Val}]|Opts],ChildType) -> + [{{default,ChildType,Key},Val},{Key,Val} + |fix_def_for_container(Opts,ChildType)]; +fix_def_for_container([[ChildType2,{Key,Val}]|Opts],_ChildType) -> + [{{default,ChildType2,Key},Val}|fix_def_for_container(Opts,ChildType2)]; +fix_def_for_container([],_) -> []. + +%% ----------------------------------------------------------------- +%% lookup things + +lookup_gstkid(DB, Name, Owner) when is_atom(Name) -> + ID = lookup(DB, {Owner, Name}), + lookup(DB, ID); + +lookup_gstkid(DB, ID, _Owner) -> + lookup(DB, ID). + + +lookup_gstkid(_DB, Name) when is_atom(Name) -> + exit({'must use owner',Name}); + +lookup_gstkid(DB, ID) -> + lookup(DB, ID). + + +lookup_ids(DB, Pid) -> + ril(ets:match(DB, {'$1', {gstkid,'_','_','_',Pid,'_','_'}})). + +lookup_item(DB, TkW, Item) -> + % [[Id]] = ets:match(DB, {'$1', {gstkid,'_',TkW, Item,'_','_','_'}}), + % Id. + %% OTP-4167 Gif images gstkids are stored differently from other objects + case ets:match(DB, {'$1', {gstkid,'_',TkW, Item,'_','_','_'}}) of + [[Id]] -> + Id; + [] -> + Pattern = {'$1', {gstkid,'_',TkW, {'_',Item},'_','_',image}}, + [[Id]] = ets:match(DB, Pattern), + Id + end. + + +%% ----------------------------------------------------------------- +%% counters + +counter(DB, Key) -> + Result = + case ets:lookup(DB, Key) of + [{Key, Value}] -> Value+1; + _ -> 0 + end, + ets:insert(DB, {Key, Result}), + Result. + + +%% ----------------------------------------------------------------- +%% delete things + +delete_widgets(DB, [ID | Rest]) -> + delete_widget(DB, ID), + delete_widgets(DB, Rest); +delete_widgets(_, []) -> + true. + + +delete_widget(DB, #gstkid{id = ID}) -> + delete_widget(DB, ID); +delete_widget(DB, ID) -> + delete_widgets(DB, lookup_kids(DB, ID)), + delete_id(DB, ID). + +delete_gstkid(DB,Gstkid) -> + delete_id(DB,Gstkid). + +delete_id(DB, ID) -> + case lookup_gstkid(DB, ID) of + undefined -> + true; + _Gstkid -> + gstk:worker_do({match_delete,[{get(options),[{{ID,'_'},'_'}]}, + {get(defaults),[{{ID,'_'},'_'}]}]}), + ets:insert(get(deleted),{deleted,ID}), + delete(DB, ID) + end, + ets:delete(get(kids), {kids, ID}), + delete(get(events), {events, ID}), + true. + +get_deleted(_DB) -> + Dd = get(deleted), + R=fix_deleted(ets:lookup(Dd,deleted)), + ets:delete(Dd,deleted), + R. + +fix_deleted([{_,Id}|Dd]) -> + [Id | fix_deleted(Dd)]; +fix_deleted([]) -> []. + +%% ----------------------------------------------------------------- +%% odd stuff + +%% check if an event is in the database, used by read_option +is_inserted(DB, #gstkid{id = ID}, What) -> + is_inserted(DB, ID, What); +is_inserted(_DB, ID, What) -> + case lookup(get(events), {events, ID}) of + undefined -> false; + Events -> + case lists:keysearch(What, 2, Events) of + {value, _} -> true; + _Other -> false + end + end. + +%% ----------------------------------------------------------------- +%% PRIMITIVES +%% ----------------------------------------------------------------- + +%% remove irritating lists +ril([[Foo] | Rest]) -> [Foo | ril(Rest)]; +ril([]) -> []. + + + diff --git a/lib/gs/src/gstk_editor.erl b/lib/gs/src/gstk_editor.erl new file mode 100644 index 0000000000..3e0c8240e4 --- /dev/null +++ b/lib/gs/src/gstk_editor.erl @@ -0,0 +1,396 @@ +%% +%% %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 Editor Type +%% ------------------------------------------------------------ + +-module(gstk_editor). + +%%------------------------------------------------------------------------------ +%% CANVAS OPTIONS +%% +%% Attributes: +%% activebg Color +%% anchor n,w,s,e,nw,se,ne,sw,center +%% bc Color +%% bg Color +%% bw Wth +%% data Data +%% fg Color +%% font Font +%% height Int +%% highlightbg Color +%% highlightbw Wth +%% highlightfg Color +%% hscroll Bool | top | bottom +%% insertbg Color +%% insertbw Wth +%% insertpos {Row,Col}|'end' (Row: 1..Max, Col: 0..Max) +%% justify left|right|center +%% padx Int (Pixels) +%% pady Int (Pixels) +%% relief Relief +%% scrollbg Color +%% scrollfg Color +%% selectbg Color +%% selectbw Width +%% selectfg Color +%% vscroll Bool | left | right +%% width Int +%% wrap none | char | word +%% x Int +%% y Int +%% +%% +%% Commands: +%% clear +%% del {FromIdx, ToIdx} +%% enable Bool +%% file String +%% get {FromIdx, ToIdx} => Text +%% insert {Index, Text}Index = [insert,{Row,lineend},end,{Row,Col}] +%% setfocus Bool +%% +%% Events: +%% buttonpress [Bool | {Bool, Data}] +%% buttonrelease [Bool | {Bool, Data}] +%% destroy [Bool | {Bool, Data}] +%% enter [Bool | {Bool, Data}] +%% focus [Bool | {Bool, Data}] +%% keypress [Bool | {Bool, Data}] +%% keyrelease [Bool | {Bool, Data}] +%% leave [Bool | {Bool, Data}] +%% motion [Bool | {Bool, Data}] +%% +%% Read Options: +%% children +%% id +%% parent +%% type +%% + +%.t tag names 2.7 -> red blue (blue �r f�rgen) +%.t tag add blue 2.1 2.10 tagga text +%.t tag configure blue -foregr blue skapa tag +% .t index end -> MaxRows.cols +% .t yview moveto (Row-1)/MaxRows + +-export([create/3, config/3, read/3, delete/2,event/5,option/5,read_option/5]). + +-include("gstk.hrl"). + +%%----------------------------------------------------------------------------- +%% MANDATORY INTERFACE FUNCTIONS +%%----------------------------------------------------------------------------- +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : create/3 +%% Purpose : Create a widget of the type defined in this module. +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +create(DB, Gstkid, Opts) -> + MainW = gstk_generic:mk_tkw_child(DB,Gstkid), + Editor = lists:append(MainW,".z"), + {Vscroll, Hscroll, NewOpts} = gstk_generic:parse_scrolls(Opts), + WidgetD = #so{main=MainW, object=Editor, + hscroll=Hscroll, vscroll=Vscroll,misc=[{1,white}]}, + NGstkid=Gstkid#gstkid{widget=MainW, widget_data=WidgetD}, + gstk_db:insert_widget(DB,NGstkid), + MandatoryCmd = ["so_create text ", MainW], + case gstk:call(MandatoryCmd) of + {result, _} -> + SimplePreCmd = [MainW, " conf"], + PlacePreCmd = [";place ", MainW], + case gstk_generic:make_command(NewOpts, NGstkid, MainW, SimplePreCmd, + PlacePreCmd, DB,Editor) of + {error,Reason} -> {error,Reason}; + Cmd -> + gstk:exec(Cmd), + gstk:exec( + [Editor," conf -bo 2 -relief sunken -highlightth 2;", + MainW,".sy conf -rel sunken -bo 2;", + MainW,".pad.sx conf -rel sunken -bo 2;", + Editor, " tag co c1 -for white;"]), + ok + end + end. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : config/3 +%% Purpose : Configure a widget of the type defined in this module. +%% Args : DB - The Database +%% Gstkid - The gstkid of the widget +%% Opts - A list of options for configuring the widget +%% +%% Return : [true | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +config(DB, Gstkid, Options) -> + SO = Gstkid#gstkid.widget_data, + MainW = Gstkid#gstkid.widget, + Editor = SO#so.object, + NewOpts = + case {gs:assq(vscroll,Options),gs:assq(hscroll,Options)} of + {false,false} -> Options; + _ -> gstk_generic:parse_scrolls(Gstkid, Options) + end, + SimplePreCmd = [MainW, " conf"], + PlacePreCmd = [";place ", MainW], + gstk_generic:mk_cmd_and_exec(NewOpts, Gstkid, MainW, SimplePreCmd, + PlacePreCmd, DB, Editor). + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : read/3 +%% Purpose : Read one option from a widget +%% Args : DB - The Database +%% Gstkid - The gstkid of the widget +%% Opt - An option to read +%% +%% Return : [OptionValue | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +read(DB, Gstkid, Opt) -> + SO = Gstkid#gstkid.widget_data, + gstk_generic:read_option(DB, Gstkid, Opt,SO#so.object). + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : delete/2 +%% Purpose : Delete widget from databas and return tkwidget to destroy +%% Args : DB - The Database +%% Gstkid - The gstkid of the widget +%% +%% Return : TkWidget to destroy +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +delete(DB, Gstkid) -> + gstk_db:delete_widget(DB, Gstkid), + Gstkid#gstkid.widget. + +event(DB, Gstkid, Etype, Edata, Args) -> + gstk_generic:event(DB, Gstkid, Etype, Edata, Args). + + +%%----------------------------------------------------------------------------- +%% MANDATORY FUNCTIONS +%%----------------------------------------------------------------------------- +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : option/5 +%% Purpose : Take care of options +%% Args : Option - An option tuple +%% Gstkid - The gstkid of the widget +%% MainW - The main tk-widget +%% Editor - The Editor tk-widget +%% DB - The Database +%% +%% Return : A tuple {OptionType, OptionCmd} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +option(Option, Gstkid, _MainW, DB, Editor) -> + case Option of + {font,Font} when is_tuple(Font) -> + gstk_db:insert_opt(DB,Gstkid,Option), + {c, [Editor, " conf -font ", gstk_font:choose_ascii(DB,Font)]}; + {font_style, {{Start,End},Font}} -> % should be only style + {Tag,Ngstkid} = get_style_tag(DB,Editor,Font,Gstkid), + gstk_db:update_widget(DB,Ngstkid), + {c, Ngstkid, [Editor, " tag ad ", Tag, " ", p_index(Start), " ", + p_index(End)]}; + {fg, {{Start,End},Color}} -> + {Tag,Ngstkid} = get_color_tag(Editor,Color,Gstkid), + gstk_db:update_widget(DB,Ngstkid), + {c, Ngstkid, [Editor, " tag ad ", Tag, " ", p_index(Start), " ", + p_index(End)]}; + {padx, Pad} -> {c, [Editor," conf -padx ",gstk:to_ascii(Pad)]}; + {pady, Pad} -> {c, [Editor," conf -pady ",gstk:to_ascii(Pad)]}; + {selection, {From, To}} -> + {c, [Editor," tag ad sel ",p_index(From)," ", p_index(To)]}; + {vscrollpos, Row} -> + {MaxRow,_Col} = ret_ed_index([Editor," ind end"]), + {c, [Editor, " yv mo ",gstk:to_ascii(Row/MaxRow)]}; + {wrap, How} -> + {c, [Editor, " conf -wrap ", gstk:to_ascii(How)]}; + {fg, Color} -> + {c, [Editor, " conf -fg ", gstk:to_color(Color)]}; + {insertbw, Wth} -> + {c, [Editor, " conf -insertbo ", gstk:to_ascii(Wth)]}; + {insertbg, Color} -> + {c, [Editor, " conf -insertba ", gstk:to_color(Color)]}; + {insertpos, Index} -> + {c, [Editor, " m s insert ", p_index(Index)]}; + {insert, {Index, Text}} -> + {c, [Editor, " ins ", p_index(Index), " ", gstk:to_ascii(Text)]}; + {del, {From, To}} -> + {c, [Editor, " del ", p_index(From), " ", p_index(To)]}; + {overwrite, {Index, Text}} -> + AI = p_index(Index), + Len = gstk:to_ascii(lists:flatlength(Text)), + {c, [Editor, " del ",AI," \"",AI,"+",Len,"c\";", + Editor, " ins ",AI," ", gstk:to_ascii(Text)]}; + clear -> {c, [Editor, " delete 1.0 end"]}; + {load, File} -> + {ok, F2,_} = regexp:gsub(File, [92,92], "/"), + case gstk:call(["ed_load ", Editor, " ", gstk:to_ascii(F2)]) of + {result, _} -> none; + {bad_result,Re} -> + {error,{no_such_file,editor,load,F2,Re}} + end; + {save, File} -> + {ok, F2,_} = regexp:gsub(File, [92,92], "/"), + case gstk:call(["ed_save ",Editor," ",gstk:to_ascii(F2)]) of + {result, _} -> none; + {bad_result,Re} -> + {error,{no_such_file,editor,save,F2,Re}} + end; + {enable, true} -> {c, [Editor, " conf -state normal"]}; + {enable, false} -> {c, [Editor, " conf -state disabled"]}; + + {setfocus, true} -> {c, ["focus ", Editor]}; + {setfocus, false} -> {c, ["focus ."]}; + _ -> invalid_option + end. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : read_option/5 +%% Purpose : Take care of a read option +%% Return : The value of the option or invalid_option +%% [OptionValue | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +read_option(Option,GstkId,_MainW,DB,Editor) -> + case Option of + font -> gstk_db:opt(DB,GstkId,font,undefined); + padx -> tcl2erl:ret_atom([Editor," cg -padx"]); + pady -> tcl2erl:ret_atom([Editor," cg -pady"]); + enable -> tcl2erl:ret_enable([Editor," cg -st"]); + fg -> tcl2erl:ret_color([Editor," cg -fg"]); + {fg, Pos} -> + L=tcl2erl:ret_list([Editor," tag nam ", p_index(Pos)]), + SO = GstkId#gstkid.widget_data, + case last_tag_val(undefined, $c, L, SO#so.misc) of + undefined -> tcl2erl:ret_color([Editor," cg -fg"]); + Color -> Color + end; + {font_style, Pos} -> + L=tcl2erl:ret_list([Editor," tag nam ", p_index(Pos)]), + SO = GstkId#gstkid.widget_data, + case last_tag_val(undefined, $f, L, SO#so.misc) of + undefined -> 'my style? nyi'; + Style -> Style + end; + selection -> ret_ed_indexes([Editor," tag ne sel 1.0"]); + char_height -> tcl2erl:ret_int([Editor, " cg -he"]); + char_width -> tcl2erl:ret_int([Editor, " cg -wi"]); + insertbg -> tcl2erl:ret_color([Editor," cg -insertba"]); + insertbw -> tcl2erl:ret_int([Editor," cg -insertbo"]); + insertpos -> ret_ed_index([Editor, " ind insert"]); + setfocus -> tcl2erl:ret_focus(Editor, "focus"); + wrap -> tcl2erl:ret_atom([Editor," cg -wrap"]); + size -> {MaxRow,_Col} = ret_ed_index([Editor," ind end"]), + MaxRow-1; + vscrollpos -> + {MaxRow,_Col} = ret_ed_index([Editor," ind end"]), + [Top,_Bot] = tcl2erl:ret_list([Editor," yvi"]), + round(Top*(MaxRow-1))+1; + {get, {From, To}} -> + tcl2erl:ret_str([Editor, " get ", p_index(From), " ", p_index(To)]); + _ -> {bad_result, {GstkId#gstkid.objtype, invalid_option, Option}} + end. + + +%%------------------------------------------------------------------------------ +%% PRIMITIVES +%%------------------------------------------------------------------------------ + +p_index({Line, lineend}) -> [$",gstk:to_ascii(Line), ".1 lineend",$"]; +p_index({Line, Char}) -> [gstk:to_ascii(Line), $., gstk:to_ascii(Char)]; +p_index(insert) -> "insert"; +p_index('end') -> "end"; +p_index(Idx) -> gs:error("bad index in editor: ~w~n",[Idx]),0. + +ret_ed_index(Cmd) -> + case gstk:call(Cmd) of + {result, Val} -> + case io_lib:fread("~d.~d", Val) of + {ok, [Row,Col], []} -> {Row, Col}; + Other -> {bad_result, Other} + end; + Bad_result -> Bad_result + end. + +ret_ed_indexes(Cmd) -> + case gstk:call(Cmd) of + {result, ""} -> undefined; + {result, Val} -> + case io_lib:fread("~d.~d ~d.~d", Val) of + {ok, [Row1,Col1,Row2,Col2], []} -> {{Row1, Col1}, {Row2,Col2}}; + Other -> {bad_result, Other} + end; + Bad_result -> Bad_result + end. + + +%%---------------------------------------------------------------------- +%% Returns: {Tag text(), NewGstkId} +%%---------------------------------------------------------------------- +%% The misc field of the so record is a list of {ColorNo, Color|Font|...} +get_color_tag(Editor,Color,Gstkid) -> + SO = Gstkid#gstkid.widget_data, + Tags = SO#so.misc, + case lists:keysearch(Color, 2, Tags) of +% {value, {No, _}} -> {["c",gstk:to_ascii(No)], Gstkid}; +% false -> % don't reuse tags, priority order spoils that + _Any -> + {No,_} = lists:max(Tags), + N=No+1, + SO2 = SO#so{misc=[{N,Color}|Tags]}, + TagStr=["c",gstk:to_ascii(N)], + gstk:exec([Editor," tag co ",TagStr," -for ", gstk:to_color(Color)]), + {TagStr,Gstkid#gstkid{widget_data=SO2}} + end. + +get_style_tag(DB,Editor,Style,Gstkid) -> + SO = Gstkid#gstkid.widget_data, + Tags = SO#so.misc, + case lists:keysearch(Style, 2, Tags) of +% {value, {No, _}} -> {["f",gstk:to_ascii(No)], Gstkid}; +% false -> % don't reuse tags, priority order spoils that + _Any -> + {No,_} = lists:max(Tags), + N=No+1, + SO2 = SO#so{misc=[{N,Style}|Tags]}, + TagStr=["f",gstk:to_ascii(N)], + gstk:exec([Editor," tag co ",TagStr," -font ", + gstk_font:choose_ascii(DB,Style)]), % should be style only + {TagStr,Gstkid#gstkid{widget_data=SO2}} + end. + +%%---------------------------------------------------------------------- +%% Purpose: Given a list of tags for a char, return its visible color +%% (that is that last color tag in the list). +%%---------------------------------------------------------------------- +last_tag_val(TagVal, _Chr, [], _TagDict) -> TagVal; +last_tag_val(TagVal, Chr, [Tag|Ts],TagDict) -> + case atom_to_list(Tag) of + [Chr|ANo] -> + No = list_to_integer(ANo), + last_tag_val(gs:val(No, TagDict),Chr,Ts,TagDict); + _NoAcolor -> + last_tag_val(TagVal,Chr, Ts,TagDict) + end. + +%%% ----- Done ----- diff --git a/lib/gs/src/gstk_entry.erl b/lib/gs/src/gstk_entry.erl new file mode 100644 index 0000000000..14f7831151 --- /dev/null +++ b/lib/gs/src/gstk_entry.erl @@ -0,0 +1,232 @@ +%% +%% %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 Entry Type +%% ------------------------------------------------------------ + +-module(gstk_entry). + +%%------------------------------------------------------------------------------ +%% ENTRY OPTIONS +%% +%% Attributes: +%% anchor n,w,s,e,nw,se,ne,sw,center +%% bg Color +%% bw Int +%% data Data +%% fg Color +%% font Font +%% height Int +%% highlightbg Color +%% highlightbw Int (Pixels) +%% highlightfg Color +%% insertbg Color +%% insertbw Int (0 or 1 Pixels ???) +%% justify left|right|center +%% relief Relief [flat|raised|sunken|ridge|groove] +%% selectbg Color +%% selectbw Int (Pixels) +%% selectfg Color +%% text String +%% width Int +%% x Int +%% xselection Bool +%% y Int +%% +%% Commands: +%% delete Index | {From, To} +%% enable Bool +%% insert {index,String} +%% select {From, To} | clear +%% setfocus Bool +%% +%% Events: +%% buttonpress [Bool | {Bool, Data}] +%% buttonrelease [Bool | {Bool, Data}] +%% configure [Bool | {Bool, Data}] +%% destroy [Bool | {Bool, Data}] +%% enter [Bool | {Bool, Data}] +%% focus [Bool | {Bool, Data}] +%% keypress [Bool | {Bool, Data}] +%% keyrelease [Bool | {Bool, Data}] +%% leave [Bool | {Bool, Data}] +%% motion [Bool | {Bool, Data}] +%% +%% Read options: +%% children +%% id +%% index Index => Int +%% parent +%% type +%% +%% +%% Not Implemented: +%% cursor ?????? +%% focus ?????? (-takefocus) +%% font ?????? +%% hscroll ?????? +%% show ?????? +%% state ?????? +%% + +-export([create/3,config/3,read/3,delete/2,event/5,option/5,read_option/5]). + +-include("gstk.hrl"). + +%%----------------------------------------------------------------------------- +%% MANDATORY INTERFACE FUNCTIONS +%%----------------------------------------------------------------------------- +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : create/7 +%% Purpose : Create a widget of the type defined in this module. +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +create(DB, GstkId, Opts) -> + TkW = gstk_generic:mk_tkw_child(DB,GstkId), + PlacePreCmd = [";place ", TkW], + Ngstkid = GstkId#gstkid{widget=TkW}, + case gstk_generic:make_command(Opts,Ngstkid,TkW,"", PlacePreCmd,DB) of + {error,Reason} -> {error,Reason}; + Cmd when is_list(Cmd) -> + case gstk:call(["entry ", TkW,Cmd]) of + {result, _} -> + gstk:exec( + [TkW," conf -bo 2 -relief sunken -highlightth 2;"]), + Ngstkid; + Bad_Result -> + {error, Bad_Result} + end + end. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : config/3 +%% Purpose : Configure a widget of the type defined in this module. +%% Args : DB - The Database +%% Gstkid - The gstkid of the widget +%% Opts - A list of options for configuring the widget +%% +%% Return : [true | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +config(DB, Gstkid, Opts) -> + TkW = Gstkid#gstkid.widget, + SimplePreCmd = [TkW, " conf"], + PlacePreCmd = [";place ", TkW], + gstk_generic:mk_cmd_and_exec(Opts,Gstkid,TkW,SimplePreCmd,PlacePreCmd,DB). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : read/3 +%% Purpose : Read one option from a widget +%% Args : DB - The Database +%% Gstkid - The gstkid of the widget +%% Opt - An option to read +%% +%% Return : [OptionValue | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +read(DB, Gstkid, Opt) -> + gstk_generic:read_option(DB, Gstkid, Opt). + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : delete/2 +%% Purpose : Delete widget from databas and return tkwidget to destroy +%% Args : DB - The Database +%% Gstkid - The gstkid of the widget +%% +%% Return : TkWidget to destroy +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +delete(DB, Gstkid) -> + gstk_db:delete_widget(DB, Gstkid), + Gstkid#gstkid.widget. + + +event(DB, Gstkid, Etype, Edata, Args) -> + gstk_generic:event(DB, Gstkid, Etype, Edata, Args). + + +%%------------------------------------------------------------------------------ +%% MANDATORY FUNCTIONS +%%------------------------------------------------------------------------------ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : option/4 +%% Purpose : Take care of options +%% Args : Option - An option tuple +%% Gstkid - The gstkid of the widget +%% TkW - The tk-widget +%% DB - The Database +%% +%% Return : A tuple {OptionType, OptionCmd} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +option(Option, Gstkid, TkW, DB,_) -> + case Option of + {font, Font} -> + gstk_db:insert_opt(DB,Gstkid,Option), + {s, [" -font ", gstk_font:choose_ascii(DB,Font)]}; + {insertbg, Color} -> {s, [" -insertba ", gstk:to_color(Color)]}; + {insertbw, Width} -> {s, [" -insertbo ", gstk:to_ascii(Width)]}; + {justify, How} -> {s, [" -ju ", gstk:to_ascii(How)]}; + {text, Str} -> + {c, [TkW," del 0 end; ",TkW," ins 0 ", gstk:to_ascii(Str)]}; + {xselection, Bool} -> {s, [" -exportse ", gstk:to_ascii(Bool)]}; + + {delete, {From, To}} -> + {c, [TkW, " del ", p_index(From), $ , p_index(To)]}; + {delete, Index} -> {c, [TkW, " de ", p_index(Index)]}; + {insert, {Idx, Str}} -> + {c, [TkW, " ins ", gstk:to_ascii(Idx),$ , gstk:to_ascii(Str)]}; + {select, clear} -> {c, [TkW, " sel clear"]}; + {select, {From, To}} -> + {c, [TkW, " sel range ", p_index(From), $ , p_index(To)]}; + _ -> invalid_option + + end. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : read_option/5 +%% Purpose : Take care of a read option +%% Args : DB - The Database +%% Gstkid - The gstkid of the widget +%% Option - An option +%% +%% Return : The value of the option or invalid_option +%% [OptionValue | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +read_option(Option,Gstkid,TkW,DB,_) -> + case Option of + insertbg -> tcl2erl:ret_color([TkW," cg -insertba"]); + insertbw -> tcl2erl:ret_int([TkW," cg -insertbo"]); + font -> gstk_db:opt(DB,Gstkid,font,undefined); + justify -> tcl2erl:ret_atom([TkW," cg -jus"]); + text -> tcl2erl:ret_str([TkW," get"]); + xselection -> tcl2erl:ret_bool([TkW," cg -exports"]); + {index, Idx} -> tcl2erl:ret_int([TkW, "cg ind ", p_index(Idx)]); + _ -> {bad_result, {Gstkid#gstkid.objtype, invalid_option, Option}} + end. + +%%------------------------------------------------------------------------------ +%% PRIMITIVES +%%------------------------------------------------------------------------------ +p_index(Index) when is_integer(Index) -> gstk:to_ascii(Index); +p_index(insert) -> "insert"; +p_index(last) -> "end"; +p_index(Idx) -> gs:error("Bad index in entry: ~w~n",[Idx]),0. + + +%%% ----- Done ----- diff --git a/lib/gs/src/gstk_font.erl b/lib/gs/src/gstk_font.erl new file mode 100644 index 0000000000..ac91e8a92a --- /dev/null +++ b/lib/gs/src/gstk_font.erl @@ -0,0 +1,254 @@ +%% +%% %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% +%% + +%% +%%% Purpose : The font model + +%% ########################################################################### +%% +%% This module handle fonts. It was changed for Tcl 8.2 but it could +%% probably be simplified more. +%% +%% In Tcl 8.2 we can use named fonts. So the whe get a font request we +%% first check if it already exists and if not we name it and insert it +%% into the database. +%% +%% The font naming is also changedin Tcl 8.2. +%% +%% In Tcl 8.2 there is a way to find out the width of a string in +%% a specified font. +%% +%% ########################################################################### + +-module(gstk_font). + +%-compile(export_all). + +-export([init/0,choose_ascii/2,choose/2,width_height/3]). + + +-ifndef(NEW_WIDTH_HEIGHT). +init() -> + %% hack. the only way to find the size of a text seems to be to put + %% it into a label in an unmappen window (DummyFontWindow) + gstk:exec("toplevel .dfw;wm withdraw .dfw;" %deiconify + "label .dfw.l -text dummyinittxt -padx 0 -pady 0 -borderwidth 0;" + "pack .dfw.l"). +-else. +init() -> true. +-endif. + +%%---------------------------------------------------------------------- +%% Returns: undefined if font doesn't exist +%% {WidthPixels, HeightPixels} +%%---------------------------------------------------------------------- +-ifndef(NEW_WIDTH_HEIGHT). +width_height(_DB, FontSpec, Txt) -> + FontSpecStr = tk_font_spec(norm_font_spec(FontSpec)), + case gstk:call([".dfw.l co -font {", FontSpecStr,"}", + " -text ", gstk:to_ascii(Txt)]) of + {result, _} -> + Width = tcl2erl:ret_int("update idletasks;winfo w .dfw.l"), + Height = tcl2erl:ret_int("winfo h .dfw.l"), +% io:format("width_height(~p,~p) =>\n~p\n\n",[FontSpec,Txt,{Width,Height}]), + {Width,Height}; + _Bad_Result -> +% io:format("width_height(~p,~p) =>\nundefined\n\n",[FontSpec,Txt]), + undefined + end. +-else. +%% This code should work but does't. Tk gives incorrect +%% values if asking to fast or something /kent +width_height(DB, FontSpec, Txt) when tuple(FontSpec) -> + NormFontSpec = norm_font_spec(FontSpec), + FontSpecStr = tk_font_spec(NormFontSpec), + {Family,_,Size} = NormFontSpec, + LineHeight = + case cached_line_height(DB, {Family,Size}) of + undefined -> + LineH = tcl2erl:ret_int( + ["font metrics {",FontSpecStr,"} -linespace"]), + cache_line_height(DB, {Family,Size}, LineH), + LineH; + LineH -> + LineH + end, + EscapedText = gstk:to_ascii(Txt), + Width = tcl2erl:ret_int( + ["font measure {",FontSpecStr,"} ",EscapedText]), + Height = LineHeight * line_count(Txt), + {Width,Height}; + +width_height(_DB, FontSpec, Txt) when list(FontSpec) -> + EscapedText = gstk:to_ascii(Txt), + Width = + tcl2erl:ret_int(["font measure {",FontSpec,"} ",EscapedText]), + LineHeight = + tcl2erl:ret_int(["font metrics {",FontSpec,"} -linespace"]), + Height = LineHeight * line_count(Txt), + {Width,Height}. + +cached_line_height(DB,FontSpec) -> + gstk_db:lookup(DB, {cached_line_height,FontSpec}). + +cache_line_height(DB,FontSpec,Size) -> + gstk_db:insert(DB, {cached_line_height,FontSpec}, Size). + +line_count(Line) -> + line_count(Line, 1). + +line_count([H | T], Count) -> + Count + line_count(H, 0) + line_count(T, 0); +line_count($\n, Count) -> Count + 1; +line_count(Char, Count) when integer(Char) -> Count; +line_count([], Count) -> Count. +-endif. + +% "expr [font metrics ",FSpec," -linespace] * \ +% [regsub -all \\n ",Txt," {} ignore]" + +%%---------------------------------------------------------------------- +%% Returns: Font specification string in Tk format +%% +%% The input is {Family,Size} or {Family,Style,Size} where Family and +%% Style are atoms ?! FIXME true??? +%%---------------------------------------------------------------------- +choose_ascii(DB, Font) -> + {Fam,Styl,Siz} = choose(DB, Font), + {variable,V} =gstk_db:lookup(DB,{font,Fam,Styl,Siz}), +% io:format("choose_ascii(~p) =>\n~p\n\n",[Font,V]), + V. + +%% DB contains: {font,Fam,Style,Size} -> {replaced_by,{font,Fam,Style,Size}} or +%% {variable, TkVariableStrInclDollar} + +%% ########################################################################### +%% +%% We create a new font name on the other side and store the name in the +%% database. We reorder the options so that they have a predefined order. +%% +%% ########################################################################### + +choose(DB, FontSpec) -> + choose_font(DB, norm_font_spec(FontSpec)). + +choose_font(DB, {Fam,Styl,Siz}) -> + Fam0 = map_family(Fam), + case gstk_db:lookup(DB,{font,Fam0,Styl,Siz}) of + {variable,_OwnFontName} -> true; + undefined -> + N = gstk_db:counter(DB,font), % FIXME: Can use "font create" + % without name to get unique name + NewName=["f",gstk:to_ascii(N)], +% io:format("~s\n\n", +% [lists:flatten(["font create ",NewName," ", +% tk_font_spec({Fam0,Styl,Siz})])]), + gstk:exec(["font create ",NewName," ", + tk_font_spec({Fam0,Styl,Siz})]), + %% should us variable syntax gs(f1) instead + %% have to recompile erlcall to define this global gs var + V2 = {variable,NewName}, + gstk_db:insert(DB,{font,Fam0,Styl,Siz},V2), + true + end, +% io:format("choose(~p,~p,~p) =>\n~p\n\n",[Fam,Styl,Siz,{Fam0,Styl,Siz}]), + {Fam0,Styl,Siz}. + + +%% ----- The Font Model ----- + +%% Guaranteed system fonts to exists in Tk 8.2 are: +%% +%% Windows : system systemfixed ansi ansifixed device oemfixed +%% Unix : fixed +%% +%% Times, Courier and Helvetica always exists. Tk try to substitute +%% others with the best matchin font. + +%% We map GS font style and names to something we know Tk 8 have. +%% We know Tk have 'times', 'courier', 'helvetica' and 'fixed'. +%% +%% GS style specification is 'bold' or 'italic'. +%% GS family is a typeface of type 'times', 'courier', 'helvetica', +%% 'symbol', 'new_century_schoolbook', or 'screen' (which is a suitable +%% screen font). +%% +%% Note that 'symbol' may not be present and this is not handled. +%% +%% The X/Tk8 font handling don't work very well. The fonts are +%% scaled "tk scaling", we can display a 9 and 10 point helvetica +%% but "font actual {helvetica 9}" will return 10 points.... + +map_family(new_century_schoolbook) -> + times; +map_family(Fam) -> + Fam. + +% Normalize so can make the coding easier and compare font +% specifications stored in database with new ones. We ignore invalid +% entries in the list. + +norm_font_spec({Family,Size}) -> + {Family,[],Size}; +norm_font_spec({Family,Style,Size}) -> + {Family,norm_style(Style),Size}. + +norm_style(bold) -> + [bold]; +norm_style(italic) -> + [italic]; +norm_style([italic]) -> + [italic]; +norm_style([bold]) -> + [bold]; +norm_style([bold,italic] = Style) -> + Style; +norm_style([italic,bold]) -> + [bold,italic]; +norm_style(List) when is_list(List) -> % not well formed list, ignore garbage + case {lists:member(bold, List),lists:member(italic, List)} of + {true,true} -> + [bold,italic]; + {true,_} -> + [bold]; + {_,true} -> + [italic]; + _ -> + [] % ignore garbage + end; +norm_style(_Any) -> % ignore garbage + []. + + +% Create a tcl string from a normalized font specification +% The style list is normalized. + +tk_font_spec({Fam,Style,Size}) -> + ["-family ",gstk:to_ascii(Fam), + " -size ",gstk:to_ascii(-Size), + tk_font_spec_style(Style)]. + +tk_font_spec_style([]) -> + ""; +tk_font_spec_style([bold]) -> + " -weight bold"; +tk_font_spec_style([italic]) -> + " -slant italic"; +tk_font_spec_style([bold,italic]) -> + " -weight bold -slant italic". diff --git a/lib/gs/src/gstk_frame.erl b/lib/gs/src/gstk_frame.erl new file mode 100644 index 0000000000..1fca8aac14 --- /dev/null +++ b/lib/gs/src/gstk_frame.erl @@ -0,0 +1,281 @@ +%% +%% %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 Frame Type. +%% ------------------------------------------------------------ + +-module(gstk_frame). + +%%----------------------------------------------------------------------------- +%% FRAME OPTIONS +%% +%% Attributes: +%% anchor n,w,s,e,nw,se,ne,sw,center +%% bg Color +%% bw Int +%% data Data +%% height Int +%% highlightbg Color +%% highlightbw Int +%% highlightfg Color +%% relief Relief [flat|raised|sunken|ridge|groove] +%% width Int +%% x Int +%% y Int +%% cursor arrow|busy|cross|hand|help|resize|text +%% +%% Commands: +%% setfocus Bool +%% +%% Events: +%% buttonpress [Bool | {Bool, Data}] +%% buttonrelease [Bool | {Bool, Data}] +%% configure [Bool | {Bool, Data}] +%% destroy [Bool | {Bool, Data}] +%% enter [Bool | {Bool, Data}] +%% focus [Bool | {Bool, Data}] +%% keypress [Bool | {Bool, Data}] +%% keyrelease [Bool | {Bool, Data}] +%% leave [Bool | {Bool, Data}] +%% motion [Bool | {Bool, Data}] +%% +%% Read Options: +%% children +%% id +%% parent +%% type +%% + +-export([create/3,config/3,read/3,delete/2,event/5,option/5,read_option/5, + mk_create_opts_for_child/4]). + +-include("gstk.hrl"). + +%%----------------------------------------------------------------------------- +%% MANDATORY INTERFACE FUNCTIONS +%%----------------------------------------------------------------------------- +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : create/3 +%% Purpose : Create a widget of the type defined in this module. +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +create(DB, GstkId, Opts) -> + TkW = gstk_generic:mk_tkw_child(DB,GstkId), + NGstkid=GstkId#gstkid{widget=TkW}, + PlacePreCmd = [";place ", TkW], + case gstk_generic:make_command(Opts, NGstkid, TkW, "", PlacePreCmd, DB) of + {error,Reason} -> {error,Reason}; + Cmd when is_list(Cmd) -> + gstk:exec(["frame ", TkW, + " -relief raised -bo 0",Cmd]), + NGstkid + end. + +mk_create_opts_for_child(DB,Cgstkid, Pgstkid, Opts) -> + gstk_generic:mk_create_opts_for_child(DB,Cgstkid,Pgstkid,Opts). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : config/3 +%% Purpose : Configure a widget of the type defined in this module. +%% Args : DB - The Database +%% Gstkid - The gstkid of the widget +%% Opts - A list of options for configuring the widget +%% +%% Return : [true | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +config(DB, Gstkid, Opts) -> + TkW = Gstkid#gstkid.widget, + SimplePreCmd = [TkW, " conf"], + PlacePreCmd = [";place ", TkW], + Opts2 = atomic_width_height(false,false,Opts), + gstk_generic:mk_cmd_and_exec(Opts2,Gstkid,TkW,SimplePreCmd,PlacePreCmd,DB). + +atomic_width_height(false,false,[]) -> + []; +atomic_width_height(false,Width,[]) -> + [{width,Width}]; +atomic_width_height(Height,false,[]) -> + [{height,Height}]; +atomic_width_height(H,W,[]) -> + [{width_height,{W,H}}]; +atomic_width_height(_,W,[{height,H}|Opts]) -> + atomic_width_height(H,W,Opts); +atomic_width_height(H,_,[{width,W}|Opts]) -> + atomic_width_height(H,W,Opts); +atomic_width_height(H,W,[Opt|Opts]) -> + [Opt|atomic_width_height(H,W,Opts)]. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : read/3 +%% Purpose : Read one option from a widget +%% Args : DB - The Database +%% Gstkid - The gstkid of the widget +%% Opt - An option to read +%% +%% Return : [OptionValue | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +read(DB, Gstkid, Opt) -> + gstk_generic:read_option(DB, Gstkid, Opt). + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : delete/2 +%% Purpose : Delete widget from databas and return tkwidget to destroy +%% Args : DB - The Database +%% Gstkid - The gstkid of the widget +%% +%% Return : TkWidget to destroy +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +delete(DB, Gstkid) -> + gstk_db:delete_widget(DB, Gstkid), + Gstkid#gstkid.widget. + +event(DB, Gstkid, Etype, Edata, Args) -> + gstk_generic:event(DB, Gstkid, Etype, Edata, Args). + + +%%----------------------------------------------------------------------------- +%% MANDATORY FUNCTIONS +%%----------------------------------------------------------------------------- +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : option/4 +%% Purpose : Take care of options +%% Args : Option - An option tuple +%% Gstkid - The gstkid of the widget +%% TkW - The tk-widget +%% DB - The Database +%% +%% Return : A tuple {OptionType, OptionCmd} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +option(Option, Gstkid, _TkW, DB,_) -> + case Option of + {bg, Color} -> {s, [" -bg ", gstk:to_color(Color)]}; + {packer_x, _Pack} -> + gstk_db:insert_opt(DB,Gstkid,Option), + none; + {packer_y, _Pack} -> + gstk_db:insert_opt(DB,Gstkid,Option), + none; + {width, W} -> + execute_pack_cmds(DB,xpack(W,DB,Gstkid)), + {s,[" -wi ", gstk:to_ascii(W)]}; + {height, H} -> + execute_pack_cmds(DB,ypack(H,DB,Gstkid)), + {s,[" -he ", gstk:to_ascii(H)]}; + {width_height,{W,H}} -> + execute_pack_cmds(DB, merge_pack_cmds(xpack(W,DB,Gstkid), + ypack(H,DB,Gstkid))), + {s,[" -he ", gstk:to_ascii(H)," -wi ", gstk:to_ascii(W)]}; + _ -> invalid_option + end. + +xpack(W,DB,Gstkid) -> + gstk_db:insert_opt(DB,Gstkid,{width,W}), + case gstk_db:opt_or_not(DB,Gstkid,packer_x) of + {value,Pack} when is_list(Pack) -> + ColSiz = gs_packer:pack(W,Pack), + pack_children(pack_x,x,width,DB, + gstk_db:lookup_kids(DB,Gstkid#gstkid.id), + ColSiz); + _Else -> [] + end. + +ypack(H,DB,Gstkid) -> + gstk_db:insert_opt(DB,Gstkid,{height,H}), + case gstk_db:opt_or_not(DB,Gstkid,packer_y) of + {value,Pack} when is_list(Pack) -> + ColSiz = gs_packer:pack(H,Pack), + pack_children(pack_y,y,height,DB, + gstk_db:lookup_kids(DB,Gstkid#gstkid.id), + ColSiz); + _Else -> [] + end. + +merge_pack_cmds([{Id,Opts1}|Cmds1],[{Id,Opts2}|Cmds2]) -> + [{Id,Opts1++Opts2}|merge_pack_cmds(Cmds1,Cmds2)]; +merge_pack_cmds(L1,L2) -> + L1++L2. + +execute_pack_cmds(DB,[{Id,Opts}|Cmds]) -> + gstk:config_impl(DB,Id,Opts), + execute_pack_cmds(DB,Cmds); +execute_pack_cmds(_,[]) -> + ok. + +%%---------------------------------------------------------------------- +%% Returns: list of {Id,Opts} to be executed (or merged with other first) +%%---------------------------------------------------------------------- +pack_children(PackOpt,PosOpt,SizOpt,DB,Kids,Sizes) -> + Schildren = keep_packed(Kids,PackOpt,DB), + pack_children2(PackOpt,PosOpt,SizOpt,Schildren,Sizes). + +pack_children2(PackOpt,PosOpt,SizOpt,[{StartStop,Id}|Childs],Sizes) -> + [pack_child(Id,StartStop,SizOpt,PosOpt,Sizes) + | pack_children2(PackOpt,PosOpt,SizOpt,Childs,Sizes)]; +pack_children2(_,_,_,[],_) -> + []. + +pack_child(Id,{StartPos,StopPos},SizOpt,PosOpt,Sizes) -> + {Pos,Size} = find_pos(StartPos,StopPos,1,0,0,Sizes), + {Id,[{PosOpt,Pos},{SizOpt,Size}]}. + +%%---------------------------------------------------------------------- +%% Returns: {PixelPos,PixelSize} +%%---------------------------------------------------------------------- +find_pos(_StartPos,Pos,Pos,AccPixelPos,AccPixelSize,[Size|_]) -> + {AccPixelPos,Size+AccPixelSize}; +find_pos(StartPos,StopPos,Pos,AccPixelPos,0,[Size|Sizes]) + when Pos < StartPos -> + find_pos(StartPos,StopPos,Pos+1,Size+AccPixelPos,0,Sizes); +find_pos(_StartPos,StopPos,Pos,AccPixelPos,AccPixelSize,[Size|Sizes]) + when Pos < StopPos -> + find_pos(Pos,StopPos,Pos+1,AccPixelPos,Size+AccPixelSize,Sizes). + + + +keep_packed([Id|Ids],PackOpt,DB) -> + case gstk:read_impl(DB,Id,PackOpt) of + undefined -> + keep_packed(Ids,PackOpt,DB); + StartStop -> + [{StartStop,Id} | keep_packed(Ids,PackOpt,DB)] + end; +keep_packed([],_,_) -> + []. + + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : read_option/3 +%% Purpose : Take care of a read option +%% Args : DB - The Database +%% Gstkid - The gstkid of the widget +%% Option - An option +%% +%% Return : The value of the option or invalid_option +%% [OptionValue | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +read_option(Option,Gstkid,TkW,_DB,_) -> + case Option of + bg -> tcl2erl:ret_color([TkW," cg -bg"]); + _ -> {bad_result, {Gstkid#gstkid.objtype, invalid_option, Option}} + end. + +%% ----- Done ----- diff --git a/lib/gs/src/gstk_generic.erl b/lib/gs/src/gstk_generic.erl new file mode 100644 index 0000000000..3ddb69efc5 --- /dev/null +++ b/lib/gs/src/gstk_generic.erl @@ -0,0 +1,1087 @@ +%% +%% %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_generic). + +-export([out_opts/8, + read_option/5, + mk_tkw_child/2, + merge_default_options/3, + merge_default_options/2, + opts_for_child/3, + mk_cmd_and_exec/4, + mk_cmd_and_exec/5, + mk_cmd_and_exec/6, + mk_cmd_and_exec/7, + make_command/5, + make_command/6, + make_command/7, + read_option/4, + handle_external_opt_call/9, + handle_external_read/1, + gen_anchor/9, + gen_anchor/5, + gen_height/9, + gen_height/5, + gen_width/9, + gen_width/5, + gen_x/9, + gen_x/5, + gen_y/9, + gen_y/5, + gen_raise/9, + gen_raise/5, + gen_lower/9, + gen_lower/5, + gen_enable/9, + gen_enable/5, + gen_align/9, + gen_align/5, + gen_justify/9, + gen_justify/5, + gen_padx/9, + gen_padx/5, + gen_pady/9, + gen_pady/5, + gen_font/9, + gen_font/5, + gen_label/9, + gen_label/5, + gen_activebg/9, + gen_activebg/5, + gen_activefg/9, + gen_activefg/5, + gen_default/9, + gen_relief/9, + gen_relief/5, + gen_bw/9, + gen_bw/5, + gen_font_wh/5, + gen_choose_font/5, + gen_data/9, + gen_data/5, + gen_pack_x/9, + gen_pack_x/5, + gen_pack_y/9, + gen_pack_y/5, + gen_pack_xy/9, + gen_flush/9, + gen_flush/5, + gen_keep_opt/9, + gen_children/5, + make_extern_id/2, + gen_id/5, + gen_parent/5, + gen_type/5, + gen_beep/9, + gen_setfocus/9, + gen_setfocus/5, + gen_buttonpress/9, + gen_buttonpress/5, + gen_buttonrelease/9, + gen_buttonrelease/5, + gen_configure/9, + gen_configure/5, + gen_destroy/9, + gen_destroy/5, + gen_enter/9, + gen_enter/5, + gen_focus_ev/9, + gen_focus_ev/5, + gen_keypress/9, + gen_keypress/5, + gen_keyrelease/9, + gen_keyrelease/5, + gen_leave/9, + gen_leave/5, + gen_motion/9, + gen_motion/5, + gen_highlightbw/9, + gen_highlightbw/5, + gen_highlightbg/9, + gen_highlightbg/5, + gen_highlightfg/9, + gen_highlightfg/5, + gen_selectbw/9, + gen_selectbw/5, + gen_selectfg/9, + gen_selectfg/5, + gen_selectbg/9, + gen_selectbg/5, + gen_fg/9, + gen_fg/5, + gen_bg/9, + gen_bg/5, + gen_so_activebg/9, + gen_so_activebg/5, + gen_so_bc/9, + gen_so_bc/5, + gen_so_scrollfg/9, + gen_so_scrollfg/5, + gen_so_scrollbg/9, + gen_so_scrollbg/5, + obj/1, + gen_so_bg/9, + gen_so_bg/5, + gen_so_selectbw/9, + gen_so_selectbw/5, + gen_so_selectfg/9, + gen_so_selectfg/5, + gen_so_selectbg/9, + gen_so_selectbg/5, + gen_so_scrolls/9, + gen_so_hscroll/5, + gen_so_vscroll/5, + cursors/0, + gen_cursor/9, + gen_cursor/5, + gen_citem_coords/9, + gen_citem_coords/5, + gen_citem_fill/9, + gen_citem_fill/5, + gen_citem_lower/9, + gen_citem_raise/9, + gen_citem_move/9, + move_coords/3, + add_to_coords/3, + gen_citem_setfocus/9, + gen_citem_setfocus/5, + gen_citem_buttonpress/9, + gen_citem_buttonrelease/9, + gen_citem_enter/9, + gen_citem_keypress/9, + gen_citem_keyrelease/9, + gen_citem_leave/9, + gen_citem_motion/9, + scrolls_vh/3, + parse_scrolls/1, + parse_scrolls/2, + parse_scrolls/4, + bind/5, + bind/6, + ebind/6, + eunbind/6, + item_bind/6, + item_ebind/6, + item_eunbind/5, + event/5, + read_option/3, + make_command/4, + mk_create_opts_for_child/4]). + +-include("gstk.hrl"). +-include("gstk_generic.hrl"). + +%%---------------------------------------------------------------------- +%% Returns: a new unique TkWidget (string()) +%%---------------------------------------------------------------------- +mk_tkw_child(DB,#gstkid{parent=P,objtype=Ot}) -> + Pgstkid = gstk_db:lookup_gstkid(DB, P), + PW = Pgstkid#gstkid.widget, + Oref = gstk_db:counter(DB, Ot), + PF = gstk_widgets:suffix(Ot), + _TkW = lists:concat([PW, PF, Oref]). + +%%---------------------------------------------------------------------- +%% Purpose: Merges options. Opts have higher priority than BuiltIn +%% (and ParentOpts have higher than BuiltIn) +%% Returns: A list of new options. +%%---------------------------------------------------------------------- +merge_default_options(ParOpts, BuildInOpts, Opts) -> + %% parents options first + Tmp=merge_default_options(ParOpts, lists:sort(Opts)), + merge_default_options(BuildInOpts,Tmp). + +merge_default_options([Def|Ds],[Opt|Os]) + when element(1,Def) < element(1,Opt) -> + [Def | merge_default_options(Ds,[Opt|Os])]; + +merge_default_options([Def|Ds],[Opt|Os]) + when element(1,Def) > element(1,Opt) -> + [Opt | merge_default_options([Def|Ds],Os)]; + +merge_default_options([Def|Ds],[Opt|Os]) + when element(1,Def) == element(1,Opt) -> + [Opt | merge_default_options(Ds,Os)]; + +merge_default_options(Defs,[Opt|Os]) -> + [Opt | merge_default_options(Defs,Os)]; + +merge_default_options([],Opts) -> Opts; +merge_default_options(Defs,[]) -> Defs. + +opts_for_child(DB,Childtype,ParId) -> + case gs_widgets:container(Childtype) of + true -> + gstk_db:default_container_opts(DB,ParId,Childtype); + false -> + gstk_db:default_opts(DB,ParId,Childtype) + end. + +mk_create_opts_for_child(DB,#gstkid{objtype=ChildType}, Pgstkid, Opts) -> + merge_default_options( + opts_for_child(DB,ChildType,Pgstkid#gstkid.id), + gs_widgets:default_options(ChildType), + Opts). + +mk_cmd_and_exec(Opts,Gstkid,Scmd,DB) -> + TkW = Gstkid#gstkid.widget, + mk_cmd_and_exec(Opts,Gstkid,TkW,Scmd,[";place ", TkW],DB,dummy). +mk_cmd_and_exec(Opts,Gstkid,Scmd,Pcmd,DB) -> + mk_cmd_and_exec(Opts,Gstkid,Gstkid#gstkid.widget,Scmd,Pcmd,DB,dummy). +mk_cmd_and_exec(Options, Gstkid, TkW, SCmd, PCmd, DB) -> + mk_cmd_and_exec(Options, Gstkid, TkW, SCmd, PCmd, DB,dummy). +mk_cmd_and_exec(Options, Gstkid, TkW, SCmd, PCmd, DB,ExtraArg) -> + case gstk_generic:make_command(Options,Gstkid,TkW,SCmd,PCmd,DB,ExtraArg) of + {error,Reason} -> {error,Reason}; + Cmd when is_list(Cmd) -> + gstk:exec(Cmd) + end. + +%%---------------------------------------------------------------------- +%% SCmd: SimplePreCommand - prepended to simple (s) options +%% PCmd: PlacePreCommand - prepended to placer (p) options +%% (should start with ';' (at least if preceeded with simple cmds)) +%% Comment: If some function changes the gstkid, +%% it's responsible for storing it in the DB. +%%---------------------------------------------------------------------- +make_command(Opts,Gstkid,Scmd,DB) -> + TkW = Gstkid#gstkid.widget, + make_command(Opts,Gstkid,TkW,Scmd,[";place ", TkW],DB,dummy). +make_command(Opts,Gstkid,Scmd,Pcmd,DB) -> + make_command(Opts,Gstkid,Gstkid#gstkid.widget,Scmd,Pcmd,DB,dummy). +make_command(Options, Gstkid, TkW, SCmd, PCmd, DB) -> + make_command(Options, Gstkid, TkW, SCmd, PCmd, DB,dummy). +make_command(Options, Gstkid, TkW, SCmd, PCmd, DB,ExtraArg) -> + case out_opts(Options, Gstkid, TkW, DB, ExtraArg, [], [], []) of + {[], [], []} -> []; + {Si, [], []} -> [SCmd, Si,$;]; + {[], Pl, []} -> [PCmd, Pl,$;]; + {[], [], Co} -> [$;,Co]; + {[], Pl, Co} -> [PCmd, Pl, $;, Co]; + {Si, [], Co} -> [SCmd, Si, $;, Co]; + {Si, Pl, []} -> [SCmd, Si, PCmd, Pl, $;]; + {Si, Pl, Co} -> [SCmd, Si, PCmd, Pl, $;, Co]; + {error,Reason} -> {error,Reason} + end. + +read_option(DB,Gstkid,Opt) -> + read_option(DB,Gstkid,Gstkid#gstkid.widget,Opt,dummy). +read_option(DB,Gstkid,Opt,ExtraArg) -> + read_option(DB,Gstkid,Gstkid#gstkid.widget,Opt,ExtraArg). + +%%---------------------------------------------------------------------- +%% Args: Args is [Gstkid, TkW, DB, ExtraArg] +%% Comment: An optimization:don't reconstruct the arg list for apply each time. +%% This is the option-engine so we should optimize. +%%---------------------------------------------------------------------- +handle_external_opt_call([Opt|Options],Gstkid,TkW,DB,ExtraArg,ExtRes,S,P,C) -> + case ExtRes of + {s, Cmd} -> + out_opts(Options,Gstkid, TkW,DB, ExtraArg, [Cmd|S], P, C); + {p, Cmd} -> + out_opts(Options, Gstkid,TkW,DB, ExtraArg, S, [Cmd|P], C); + {c, Cmd} -> + out_opts(Options, Gstkid,TkW,DB, ExtraArg,S, P, [Cmd,$;|C]); + none -> + out_opts(Options, Gstkid,TkW,DB,ExtraArg, S, P, C); + % {s, NGstkid, Cmd} -> + % out_opts(Options,NGstkid,TkW,DB,ExtraArg, [Cmd|S], P, C); + % {p, NGstkid, Cmd} -> + % out_opts(Options,NGstkid,TkW,DB,ExtraArg, S, [Cmd|P], C); + {c, NGstkid, Cmd} -> + out_opts(Options,NGstkid,TkW,DB, ExtraArg,S,P,[Cmd,$;|C]); + {none, NGstkid} -> + out_opts(Options,NGstkid,TkW,DB, ExtraArg, S, P, C); + {sp,{Scmd,Pcmd}} -> + out_opts(Options,Gstkid,TkW,DB,ExtraArg,[Scmd|S],[Pcmd|P],C); + invalid_option -> + {error,{invalid_option,Gstkid#gstkid.objtype,Opt}}; + break -> % a hack. it is possible to abort generic option handling at + %% any time (without even inserting the gstkid inte to DB (for + %% performance reasons)). + {S, P, C} + end. + +handle_external_read(Res) -> + case Res of + {bad_result,{Objtype,Reason,Option}} -> + {error,{Objtype,Reason,Option}}; + _ -> ok + end, + Res. + +%%---------------------------------------------------------------------- +%% Generic options +%%---------------------------------------------------------------------- + +gen_anchor(How,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> + out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,[" -anc ", gstk:to_ascii(How)|P],C). +gen_anchor(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> + tcl2erl:ret_place(anchor, TkW). + +gen_height(Height,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> + gstk_db:insert_opt(DB,Gstkid,{height,Height}), + out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S, + [" -he ", gstk:to_ascii(Height)|P],C). +gen_height(_Opt,Gstkid,_TkW,DB,_ExtraArg) -> + gstk_db:opt(DB,Gstkid,height). + +gen_width(Width,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> + gstk_db:insert_opt(DB,Gstkid,{width,Width}), + out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S, + [" -wi ", gstk:to_ascii(Width)|P],C). +gen_width(_Opt,Gstkid,_TkW,DB,_ExtraArg) -> + gstk_db:opt(DB,Gstkid,width). + +gen_x(X,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> + gstk_db:insert_opt(DB,Gstkid,{x,X}), + out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S, + [" -x ", gstk:to_ascii(X)|P],C). +gen_x(_Opt,Gstkid,_TkW,DB,_ExtraArg) -> + gstk_db:opt(DB,Gstkid,x). + +gen_y(Y,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> + gstk_db:insert_opt(DB,Gstkid,{y,Y}), + out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S, + [" -y ", gstk:to_ascii(Y)|P],C). +gen_y(_Opt,Gstkid,_TkW,DB,_ExtraArg) -> + gstk_db:opt(DB,Gstkid,y). + +gen_raise(_,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> + out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,["raise ", TkW,$;|C]). +gen_raise(_Opt,_Gstkid,_TkW,_DB,_ExtraArg) -> + undefined. + +gen_lower(_,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> + out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,["lower ", TkW,$;|C]). +gen_lower(_Opt,_Gstkid,_TkW,_DB,_ExtraArg) -> + undefined. + +gen_enable(true,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> + out_opts(Opts,Gstkid,TkW,DB,ExtraArg,[" -st normal"|S],P,C); +gen_enable(false,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> + out_opts(Opts,Gstkid,TkW,DB,ExtraArg,[" -st disabled"|S],P,C). +gen_enable(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> + tcl2erl:ret_enable([TkW, " cg -st"]). + +gen_align(How,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> + out_opts(Opts,Gstkid,TkW,DB,ExtraArg,[" -an ", gstk:to_ascii(How)|S],P,C). +gen_align(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> + tcl2erl:ret_atom([TkW, " cg -anch"]). + +gen_justify(How,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> + out_opts(Opts,Gstkid,TkW,DB,ExtraArg,[" -ju ", gstk:to_ascii(How)|S],P,C). +gen_justify(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> + tcl2erl:ret_atom([TkW, " cg -ju"]). + +gen_padx(Pad,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> + out_opts(Opts,Gstkid,TkW,DB,ExtraArg,[" -padx ", gstk:to_ascii(Pad)|S],P,C). +gen_padx(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> + tcl2erl:ret_atom([TkW, " cg -padx"]). + +gen_pady(Pad,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> + out_opts(Opts,Gstkid,TkW,DB,ExtraArg,[" -pady ", gstk:to_ascii(Pad)|S],P,C). +gen_pady(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> + tcl2erl:ret_atom([TkW, " cg -pady"]). + + +gen_font(Font,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> + gstk_db:insert_opt(DB,Gstkid,{font,Font}), + out_opts(Opts,Gstkid,TkW,DB,ExtraArg, + [" -font ", gstk_font:choose_ascii(DB,Font)|S],P,C). +gen_font(_Opt,Gstkid,_TkW,DB,_ExtraArg) -> + gstk_db:opt(DB,Gstkid,font,undefined). + +gen_label({text,Text},Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> + out_opts(Opts,Gstkid,TkW,DB,ExtraArg,[" -text ", gstk:to_ascii(Text), " -bi {}"|S],P,C); +gen_label({image,Img},Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> + {ok, I2,_} = regexp:gsub(Img, [92,92], "/"), + out_opts(Opts,Gstkid,TkW,DB,ExtraArg,[" -bi \"@", I2, "\" -text {}"|S],P,C). +gen_label(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> + case gstk:call([TkW, " cg -bit"]) of + {result, [$@|Image]} -> {image,Image}; + _Nope -> + case gstk:call([TkW, " cg -text"]) of + {result, Txt} -> {text, Txt}; + Bad_Result -> Bad_Result + end + end. + +gen_activebg(Color,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> + out_opts(Opts,Gstkid,TkW,DB,ExtraArg,[" -activeba ", gstk:to_color(Color)|S],P,C). +gen_activebg(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> + tcl2erl:ret_color([TkW, " cg -activeba"]). + +gen_activefg(Color,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> + out_opts(Opts,Gstkid,TkW,DB,ExtraArg,[" -activef ", gstk:to_color(Color)|S],P,C). +gen_activefg(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> + tcl2erl:ret_color([TkW, " cg -activef"]). + + +gen_default(Opt,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> + case Opt of + {all, {font, Font}} -> + C2 = ["option a *",tl(TkW), % have to remove preceeding dot + "*font ",gstk_font:choose_ascii(DB, Font)], + gstk_db:insert_def(Gstkid,grid,{font,Font}), + gstk_db:insert_def(Gstkid,text,{font,Font}), + out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,[C2,$;|C]); + {buttons, {font, Font}} -> + C2 = ["option a *",tl(TkW), % have to remove preceeding dot + ".Button.font ",gstk_font:choose_ascii(DB, Font)], + out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,[C2,$;|C]); + {buttons,{Key,Val}} -> + gstk_db:insert_def(Gstkid,button,{Key,Val}), + gstk_db:insert_def(Gstkid,checkbutton,{Key,Val}), + gstk_db:insert_def(Gstkid,radiobutton,{Key,Val}), + out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,C); + {ObjType, {Key,Val}} -> + gstk_db:insert_def(Gstkid,ObjType,{Key,Val}), + out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) + end. + + +gen_relief(Relief,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> + out_opts(Opts,Gstkid,TkW,DB,ExtraArg,[" -reli ",gstk:to_ascii(Relief)|S],P,C). +gen_relief(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> + tcl2erl:ret_atom([TkW, " cg -reli"]). + +gen_bw(Wth,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> + out_opts(Opts,Gstkid,TkW,DB,ExtraArg,[" -bd ", gstk:to_ascii(Wth)|S],P,C). +gen_bw(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> + tcl2erl:ret_int([TkW, " cg -bd"]). + + + +gen_font_wh({font_wh,{Font, Txt}},_Gstkid,_TkW,DB,_) -> + gstk_font:width_height(DB, gstk_font:choose(DB,Font), Txt). + +gen_choose_font({choose_font,Font},_Gstkid,_TkW,DB,_ExtraArg) -> + gstk_font:choose(DB,Font). + +gen_data(Data,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> + gstk_db:insert_opt(DB,Gstkid,{data,Data}), + out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,C). +gen_data(_Opt,Gstkid,_TkW,DB,_ExtraArg) -> + gstk_db:opt(DB,Gstkid,data). + +gen_pack_x({Start,Stop},Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> + gstk_db:insert_opt(DB,Gstkid,{pack_x,{Start,Stop}}), + out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,C); +gen_pack_x(Col,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) when is_integer(Col) -> + gstk_db:insert_opt(DB,Gstkid,{pack_x,{Col,Col}}), + out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,C). +gen_pack_x(_Opt,Gstkid,_TkW,DB,_ExtraArg) -> + gstk_db:opt(DB,Gstkid,pack_x, undefined). + +gen_pack_y({Start,Stop},Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> + gstk_db:insert_opt(DB,Gstkid,{pack_y,{Start,Stop}}), + out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,C); +gen_pack_y(Row,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) when is_integer(Row) -> + gstk_db:insert_opt(DB,Gstkid,{pack_y,{Row,Row}}), + out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,C). +gen_pack_y(_Opt,Gstkid,_TkW,DB,_ExtraArg) -> + gstk_db:opt(DB,Gstkid,pack_y, undefined). + +gen_pack_xy({Col,Row},Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) + when is_integer(Col), is_integer(Row) -> + gstk_db:insert_opt(DB,Gstkid,{pack_x,{Col,Col}}), + gstk_db:insert_opt(DB,Gstkid,{pack_y,{Row,Row}}), + out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,C); +gen_pack_xy({Col,{StartRow,StopRow}},Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) + when is_integer(Col) -> + gstk_db:insert_opt(DB,Gstkid,{pack_x,{Col,Col}}), + gstk_db:insert_opt(DB,Gstkid,{pack_y,{StartRow,StopRow}}), + out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,C); +gen_pack_xy({{StartCol,StopCol},Row},Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) + when is_integer(Row) -> + gstk_db:insert_opt(DB,Gstkid,{pack_x,{StartCol,StopCol}}), + gstk_db:insert_opt(DB,Gstkid,{pack_y,{Row,Row}}), + out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,C); +gen_pack_xy({Col,Row},Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> + gstk_db:insert_opt(DB,Gstkid,{pack_x,Col}), + gstk_db:insert_opt(DB,Gstkid,{pack_y,Row}), + out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,C). + + +gen_flush(_Opt,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> + tcl2erl:ret_int(["update idletasks;expr 1+1"]), + out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,C). +gen_flush(_Opt,_Gstkid,_TkW,_DB,_ExtraArg) -> + tcl2erl:ret_int(["update idletasks;expr 1+1"]). + + % a hidden impl option. +gen_keep_opt(Opt,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> + gstk_db:insert_opt(DB,Gstkid,Opt), + out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,C). + +gen_children(_Opt,Gstkid,_TkW,DB,_ExtraArg) -> + make_extern_id(gstk_db:lookup_kids(DB, Gstkid#gstkid.id), DB). + +make_extern_id([Id|Ids], DB) -> + [gstk:make_extern_id(Id, DB) | make_extern_id(Ids, DB)]; +make_extern_id([], _) -> []. + +gen_id(_Opt,#gstkid{id=Id},_TkW,DB,_ExtraArg) -> + gstk:make_extern_id(Id, DB). + +gen_parent(_Opt,Gstkid,_TkW,DB,_ExtraArg) -> + gstk:make_extern_id(Gstkid#gstkid.parent, DB). + +gen_type(_Opt,Gstkid,_TkW,_DB,_ExtraArg) -> + Gstkid#gstkid.objtype. + +gen_beep(_,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> + out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,["bell;",$;|C]). + +gen_setfocus(true,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> + out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,["focus ", TkW,$;|C]); +gen_setfocus(false,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> + out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,["focus .",$;|C]). + +gen_setfocus(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> + tcl2erl:ret_focus(TkW, "focus"). + +gen_buttonpress(On,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> + Cmd = bind(DB, Gstkid, TkW, buttonpress, On), + out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,[Cmd,$;|C]). +gen_buttonpress(_Opt,Gstkid,_TkW,DB,_ExtraArg) -> + gstk_db:is_inserted(DB, Gstkid, buttonpress). + +gen_buttonrelease(On,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> + Cmd = bind(DB, Gstkid, TkW, buttonrelease, On), + out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,[Cmd,$;|C]). +gen_buttonrelease(_Opt,Gstkid,_TkW,DB,_ExtraArg) -> + gstk_db:is_inserted(DB,Gstkid,buttonrelease). + +gen_configure(On,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> + Cmd = bind(DB, Gstkid, TkW, configure, On), + out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,[Cmd,$;|C]). +gen_configure(_Opt,Gstkid,_TkW,DB,_ExtraArg) -> + gstk_db:is_inserted(DB,Gstkid,configure). + +gen_destroy(On,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> + Cmd = bind(DB, Gstkid, TkW, destroy, On), + out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,[Cmd,$;|C]). +gen_destroy(_Opt,Gstkid,_TkW,DB,_ExtraArg) -> + gstk_db:is_inserted(DB,Gstkid,destroy). + +gen_enter(On,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> + Cmd = bind(DB, Gstkid, TkW, enter, On), + out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,[Cmd,$;|C]). +gen_enter(_Opt,Gstkid,_TkW,DB,_ExtraArg) -> + gstk_db:is_inserted(DB,Gstkid,enter). + +gen_focus_ev(On,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> + Cmd = bind(DB, Gstkid, TkW, focus, On), + out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,[Cmd,$;|C]). +gen_focus_ev(_Opt,Gstkid,_TkW,DB,_ExtraArg) -> + gstk_db:is_inserted(DB,Gstkid,focus). + +gen_keypress(On,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> + Cmd = bind(DB, Gstkid, TkW, keypress, On), + out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,[Cmd,$;|C]). +gen_keypress(_Opt,Gstkid,_TkW,DB,_ExtraArg) -> + gstk_db:is_inserted(DB,Gstkid,keypress). + +gen_keyrelease(On,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> + Cmd = bind(DB, Gstkid, TkW, keyrelease, On), + out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,[Cmd,$;|C]). +gen_keyrelease(_Opt,Gstkid,_TkW,DB,_ExtraArg) -> + gstk_db:is_inserted(DB,Gstkid,keyrelease). + +gen_leave(On,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> + Cmd = bind(DB, Gstkid, TkW, leave, On), + out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,[Cmd,$;|C]). +gen_leave(_Opt,Gstkid,_TkW,DB,_ExtraArg) -> + gstk_db:is_inserted(DB,Gstkid,leave). + +gen_motion(On,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> + Cmd = bind(DB, Gstkid, TkW, motion, On), + out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,[Cmd,$;|C]). +gen_motion(_Opt,Gstkid,_TkW,DB,_ExtraArg) -> + gstk_db:is_inserted(DB,Gstkid,motion). + +gen_highlightbw(Wth,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> + out_opts(Opts,Gstkid,TkW,DB,ExtraArg,[" -highlightt ", gstk:to_ascii(Wth)|S],P,C). +gen_highlightbw(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> + tcl2erl:ret_int([TkW, " cg -highlightt"]). + +gen_highlightbg(Color,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> + out_opts(Opts,Gstkid,TkW,DB,ExtraArg,[" -highlightb ", gstk:to_color(Color)|S],P,C). +gen_highlightbg(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> + tcl2erl:ret_color([TkW, " cg -highlightb"]). + +gen_highlightfg(Color,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> + out_opts(Opts,Gstkid,TkW,DB,ExtraArg,[" -highlightc ", gstk:to_color(Color)|S],P,C). +gen_highlightfg(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> + tcl2erl:ret_color([TkW, " cg -highlightc"]). + + +gen_selectbw(Width,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> + out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,[TkW, " conf -selectbo ", gstk:to_ascii(Width),$;|C]). +gen_selectbw(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> + tcl2erl:ret_int([TkW," cg -selectbo"]). + +gen_selectfg(Color,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> + out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,[TkW, " conf -selectfo ", gstk:to_color(Color),$;|C]). +gen_selectfg(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> + tcl2erl:ret_color([TkW," cg -selectfo"]). + +gen_selectbg(Color,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> + out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,[TkW, " conf -selectba ", gstk:to_color(Color),$;|C]). +gen_selectbg(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> + tcl2erl:ret_color([TkW," cg -selectba"]). + +gen_fg(Color,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> + out_opts(Opts,Gstkid,TkW,DB,ExtraArg,[" -fg ", gstk:to_color(Color)|S],P,C). +gen_fg(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> + tcl2erl:ret_color([TkW, " cg -fg"]). + +gen_bg(Color,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> + out_opts(Opts,Gstkid,TkW,DB,ExtraArg,[" -bg ", gstk:to_color(Color)|S],P,C). +gen_bg(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> + tcl2erl:ret_color([TkW, " cg -bg"]). + +%%---------------------------------------------------------------------- +%% Generic functions for scrolled objects +%%---------------------------------------------------------------------- +gen_so_activebg(Color,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> + Col = gstk:to_color(Color), + C2 = [TkW, ".sy conf -activeba ", Col,$;, + TkW, ".pad.sx conf -activeba ", Col], + out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,[C2,$;|C]). +gen_so_activebg(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> + tcl2erl:ret_color([TkW,".sy cg -activeba"]). + +gen_so_bc(Color,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> + Col = gstk:to_color(Color), + C2= [TkW, " conf -bg ", Col,$;, + TkW, ".sy conf -highlightba ", Col,$;, + TkW, ".pad.it conf -bg ", Col,$;, + TkW, ".pad.sx conf -highlightba ", Col], + out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,[C2,$;|C]). +gen_so_bc(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> + tcl2erl:ret_color([TkW," cg -bg"]). + +gen_so_scrollfg(Color,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> + Col = gstk:to_color(Color), + C2=[TkW, ".sy conf -bg ", Col,$;, + TkW, ".pad.sx conf -bg ", Col], + out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,[C2,$;|C]). +gen_so_scrollfg(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> + tcl2erl:ret_color([TkW,".sy cg -bg"]). + + +gen_so_scrollbg(Color,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> + Col = gstk:to_color(Color), + C2 = [TkW, ".sy conf -troughc ", Col, $;, + TkW, ".pad.sx conf -troughc ", Col], + out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,[C2,$;|C]). + +gen_so_scrollbg(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> + tcl2erl:ret_color([TkW,".sy cg -troughc"]). + +obj(#gstkid{widget_data=SO}) -> + SO#so.object. + +gen_so_bg(Color,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> + C2= [obj(Gstkid), " conf -bg ", gstk:to_color(Color)], + out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,[C2,$;|C]). +gen_so_bg(_Opt,Gstkid,_TkW,_DB,_ExtraArg) -> + tcl2erl:ret_color([obj(Gstkid)," cg -bg"]). + +gen_so_selectbw(Width,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> + C2 = [obj(Gstkid), " conf -selectbo ", gstk:to_ascii(Width)], + out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,[C2,$;|C]). +gen_so_selectbw(_Opt,Gstkid,_TkW,_DB,_ExtraArg) -> + tcl2erl:ret_int([obj(Gstkid)," cg -selectbo"]). + +gen_so_selectfg(Color,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> + C2 = [obj(Gstkid), " conf -selectfo ", gstk:to_color(Color)], + out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,[C2,$;|C]). +gen_so_selectfg(_Opt,Gstkid,_TkW,_DB,_ExtraArg) -> + tcl2erl:ret_color([obj(Gstkid)," cg -selectfo"]). + +gen_so_selectbg(Color,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> + C2 = [obj(Gstkid), " conf -selectba ", gstk:to_color(Color)], + out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,[C2,$;|C]). +gen_so_selectbg(_Opt,Gstkid,_TkW,_DB,_ExtraArg) -> + tcl2erl:ret_color([obj(Gstkid)," cg -selectba"]). + +gen_so_scrolls({Vscroll, Hscroll},Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> + SO = Gstkid#gstkid.widget_data, + NewSO = SO#so{hscroll=Hscroll, vscroll=Vscroll}, + C2 = scrolls_vh(TkW, Vscroll, Hscroll), + Ngstkid = Gstkid#gstkid{widget_data=NewSO}, + gstk_db:update_widget(DB,Ngstkid), + out_opts(Opts,Ngstkid,TkW,DB,ExtraArg,S,P,[C2,$;|C]). + + % read-only +gen_so_hscroll(_Opt,#gstkid{widget_data=SO},_TkW,_DB,_) -> + SO#so.hscroll. + + % read-only +gen_so_vscroll(_Opt,#gstkid{widget_data=SO},_TkW,_DB,_) -> + SO#so.vscroll. + +cursors() -> [{arrow,"top_left_arrow"},{busy,"watch"},{cross,"X_cursor"}, + {hand,"hand2"},{help,"question_arrow"},{resize,"fleur"}, + {text,"xterm"}]. + +gen_cursor(parent,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> + out_opts(Opts,Gstkid,TkW,DB,ExtraArg,[" -cur {}"|S],P,C); +gen_cursor(Cur,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> + case gs:assq(Cur,cursors()) of + {value, TxtCur} -> + out_opts(Opts,Gstkid,TkW,DB,ExtraArg,[" -cur ",TxtCur|S],P,C); + _ -> + {error,{invalid_cursor,Gstkid#gstkid.objtype,Cur}} + end. +gen_cursor(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> + case tcl2erl:ret_str([TkW," cg -cur"]) of + "" -> parent; + Txt when is_list(Txt) -> + case lists:keysearch(Txt,2,cursors()) of + {value,{Cur,_}} -> Cur; + _ -> {bad_result, read_cursor} + end; + Bad_Result -> Bad_Result + end. + +gen_citem_coords(Coords,Opts,Gstkid,TkW,DB,AItem,S,P,C) -> + gstk_db:insert_opt(DB,Gstkid,{coords,Coords}), + out_opts(Opts,Gstkid,TkW,DB,AItem,S,P, + [TkW, " coords ", AItem," ",gstk_canvas:coords(Coords),$;|C]). +gen_citem_coords(_Opt,Gstkid,_TkW,DB,_ExtraArg) -> + gstk_db:opt(DB,Gstkid, coords). + +gen_citem_fill(none,Opts,Gstkid,TkW,DB,AItem,S,P,C) -> + out_opts(Opts,Gstkid,TkW,DB,AItem,[" -f {}"|S],P,C); +gen_citem_fill(Color,Opts,Gstkid,TkW,DB,AItem,S,P,C) -> + out_opts(Opts,Gstkid,TkW,DB,AItem,[" -f ",gstk:to_color(Color)|S],P,C). +gen_citem_fill(_Opt,_Gstkid,TkW,_DB,AItem) -> + tcl2erl:ret_color([TkW, " itemcg ", AItem, " -f"]). + +gen_citem_lower(_,Opts,Gstkid,TkW,DB,AItem,S,P,C) -> + out_opts(Opts,Gstkid,TkW,DB,AItem,S,P, + [TkW, " lower ", AItem,$;|C]). + +gen_citem_raise(_,Opts,Gstkid,TkW,DB,AItem,S,P,C) -> + out_opts(Opts,Gstkid,TkW,DB,AItem,S,P, + [TkW, " raise ", AItem,$;|C]). + +gen_citem_move({Dx,Dy},Opts,Gstkid,TkW,DB,AItem,S,P,C) -> + NewCoords = move_coords(Dx,Dy,gstk_db:opt(DB,Gstkid,coords)), + gstk_db:insert_opt(DB,Gstkid,NewCoords), + out_opts(Opts,Gstkid,TkW,DB,AItem,S,P, + [TkW, " move ", AItem, " ", + gstk:to_ascii(Dx), " ", gstk:to_ascii(Dy),$;|C]). + +move_coords(Dx,Dy,Coords) -> + Coords2 = add_to_coords(Dx,Dy, Coords), + {coords,Coords2}. + +add_to_coords(Dx,Dy,[{X,Y}|Coords]) -> + [{X+Dx,Y+Dy}|add_to_coords(Dx,Dy,Coords)]; +add_to_coords(_,_,[]) -> []. + + +gen_citem_setfocus(true,Opts,Gstkid,TkW,DB,AItem,S,P,C) -> + out_opts(Opts,Gstkid,TkW,DB,AItem,S,P, + [TkW, " focus ", AItem,$;|C]); +gen_citem_setfocus(false,Opts,Gstkid,TkW,DB,AItem,S,P,C) -> + out_opts(Opts,Gstkid,TkW,DB,AItem,S,P, + [TkW, " focus {}",$;|C]). +gen_citem_setfocus(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> + tcl2erl:ret_focus(gstk:to_ascii(bug_aitem),[TkW, " focus"]). + +gen_citem_buttonpress(On,Opts,Gstkid,TkW,DB,AItem,S,P,C) -> + out_opts(Opts,Gstkid,TkW,DB,AItem,S,P, + [item_bind(DB, Gstkid, TkW, AItem,buttonpress, On),$;|C]). +gen_citem_buttonrelease(On,Opts,Gstkid,TkW,DB,AItem,S,P,C) -> + out_opts(Opts,Gstkid,TkW,DB,AItem,S,P, + [item_bind(DB,Gstkid,TkW,AItem,buttonrelease, On),$;|C]). +gen_citem_enter(On,Opts,Gstkid,TkW,DB,AItem,S,P,C) -> + out_opts(Opts,Gstkid,TkW,DB,AItem,S,P, + [item_bind(DB, Gstkid, TkW, AItem, enter, On),$;|C]). + +gen_citem_keypress(On,Opts,Gstkid,TkW,DB,AItem,S,P,C) -> + out_opts(Opts,Gstkid,TkW,DB,AItem,S,P, + [item_bind(DB, Gstkid, TkW, AItem, keypress, On),$;|C]). +gen_citem_keyrelease(On,Opts,Gstkid,TkW,DB,AItem,S,P,C) -> + out_opts(Opts,Gstkid,TkW,DB,AItem,S,P, + [item_bind(DB, Gstkid, TkW, AItem, keyrelease, On),$;|C]). + +gen_citem_leave(On,Opts,Gstkid,TkW,DB,AItem,S,P,C) -> + out_opts(Opts,Gstkid,TkW,DB,AItem,S,P, + [item_bind(DB, Gstkid, TkW, AItem, leave, On),$;|C]). +gen_citem_motion(On,Opts,Gstkid,TkW,DB,AItem,S,P,C) -> + out_opts(Opts,Gstkid,TkW,DB,AItem,S,P, + [item_bind(DB, Gstkid, TkW, AItem, motion, On),$;|C]). + + +scrolls_vh(W, V, true) -> scrolls_vh(W, V, bottom); +scrolls_vh(W, true, H) -> scrolls_vh(W, left, H); +scrolls_vh(W, left, bottom) -> ["so_bottom_left ",W]; +scrolls_vh(W, left, top) -> ["so_top_left ",W]; +scrolls_vh(W, left, _) -> ["so_left ",W]; +scrolls_vh(W, right, bottom) -> ["so_bottom_right ",W]; +scrolls_vh(W, right, top) -> ["so_top_right ",W]; +scrolls_vh(W, right, _) -> ["so_right ",W]; +scrolls_vh(W, _, bottom) -> ["so_bottom ",W]; +scrolls_vh(W, _, top) -> ["so_top ",W]; +scrolls_vh(W, _, _) -> ["so_plain ",W]. + +%% create version +parse_scrolls(Opts) -> + {Vscroll, Hscroll, NewOpts} = parse_scrolls(Opts, false, false, []), + {Vscroll, Hscroll, [{scrolls, {Vscroll, Hscroll}} | NewOpts]}. + +%% config version +parse_scrolls(Gstkid, Opts) -> + SO = Gstkid#gstkid.widget_data, + Vscroll = SO#so.vscroll, + Hscroll = SO#so.hscroll, + case parse_scrolls(Opts, Vscroll, Hscroll, []) of + {Vscroll, Hscroll, Opts} -> Opts; + {NewVscroll, NewHscroll, NewOpts} -> + [{scrolls, {NewVscroll, NewHscroll}} | NewOpts] + end. + + +parse_scrolls([Option | Rest], Vscroll, Hscroll, Opts) when is_tuple(Option) -> + case element(1, Option) of + vscroll -> + parse_scrolls(Rest, element(2, Option), Hscroll, Opts); + hscroll -> + parse_scrolls(Rest, Vscroll, element(2, Option), Opts); + _ -> + parse_scrolls(Rest, Vscroll, Hscroll, [Option | Opts]) + end; + +parse_scrolls([Option | Rest], Vscroll, Hscroll, Opts) -> + parse_scrolls(Rest, Vscroll, Hscroll, [Option | Opts]); + +parse_scrolls([], Vscroll, Hscroll, Opts) -> + {Vscroll, Hscroll, Opts}. + + +%% +%% Event bind main function +%% +%% Should return a list of tcl commands or invalid_option +%% +%% WS = Widget suffix for complex widgets +%% +bind(DB, Gstkid, TkW, Etype, On) -> + WD = Gstkid#gstkid.widget_data, + TkW2 = if is_record(WD, so) -> + WD#so.object; + true -> TkW + end, + case bind(DB, Gstkid, TkW2, Etype, On, "") of + invalid_option -> invalid_option; + Cmd -> + Cmd + end. + +bind(DB, Gstkid, TkW, Etype, On, WS) -> + case On of + true -> ebind(DB, Gstkid, TkW, Etype, WS, ""); + false -> eunbind(DB, Gstkid, TkW, Etype, WS, ""); + {true, Edata} -> ebind(DB, Gstkid, TkW, Etype, WS, Edata); + {false, Edata} -> eunbind(DB, Gstkid, TkW, Etype, WS, Edata); + _ -> invalid_option + end. + + +%% +%% Event bind on +%% +%% Should return a list of tcl commands or invalid_option +%% +%% WS = Widget suffix for complex widgets +%% +ebind(DB, Gstkid, TkW, Etype, WS, Edata) -> + Eref = gstk_db:insert_event(DB, Gstkid, Etype, Edata), + P = ["bind ", TkW, WS], + Cmd = case Etype of + motion -> [P, " <Motion> {erlsend ", Eref, " %x %y}"]; + keypress -> + [P, " <KeyPress> {erlsend ", Eref," %K %N 0 0};", + P, " <Shift-KeyPress> {erlsend ", Eref, " %K %N 1 0};", + P, " <Control-KeyPress> {erlsend ", Eref, " %K %N 0 1};", + P," <Control-Shift-KeyPress> {erlsend ", Eref," %K %N 1 1}"]; + keyrelease -> + [P, " <KeyRelease> {erlsend ", Eref," %K %N 0 0};", + P, " <Shift-KeyRelease> {erlsend ", Eref, " %K %N 1 0};", + P, " <Control-KeyRelease> {erlsend ", Eref, " %K %N 0 1};", + P," <Control-Shift-KeyRelease> {erlsend ",Eref," %K %N 1 1}"]; + buttonpress -> + [P, " <ButtonPress> {erlsend ", Eref, " %b %x %y}"]; + buttonrelease -> + [P, " <ButtonRelease> {erlsend ", Eref, " %b %x %y}"]; + leave -> [P, " <Leave> {erlsend ", Eref, "}"]; + enter -> [P, " <Enter> {erlsend ", Eref, "}"]; + destroy -> + [P, " <Destroy> {if {\"%W\"==\"", [TkW, WS], + "\"} {erlsend ", Eref, "}}"]; + focus -> + [P, " <FocusIn> {erlsend ", Eref, " 1};" , + P, " <FocusOut> {erlsend ", Eref, " 0}"]; + configure -> + [P, " <Configure> {if {\"%W\"==\"", [TkW, WS], + "\"} {erlsend ", Eref, " %w %h %x %y}}"] + end, + Cmd. + + +%% +%% Unbind event +%% +%% Should return a list of tcl commands +%% Already checked for validation in bind/5 +%% +%% WS = Widget suffix for complex widgets +%% +eunbind(DB, Gstkid, TkW, Etype, WS, _Edata) -> + gstk_db:delete_event(DB, Gstkid, Etype), + P = ["bind ", TkW, WS], + Cmd = case Etype of + motion -> + [P, " <Motion> {}"]; + keypress -> + [P, " <KeyPress> {};", + P, " <Shift-KeyPress> {};", + P, " <Control-KeyPress> {};", + P, " <Control-Shift-KeyPress> {}"]; + keyrelease -> + [P, " <KeyRelease> {};", + P, " <Shift-KeyRelease> {};", + P, " <Control-KeyRelease> {};", + P, " <Control-Shift-KeyRelease> {}"]; + buttonpress -> + [P, " <ButtonPress> {}"]; + buttonrelease -> + [P, " <ButtonRelease> {}"]; + leave -> + [P, " <Leave> {}"]; + enter -> + [P, " <Enter> {}"]; + destroy -> + [P, " <Destroy> {}"]; + focus -> + [P, " <FocusIn> {};", + P, " <FocusOut> {}"]; + configure -> + [P, " <Configure> {}"] + end, + Cmd. + + +%% +%% Event item bind main function +%% +%% Should return a list of tcl commands or invalid_option +%% +item_bind(DB, Gstkid, Canvas, Item, Etype, On) -> + case On of + true -> item_ebind(DB, Gstkid, Canvas, Item, Etype, ""); + {true, Edata} -> item_ebind(DB, Gstkid, Canvas, Item, Etype, Edata); + _Other -> item_eunbind(DB, Gstkid, Canvas, Item, Etype) + end. + +%% +%% Event bind on +%% +%% Should return a list of tcl commands or invalid_option +%% +item_ebind(DB, Gstkid, Canvas, Item, Etype, Edata) -> + Eref = gstk_db:insert_event(DB, Gstkid, Etype, Edata), + P = [Canvas, " bind ", Item], + case Etype of + enter -> [P, " <Enter> {erlsend ", Eref, "}"]; + leave -> [P, " <Leave> {erlsend ", Eref, "}"]; + motion -> [P, " <Motion> {erlsend ", Eref, " [", + Canvas, " canvasx %x] [", Canvas, " canvasy %y] %x %y}"]; + keypress -> + [P, " <Key> {erlsend ", Eref," %K %N 0 0 [", + Canvas, " canvasx %x] [", Canvas, " canvasy %y]};", + P, " <Shift-Key> {erlsend ", Eref, " %K %N 1 0 [", + Canvas, " canvasx %x] [", Canvas, " canvasy %y]};", + P, " <Control-Key> {erlsend ", Eref, " %K %N 0 1 [", + Canvas, " canvasx %x] [", Canvas, " canvasy %y]};", + P, " <Control-Shift-Key> {erlsend ", Eref," %K %N 1 1 [", + Canvas, " canvasx %x] [", Canvas, " canvasy %y]}"]; + keyrelease -> + [P, " <KeyRelease> {erlsend ", Eref," %K %N 0 0 [", + Canvas, " canvasx %x] [", Canvas, " canvasy %y]};", + P, " <Shift-KeyRelease> {erlsend ", Eref, " %K %N 1 0 [", + Canvas, " canvasx %x] [", Canvas, " canvasy %y]};", + P, " <Control-KeyRelease> {erlsend ", Eref, " %K %N 0 1 [", + Canvas, " canvasx %x] [", Canvas, " canvasy %y]};", + P, " <Control-Shift-KeyRelease> {erlsend ", Eref," %K %N 1 1[", + Canvas, " canvasx %x] [", Canvas, " canvasy %y]}"]; + buttonpress -> + [P, " <Button> {erlsend ", Eref, " %b [", + Canvas, " canvasx %x] [", Canvas, " canvasy %y] %x %y}"]; + buttonrelease -> + [P, " <ButtonRelease> {erlsend ", Eref, " %b [", + Canvas, " canvasx %x] [", Canvas, " canvasy %y] %x %y}"] + end. + + +%% +%% Unbind event +%% +%% Should return a list of tcl commands +%% Already checked for validation in bind/5 +%% +item_eunbind(DB, Gstkid, Canvas, Item, Etype) -> + gstk_db:delete_event(DB, Gstkid, Etype), + P = [Canvas, " bind ", Item], + Cmd = case Etype of + enter -> [P, " <Enter> {}"]; + leave -> [P, " <Leave> {}"]; + motion -> [P, " <Motion> {}"]; + keypress -> + [P, " <KeyPress> {};", + P, " <Shift-KeyPress> {};", + P, " <Control-KeyPress> {};", + P, " <Control-Shift-KeyPress> {}"]; + keyrelease -> + [P, " <KeyRelease> {};", + P, " <Shift-KeyRelease> {};", + P, " <Control-KeyRelease> {};", + P, " <Control-Shift-KeyRelease> {}"]; + buttonpress -> [P, " <Button> {}"]; + buttonrelease -> [P, " <ButtonRelease> {}"] + end, + Cmd. + + + +event(DB, Gstkid, Etype, _Edata, Args) -> + #gstkid{owner=Ow,id=Id} = Gstkid, + Data = gstk_db:opt(DB,Gstkid,data), + gs_frontend:event(get(gs_frontend),Ow,{gs,Id,Etype,Data,Args}). diff --git a/lib/gs/src/gstk_grid.erl b/lib/gs/src/gstk_grid.erl new file mode 100644 index 0000000000..4189246822 --- /dev/null +++ b/lib/gs/src/gstk_grid.erl @@ -0,0 +1,282 @@ +%% +%% %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_grid). + +-export([event/5,create/3,config/3,option/5,read/3,delete/2,destroy/2, + mk_create_opts_for_child/4,read_option/5]). + +-include("gstk.hrl"). + +%%----------------------------------------------------------------------------- +%% GRID OPTIONS +%% +%% rows {ViewFrom, ViewTo} +%% columnwidths [CW1, CW2, ..., CWn] +%% vscroll Bool | left | right +%% hscroll Bool | top | bottom +%% x Coord +%% y Coord +%% width Int +%% height Int +%% fg Color (lines and default line color) +%% bg Color +%%----------------------------------------------------------------------------- + +-record(state,{canvas,ncols,max_range,cell_id, cell_pos,ids,db,tkcanvas}). +-record(item,{text_id,rect_id,line_id}). + +%%====================================================================== +%% Interfaces +%%====================================================================== + +event(DB, Gstkid, Etype, Edata, Args) -> + gstk_gridline:event(DB, Gstkid, Etype, Edata, Args). + +create(DB, Gstkid, Options) -> + WinParent=Gstkid#gstkid.parent, + {OtherOpts,CanvasOpts} = parse_opts(Options,[],[]), + %% Why this (secret) hack? Performance reasons. + %% if we ".canvas bind all" once and for all, then we can + %% create lines twice as fast since we don't have to bind each line. + C = make_ref(), + gstk:create_impl(DB,{a_grid, {canvas,C,WinParent, + [{secret_hack_gridit, Gstkid} + | CanvasOpts]}}), + CanvasGstkid = gstk_db:lookup_gstkid(DB, C), + Wid = CanvasGstkid#gstkid.widget, + SO = CanvasGstkid#gstkid.widget_data, + TkCanvas = SO#so.object, + CI=ets:new(gstk_grid_cellid,[private,set]), + CP=ets:new(gstk_grid_cellpos,[private,set]), + IDs=ets:new(gstk_grid_id,[private,set]), + S=#state{db=DB,ncols=length(gs:val(columnwidths,OtherOpts)), + canvas=C,cell_id=CI,tkcanvas=TkCanvas,cell_pos=CP,ids=IDs}, + Ngstkid = Gstkid#gstkid{widget=Wid,widget_data=S}, + gstk_db:insert_opts(DB,Ngstkid,OtherOpts), + gstk_db:insert_widget(DB,Ngstkid), + gstk_generic:mk_cmd_and_exec(lists:keydelete(columnwidths,1,OtherOpts), + Ngstkid, TkCanvas,"","", DB,nop). + +config(DB, Gstkid, Options) -> + #gstkid{widget=TkW,widget_data=State}=Gstkid, + {OtherOpts,CanvasOpts} = parse_opts(Options,[],[]), + case gstk:config_impl(DB,State#state.canvas,CanvasOpts) of + ok -> + SimplePreCmd = "nyi?", + PlacePreCmd = [";place ", TkW], + gstk_generic:mk_cmd_and_exec(OtherOpts,Gstkid,TkW, + SimplePreCmd,PlacePreCmd,DB,State); + Err -> Err + end. + + +option(Option, Gstkid, _TkW, DB,State) -> + case Option of + {rows,{From,To}} -> + Ngstkid = reconfig_rows(From,To,Gstkid), + gstk_db:insert_opt(DB,Gstkid,Option), + gstk_db:update_widget(DB,Ngstkid), + {none,Ngstkid}; + {fg,_Color} -> + reconfig_grid(DB,Option,State), + gstk_db:insert_opt(DB,Gstkid,Option), + none; + {bg,_Color} -> + reconfig_grid(DB,Option,State), + gstk_db:insert_opt(DB,Gstkid,Option), + none; + {font,_Font} -> + reconfig_grid(DB,Option,State), + gstk_db:insert_opt(DB,Gstkid,Option), + none; + {columnwidths,ColWs} -> + gstk_db:insert_opt(DB,Gstkid,Option), + Rows = gstk_db:opt(DB,Gstkid,rows), + CellHeight = gstk_db:opt(DB,Gstkid,cellheight), + gstk:config_impl(DB,State#state.canvas, + [calc_scrollregion(Rows,ColWs,CellHeight)]), + %% Crash upon an error msg (so we know WHY) + {result,_} = gstk:call(["resize_grid_cols ",State#state.tkcanvas, + " [list ",asc_tcl_colw(ColWs),"]"]), + none; + {cellheight,_Height} -> + gstk_db:insert_opt(DB,Gstkid,Option), + none; + _ -> + invalid_option + end. + +reconfig_grid(_,_,nop) -> done; +reconfig_grid(DB,Option,#state{tkcanvas=TkW,cell_pos=CP, + ncols=Ncols,max_range={From,To}}) -> + reconfig_grid(DB,TkW,Option,From,To,CP,Ncols). + +reconfig_grid(DB,TkW,Opt,Row,MaxRow,CellPos,Ncols) when Row =< MaxRow -> + [{_,Item}] = ets:lookup(CellPos,{1,Row}), + case Item#item.line_id of + free -> empty_cell_config(DB,TkW,Row,1,Ncols,CellPos,Opt); + GridLine -> + gstk_gridline:config(DB,gstk_db:lookup_gstkid(DB,GridLine), + [Opt]) + end, + reconfig_grid(DB,TkW,Opt,Row+1,MaxRow,CellPos,Ncols); +reconfig_grid(_,_,_,_,_,_,_) -> done. + +%%---------------------------------------------------------------------- +%% Purpose: Config an empty cell (i.e. has no gridline) +%%---------------------------------------------------------------------- +empty_cell_config(DB,TkW,Row,Col,Ncols,CellPos,Opt) when Col =< Ncols -> + [{_,Item}] = ets:lookup(CellPos,{Col,Row}), + empty_cell_config(DB,TkW,Item,Opt), + empty_cell_config(DB,TkW,Row,Col+1,Ncols,CellPos,Opt); +empty_cell_config(_,_,_,_,_,_,_) -> done. + +empty_cell_config(_,TkW,#item{rect_id=Rid},{bg,Color}) -> + gstk:exec([TkW," itemconf ",gstk:to_ascii(Rid)," -f ",gstk:to_color(Color)]); +empty_cell_config(_,TkW,#item{rect_id=Rid,text_id=Tid},{fg,Color}) -> + Acolor = gstk:to_color(Color), + Pre = [TkW," itemconf "], + RectStr = [Pre, gstk:to_ascii(Rid)," -outline ",Acolor], + TexdStr = [Pre, gstk:to_ascii(Tid)," -fi ",Acolor], + gstk:exec([RectStr,$;,TexdStr]); +empty_cell_config(DB,TkW,#item{text_id=Tid},{font,Font}) -> + gstk:exec([TkW," itemconf ",gstk:to_ascii(Tid)," -font ", + gstk_font:choose_ascii(DB,Font)]); +empty_cell_config(_,_,_,_) -> done. + + + +reconfig_rows(From, To, Gstkid) -> + #gstkid{widget_data=State,id=Id} = Gstkid, + #state{tkcanvas=TkCanvas,cell_pos=CP,cell_id=CI, + canvas=C,db=DB,max_range=Range}=State, + NewRange = + if Range == undefined -> + mkgrid(DB,CP,CI,TkCanvas,Id,From,To), + {From,To}; + true -> + {Top,Bot} = Range, + if + From < Top -> % we need more rects above + mkgrid(DB,CP,CI,TkCanvas,Id,From,Top-1); + true -> true + end, + if + To > Bot -> % we need more rects below + mkgrid(DB,CP,CI,TkCanvas,Id,Bot+1,To); + true -> true + end, + {lists:min([Top, From]), lists:max([Bot, To])} + end, + gstk:config_impl(DB,C,[calc_scrollregion({From,To}, + gstk_db:opt(DB,Id,columnwidths), + gstk_db:opt(DB,Id,cellheight))]), + S2 = State#state{max_range=NewRange}, + Gstkid#gstkid{widget_data=S2}. + +read(DB,Gstkid,Opt) -> + State = Gstkid#gstkid.widget_data, + case lists:member(Opt,[x,y,width,height,hscroll,vscroll]) of + true -> gstk:read_impl(DB,State#state.canvas,Opt); + false -> + gstk_generic:read_option(DB, Gstkid, Opt,State) + end. + +read_option(Option,Gstkid,_TkW,DB,State) -> + case Option of + {obj_at_row,Row} -> + case ets:lookup(State#state.cell_pos,{1,Row}) of + [{_pos,Item}] -> + case Item#item.line_id of + free -> undefined; + GridLine -> + gstk:make_extern_id(GridLine, DB) + end; + _ -> undefined + end; + Opt -> gstk_db:opt(DB,Gstkid#gstkid.id,Opt,undefined) + end. + + +%%---------------------------------------------------------------------- +%% Is always called. +%% Clean-up my specific side-effect stuff. +%%---------------------------------------------------------------------- +delete(DB, Gstkid) -> + gstk_db:delete_widget(DB, Gstkid), + State = Gstkid#gstkid.widget_data, + #state{canvas=C,cell_pos=CP,cell_id=CIs, ids=IDs} = State, + ets:delete(CP), + ets:delete(CIs), + ets:delete(IDs), + {Gstkid#gstkid.parent, Gstkid#gstkid.id, gstk_grid, [C]}. + +%%---------------------------------------------------------------------- +%% Is called iff my parent is not also destroyed. +%%---------------------------------------------------------------------- +destroy(DB, Canvas) -> + gstk:destroy_impl(DB,gstk_db:lookup_gstkid(DB,Canvas)). + +mk_create_opts_for_child(DB,Cgstkid, Pgstkid, Opts) -> + gstk_generic:mk_create_opts_for_child(DB,Cgstkid,Pgstkid,Opts). + +mkgrid(DB,CellPos,CellIds,TkCanvas,Id,From,To) -> + ColWs = gstk_db:opt(DB,Id,columnwidths), + AscColW = ["[list ",asc_tcl_colw(ColWs),"]"], + Font = gstk_font:choose_ascii(DB,gstk_db:opt(DB,Id,font)), + Fg = gstk:to_color(gstk_db:opt(DB,Id,fg)), + Bg = gstk:to_color(gstk_db:opt(DB,Id,bg)), + Objs = tcl2erl:ret_list(["mkgrid ",TkCanvas," ",AscColW," ", + gstk:to_ascii(From)," ", + gstk:to_ascii(To)," ", + gstk:to_ascii(gstk_db:opt(DB,Id,cellheight))," ", + Font," ",Fg," ",Bg]), + insert_objs(CellPos,CellIds,From,To,1,length(ColWs)+1,Objs). + +insert_objs(_,_,_,_,_,_,[]) -> done; +insert_objs(CP,CI,Row,T,MaxCol,MaxCol,Objs) -> + insert_objs(CP,CI,Row+1,T,1,MaxCol,Objs); +insert_objs(CellPos,CellIds,Row,To,Col,Ncols,[RectId,TextId|Objs]) -> + ets:insert(CellPos,{{Col,Row}, + #item{text_id=TextId,rect_id=RectId,line_id=free}}), + ets:insert(CellIds,{RectId,{Col,Row}}), + ets:insert(CellIds,{TextId,{Col,Row}}), + insert_objs(CellPos,CellIds,Row,To,Col+1,Ncols,Objs). + +asc_tcl_colw([]) -> ""; +asc_tcl_colw([Int|T]) -> [gstk:to_ascii(Int)," "|asc_tcl_colw(T)]. + +%%---------------------------------------------------------------------- +%% Args: Cols list of column sizes (measured in n-chars) +%%---------------------------------------------------------------------- +calc_scrollregion({From, To}, Cols, Height) -> + {scrollregion, {0, ((From-1) * Height) + From, + lists:sum(Cols)+length(Cols)+1, (To * Height)+ To+1}}. + +parse_opts([],OtherOpts,CanvasOpts) -> {OtherOpts,CanvasOpts}; +parse_opts([{Key,Val}|Opts],OtherOpts,CanvasOpts) -> + case lists:member(Key,[x,y,width,height,vscroll,hscroll]) of + true -> parse_opts(Opts,OtherOpts,[{Key,Val}|CanvasOpts]); + false -> parse_opts(Opts,[{Key,Val}|OtherOpts],CanvasOpts) + end; +parse_opts([Opt|Opts],OtherOpts,CanvasOpts) -> + parse_opts(Opts,[Opt|OtherOpts],CanvasOpts). + diff --git a/lib/gs/src/gstk_gridline.erl b/lib/gs/src/gstk_gridline.erl new file mode 100644 index 0000000000..c1dd5a1443 --- /dev/null +++ b/lib/gs/src/gstk_gridline.erl @@ -0,0 +1,298 @@ +%% +%% %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_gridline). + +-export([event/5,create/3,config/3,option/5,read/3,delete/2,destroy/3, + read_option/5]). + +-include("gstk.hrl"). +-record(state,{canvas,ncols,max_range,cell_id, cell_pos,ids,db,tkcanvas}). +-record(item,{text_id,rect_id,line_id}). + +%%----------------------------------------------------------------------------- +%% GRIDLINE OPTIONS +%% +%% text Text +%% row Row +%% data Data +%% fg Color (default is the same as grid fg) +%% click Bool +%% +%%----------------------------------------------------------------------------- + +create(DB, Gstkid, Options) -> + Pgstkid = gstk_db:lookup_gstkid(DB,Gstkid#gstkid.parent), + Id = Gstkid#gstkid.id, + #gstkid{widget_data=State} = Pgstkid, + #state{cell_pos=CP,tkcanvas=TkW,ncols=Ncols} = State, + Row = gs:val(row,Options), + case check_row(CP,Row) of + {error,Reason} -> {error,Reason}; + ok -> + Ngstkid = Gstkid#gstkid{widget=TkW}, + gstk_db:insert_opts(DB,Id,[{data,[]},{row,Row}]), + update_cp_db(Ncols,Row,Id,CP), + config_line(DB,Pgstkid,Ngstkid,Row,Options), + Ngstkid + end. + +%%---------------------------------------------------------------------- +%% Returns: ok|false +%%---------------------------------------------------------------------- +check_row(_CellPos,undefined) -> + {error,{gridline,{row,undefined}}}; +check_row(CellPos,Row) -> + case ets:lookup(CellPos,{1,Row}) of + [] -> + {error,{gridline,row_outside_range,Row}}; + [{_,Item}] -> + case Item#item.line_id of + free -> ok; + _ -> + {error,{gridline,row_is_occupied,Row}} + end + end. + +%%---------------------------------------------------------------------- +%% s => text item +%% p => rect item +%%---------------------------------------------------------------------- +option(Option, _Gstkid, _TkW, DB,_) -> + case Option of + {{bg,_Item}, Color} -> {p,[" -f ", gstk:to_color(Color)]}; + {{text,_Item},Text} -> {s, [" -te ", gstk:to_ascii(Text)]}; + {{fg,_Item},Color} -> {sp,{[" -fi ", gstk:to_color(Color)], + [" -outline ", gstk:to_color(Color)]}}; + {{font,_Item},Font} -> {s,[" -font ",gstk_font:choose_ascii(DB,Font)]}; + _ -> invalid_option + end. + +%%---------------------------------------------------------------------- +%% Is always called. +%% Clean-up my specific side-effect stuff. +%%---------------------------------------------------------------------- +delete(DB, Gstkid) -> + Row = gstk_db:opt(DB,Gstkid,row), + gstk_db:delete_widget(DB, Gstkid), + {Gstkid#gstkid.parent, Gstkid#gstkid.id, gstk_gridline,[Gstkid, Row]}. + +%%---------------------------------------------------------------------- +%% Is called iff my parent is not also destroyed. +%%---------------------------------------------------------------------- +destroy(DB, Lgstkid, Row) -> + Ggstkid = gstk_db:lookup_gstkid(DB,Lgstkid#gstkid.parent), + #gstkid{widget_data=State} = Ggstkid, + config_line(DB,Ggstkid,Lgstkid,Row, + [{bg,gstk_db:opt(DB,Ggstkid,bg)}, + {fg,gstk_db:opt(DB,Ggstkid,fg)},{text,""}]), + Ncols = State#state.ncols, + update_cp_db(Ncols,Row,free,State#state.cell_pos). + + +config(DB, Gstkid, Opts) -> + Pgstkid = gstk_db:lookup_gstkid(DB,Gstkid#gstkid.parent), + case {gs:val(row,Opts,missing),gstk_db:opt(DB,Gstkid,row)} of + {Row,Row} -> % stay here... + config_line(DB,Pgstkid,Gstkid,Row,Opts); + {missing,Row} -> % stay here... + config_line(DB,Pgstkid,Gstkid,Row,Opts); + {NewRow,OldRow} -> + config_line(DB,Pgstkid,Gstkid,OldRow,Opts), + Ngstkid = gstk_db:lookup_gstkid(DB,Gstkid#gstkid.id), + case move_line(NewRow,OldRow,DB,Pgstkid#gstkid.widget_data,Ngstkid) of + true -> + gstk_db:insert_opt(DB,Ngstkid,{row,NewRow}), + ok; + {error,_Reason} -> ok + end + end, + ok. + +%%---------------------------------------------------------------------- +%% Returns: true|false depending on if operation succeeded +%%---------------------------------------------------------------------- +move_line(NewRow,OldRow,_DB,State,_Ngstkid) -> + case ets:lookup(State#state.cell_pos,{1,NewRow}) of + [] -> + {error,{gridline,row_outside_grid,NewRow}}; + [{_,#item{line_id=Lid}}] when Lid =/= free-> + {error,{gridline,new_row_occupied,NewRow}}; + [{_,_NewItem}] -> + #state{tkcanvas=TkW,ncols=Ncols,cell_pos=CP} = State, + swap_lines(TkW,OldRow,NewRow,1,Ncols,CP), + true + end. + +%%---------------------------------------------------------------------- +%% Purpose: swaps an empty newrow with a (oldrow) gridline +%%---------------------------------------------------------------------- +swap_lines(TkW,OldRow,NewRow,Col,MaxCol,CellPos) when Col =< MaxCol -> + [{_,NewItem}] = ets:lookup(CellPos,{Col,NewRow}), + [{_,OldItem}] = ets:lookup(CellPos,{Col,OldRow}), + swap_cells(TkW,NewItem,OldItem), + ets:insert(CellPos,{{Col,NewRow},OldItem}), + ets:insert(CellPos,{{Col,OldRow},NewItem}), + swap_lines(TkW,OldRow,NewRow,Col+1,MaxCol,CellPos); +swap_lines(_,_,_,_,_,_) -> done. + +swap_cells(TkW,#item{rect_id=NewRectId,text_id=NewTextId}, + #item{rect_id=OldRectId,text_id=OldTextId}) -> + Aorid = gstk:to_ascii(OldRectId), + Aotid = gstk:to_ascii(OldTextId), + Anrid = gstk:to_ascii(NewRectId), + Antid = gstk:to_ascii(NewTextId), + Pre = [TkW," coords "], + OldRectCoords = tcl2erl:ret_str([Pre,Aorid]), + OldTextCoords = tcl2erl:ret_str([Pre,Aotid]), + NewRectCoords = tcl2erl:ret_str([Pre,Anrid]), + NewTextCoords = tcl2erl:ret_str([Pre,Antid]), + gstk:exec([Pre,Aotid," ",NewTextCoords]), + gstk:exec([Pre,Antid," ",OldTextCoords]), + gstk:exec([Pre,Aorid," ",NewRectCoords]), + gstk:exec([Pre,Anrid," ",OldRectCoords]). + +%%---------------------------------------------------------------------- +%% Pre: {row,Row} option is taken care of. +%%---------------------------------------------------------------------- +config_line(DB,Pgstkid,Lgstkid,Row,Opts) -> + #gstkid{widget_data=State, widget=TkW} = Pgstkid, + #state{cell_pos=CP,ncols=Ncols} = State, + Ropts = transform_opts(Opts,Ncols), + RestOpts = config_gridline(DB,CP,Lgstkid,Ncols,Row,Ropts), + gstk_generic:mk_cmd_and_exec(RestOpts,Lgstkid,TkW,"","",DB). + +%%---------------------------------------------------------------------- +%% Returns: non-processed options +%%---------------------------------------------------------------------- +config_gridline(_DB,_CP,_Gstkid,0,_Row,Opts) -> + Opts; +config_gridline(DB,CP,Gstkid,Col,Row,Opts) -> + {ColOpts,OtherOpts} = opts_for_col(Col,Opts,[],[]), + if + ColOpts==[] -> done; + true -> + [{_pos,Item}] = ets:lookup(CP,{Col,Row}), + TkW = Gstkid#gstkid.widget, + TextPre = [TkW," itemconf ",gstk:to_ascii(Item#item.text_id)], + RectPre = [$;,TkW," itemconf ",gstk:to_ascii(Item#item.rect_id)], + case gstk_generic:make_command(ColOpts,Gstkid,TkW, + TextPre,RectPre,DB) of + [] -> ok; + {error,_Reason} -> ok; + Cmd -> gstk:exec(Cmd) + end + end, + config_gridline(DB,CP,Gstkid,Col-1,Row,OtherOpts). + +opts_for_col(Col,[{{Key,Col},Val}|Opts],ColOpts,RestOpts) -> + opts_for_col(Col,Opts,[{{Key,Col},Val}|ColOpts],RestOpts); +opts_for_col(Col,[Opt|Opts],ColOpts,RestOpts) -> + opts_for_col(Col,Opts,ColOpts,[Opt|RestOpts]); +opts_for_col(_Col,[],ColOpts,RestOpts) -> {ColOpts,RestOpts}. + +%%---------------------------------------------------------------------- +%% {Key,{Col,Val}} becomes {{Key,Col},Val} +%% {Key,Val} becomes {{Key,1},Val}...{{Key,Ncol},Val} +%%---------------------------------------------------------------------- +transform_opts([], _Ncols) -> []; +transform_opts([{{Key,Col},Val} | Opts],Ncols) -> + [{{Key,Col},Val}|transform_opts(Opts,Ncols)]; +transform_opts([{Key,{Col,Val}}|Opts],Ncols) when is_integer(Col) -> + [{{Key,Col},Val}|transform_opts(Opts,Ncols)]; +transform_opts([{Key,Val}|Opts],Ncols) -> + case lists:member(Key,[fg,bg,text,font]) of + true -> + lists:append(expand_to_all_cols(Key,Val,Ncols), + transform_opts(Opts,Ncols)); + false -> + case lists:member(Key,[click,doubleclick,row]) of + true -> + [{keep_opt,{Key,Val}}|transform_opts(Opts,Ncols)]; + false -> + [{Key,Val}|transform_opts(Opts,Ncols)] + end + end; +transform_opts([Opt|Opts],Ncols) -> + [Opt|transform_opts(Opts,Ncols)]. + +expand_to_all_cols(Key,Val,1) -> + [{{Key,1},Val}]; +expand_to_all_cols(Key,Val,Col) -> + [{{Key,Col},Val}|expand_to_all_cols(Key,Val,Col-1)]. + + +read(DB, Gstkid, Opt) -> + Pgstkid = gstk_db:lookup_gstkid(DB,Gstkid#gstkid.parent), + gstk_generic:read_option(DB, Gstkid, Opt,Pgstkid). + +read_option({font,Column},Gstkid, _TkW,DB,Pgstkid) -> + case gstk_db:opt_or_not(DB,Gstkid,{font,Column}) of + false -> gstk_db:opt(DB,Pgstkid,font); + {value,V} -> V + end; +read_option({Opt,Column},Gstkid, TkW,DB,#gstkid{widget_data=State}) -> + Row = gstk_db:opt(DB,Gstkid,row), + [{_pos,Item}] = ets:lookup(State#state.cell_pos,{Column,Row}), + Rid = gstk:to_ascii(Item#item.rect_id), + Tid = gstk:to_ascii(Item#item.text_id), + Pre = [TkW," itemcg "], + case Opt of + bg -> tcl2erl:ret_color([Pre,Rid," -f"]); + fg -> tcl2erl:ret_color([Pre,Tid," -fi"]); + text -> tcl2erl:ret_str([Pre,Tid," -te"]); + _ -> {bad_result, {Gstkid#gstkid.objtype, invalid_option, {Opt,Column}}} + end; +read_option(Option,Gstkid,TkW,DB,Pgstkid) -> + case lists:member(Option,[bg,fg,text]) of + true -> read_option({Option,1},Gstkid,TkW,DB,Pgstkid); + false -> gstk_db:opt(DB,Gstkid,Option,undefined) + end. + +update_cp_db(0,_Row,_,_) -> ok; +update_cp_db(Col,Row,ID,CP) -> + [{_,Item}] = ets:lookup(CP,{Col,Row}), + ets:insert(CP,{{Col,Row},Item#item{line_id = ID}}), + update_cp_db(Col-1,Row,ID,CP). + + +event(DB, GridGstkid, Etype, _Edata, [CanItem]) -> + State = GridGstkid#gstkid.widget_data, + #state{cell_pos=CP,cell_id=CIs,tkcanvas=TkW} = State, + case ets:lookup(CIs,CanItem) of + [{_id,{Col,Row}}] -> + [{_pos,Item}] = ets:lookup(CP,{Col,Row}), + case Item#item.line_id of + free -> ok; + Id -> + Lgstkid = gstk_db:lookup_gstkid(DB,Id), + case gstk_db:opt_or_not(DB,Lgstkid,Etype) of + {value,true} -> + Txt = read_option({text,Col},Lgstkid,TkW, + DB,GridGstkid), + gstk_generic:event(DB,Lgstkid,Etype,dummy, + [Col,Row,Txt]); + _ -> ok + end + end; + _ -> ok + end; +event(_DB, _Gstkid, _Etype, _Edata, _Args) -> + ok. diff --git a/lib/gs/src/gstk_gs.erl b/lib/gs/src/gstk_gs.erl new file mode 100644 index 0000000000..eac894759e --- /dev/null +++ b/lib/gs/src/gstk_gs.erl @@ -0,0 +1,53 @@ +%% +%% %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% +%% + +%% +%%% Purpose : The GS object + +-module(gstk_gs). + +-export([mk_create_opts_for_child/4, + config/3, + read/3, + read_option/5, + option/5]). + +-include("gstk.hrl"). + +%%---------------------------------------------------------------------- +%% The GS object implementation +%%---------------------------------------------------------------------- + +mk_create_opts_for_child(DB,Cgstkid, Pgstkid, Opts) -> + gstk_generic:mk_create_opts_for_child(DB,Cgstkid,Pgstkid,Opts). + +config(DB, Gstkid, Opts) -> + Cmd=gstk_generic:make_command(Opts,Gstkid,"",DB), + gstk:exec(Cmd), + ok. + +read(DB, Gstkid, Opt) -> + gstk_generic:read_option(DB, Gstkid, Opt). + +% No options of my own +read_option(Option,Gstkid, _TkW,_DB,_) -> + {bad_result, {Gstkid#gstkid.objtype, invalid_option, Option}}. + +option(_Option, _Gstkid, _TkW, _DB,_) -> + invalid_option. diff --git a/lib/gs/src/gstk_image.erl b/lib/gs/src/gstk_image.erl new file mode 100644 index 0000000000..5ad37cf6de --- /dev/null +++ b/lib/gs/src/gstk_image.erl @@ -0,0 +1,319 @@ +%% +%% %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 Image Type +%% ------------------------------------------------------------ + +-module(gstk_image). + +%%----------------------------------------------------------------------------- +%% BITMAP OPTIONS +%% +%% Attributes: +%% anchor n|w|e|s|nw|sw|ne|se|center +%% bg Color +%% bitmap String +%% coords [{X,Y}] +%% data Data +%% fg Color +%% +%% Attributes for gifs only: +%% pix_val {{X,Y},Color}|{{{X1,Y1},{X2,Y2}},Color] +%% save String +%% refresh +%% +%% Commands: +%% lower +%% move {Dx, Dy} +%% raise +%% scale {Xo, Yo, Sx, Sy} +%% setfocus Bool +%% +%% Events: +%% buttonpress [Bool | {Bool, Data}] +%% buttonrelease [Bool | {Bool, Data}] +%% enter [Bool | {Bool, Data}] +%% keypress [Bool | {Bool, Data}] +%% keyrelease [Bool | {Bool, Data}] +%% leave [Bool | {Bool, Data}] +%% motion [Bool | {Bool, Data}] +%% +%% Read Options: +%% pix_val {X,Y} +%% children +%% id +%% parent +%% type +%% +%% Not Implemented: +%% + +-export([create/3, config/3, read/3, delete/2, destroy/3, event/5, + option/5,read_option/5]). + +-include("gstk.hrl"). + +%%------------------------------------------------------------------------------ +%% MANDATORY INTERFACE FUNCTIONS +%%------------------------------------------------------------------------------ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : create/7 +%% Purpose : Create a widget of the type defined in this module. +%% Args : DB - The Database +%% Objmod - An atom, this module +%% Objtype - An atom, the logical widget type +%% Owner - Pid of the creator +%% Name - An atom naming the widget +%% Parent - Gsid of the parent +%% Opts - A list of options for configuring the widget +%% +%% Return : [Gsid_of_new_widget | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +create(DB, Gstkid, Opts) -> + case pickout_type(Opts) of + bitmap -> + create(bitmap,DB, Gstkid, Opts); + _gif -> %%Default gif + create(gif,DB, Gstkid, Opts) + end. + +create(gif,DB, Gstkid, Opts) -> + case pickout_coords(Opts, []) of + {error, Error} -> + {bad_result, Error}; + {Coords, NewOpts} -> + CCmd = "image create photo", + case tcl2erl:ret_atom(CCmd) of + Photo_item when is_atom(Photo_item) -> + #gstkid{parent=Parent,owner=Owner,id=Id}=Gstkid, + Pgstkid = gstk_db:lookup_gstkid(DB, Parent, Owner), + SO = Pgstkid#gstkid.widget_data, + CanvasTkW = SO#so.object, + Photo_item_s = atom_to_list(Photo_item), + gstk_db:insert_opt(DB,Id,gs:pair(coords,Opts)), + Ngstkid=Gstkid#gstkid{widget=CanvasTkW, + widget_data={Photo_item_s,unknown}}, + gstk_db:update_widget(DB,Ngstkid), + MCmd = [CanvasTkW," create image ",Coords," -image ", + Photo_item_s," -anchor nw"], + case gstk_canvas:make_command(NewOpts, Ngstkid, + CanvasTkW, MCmd, DB) of + {error,Reason} -> {error,Reason}; + Cmd when is_list(Cmd) -> + case tcl2erl:ret_int(Cmd) of + Item when is_integer(Item) -> + %% buu, not nice + G2 = gstk_db:lookup_gstkid(DB,Id), + NewWidget = {Photo_item_s,Item}, + NewGstkid = G2#gstkid{widget_data=NewWidget}, + gstk_db:insert_widget(DB, NewGstkid), + NewGstkid; + Bad_result -> + {error,Bad_result} + end + end; + Bad_result -> + {error,Bad_result} + end + end; + +create(bitmap,DB, Gstkid, Opts) -> + case pickout_coords(Opts, []) of + {error, Error} -> + {bad_result, Error}; + {Coords, NewOpts} -> + #gstkid{parent=Parent,owner=Owner,id=Id}=Gstkid, + Pgstkid = gstk_db:lookup_gstkid(DB, Parent, Owner), + SO = Pgstkid#gstkid.widget_data, + CanvasTkW = SO#so.object, + gstk_db:insert_opt(DB,Id,gs:pair(coords,Opts)), + Ngstkid=Gstkid#gstkid{widget=CanvasTkW, widget_data=no_item}, + gstk_db:update_widget(DB,Ngstkid), + MCmd = [CanvasTkW," create bi ", Coords], + gstk_canvas:mk_cmd_and_call(NewOpts,Ngstkid, CanvasTkW, MCmd,DB) + end. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : config/3 +%% Purpose : Configure a widget of the type defined in this module. +%% Args : DB - The Database +%% Gstkid - The gstkid of the widget +%% Opts - A list of options for configuring the widget +%% +%% Return : [true | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +config(DB, Gstkid, Opts) -> + {Canvas, Item} = get_widget(Gstkid), + AItem = gstk:to_ascii(Item), + SCmd = [Canvas, " itemconf ", AItem], + gstk_canvas:mk_cmd_and_exec(Opts, Gstkid, Canvas, AItem, SCmd, DB). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : read/3 +%% Purpose : Read one option from a widget +%% Args : DB - The Database +%% Gstkid - The gstkid of the widget +%% Opt - An option to read +%% +%% Return : [OptionValue | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +read(DB, Gstkid, Opt) -> + {_, Item} = get_widget(Gstkid), + gstk_generic:read_option(DB,Gstkid,Opt,[gstk:to_ascii(Item)]). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : delete/2 +%% Purpose : Delete widget from databas and return tkwidget to destroy +%% Args : DB - The Database +%% Gstkid - The gstkid of the widget +%% +%% Return : TkWidget to destroy | {Parent, Objmod, Args}. +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +delete(DB, Gstkid) -> + gstk_db:delete_widget(DB, Gstkid), + #gstkid{parent=P,id=ID}=Gstkid, + {Canvas, Item} = get_widget(Gstkid), + {P, ID, gstk_image, [Canvas, Item]}. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : destroy/3 +%% Purpose : Destroy a widget +%% Args : DB - The Database +%% Canvas - The canvas tk widget +%% Item - The item number to destroy +%% +%% Return : [true | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +destroy(_DB, Canvas, Item) -> + gstk:exec([Canvas, " delete ", gstk:to_ascii(Item)]). + + +event(DB, Gstkid, Etype, Edata, Args) -> + gstk_generic:event(DB, Gstkid, Etype, Edata, Args). + +%%------------------------------------------------------------------------------ +%% MANDATORY FUNCTIONS +%%------------------------------------------------------------------------------ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : option/5 +%% Purpose : Take care of options +%% Args : Option - An option tuple +%% Gstkid - The gstkid of the widget +%% MainW - The main tk-widget +%% Canvas - The canvas tk-widget +%% DB - The Database +%% +%% Return : A tuple {OptionType, OptionCmd} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +option(Option, Gstkid, _Canvas, _DB, _AItem) -> + case Option of + {bitmap, Bitmap} -> + {ok, BF,_} = regexp:gsub(Bitmap, [92,92], "/"), + {s, [" -bi @", BF]}; + {load_gif, File} -> + {ok, F2,_} = regexp:gsub(File, [92,92], "/"), + {Photo_item, _item} = Gstkid#gstkid.widget_data, + {c,[Photo_item, " configure -file ", gstk:to_ascii(F2)]}; + {pix_val, {Coords,Color}} -> + {Photo_item, _item} = Gstkid#gstkid.widget_data, + {c, [Photo_item, " put ", gstk:to_color(Color), " -to ", + coords(Coords)]}; + {save_gif, Name} -> + {Photo_item, _item} = Gstkid#gstkid.widget_data, + {c, [Photo_item, " write ", gstk:to_ascii(Name)]}; + {fg, Color} -> {s, [" -fo ", gstk:to_color(Color)]}; + {bg, Color} -> {s, [" -ba ", gstk:to_color(Color)]}; + {anchor, How} -> {s, [" -anchor ", gstk:to_ascii(How)]}; + _ -> invalid_option + end. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : read_option/5 +%% Return : The value of the option or invalid_option +%% [OptionValue | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +read_option(Option, Gstkid, Canvas, _DB, AItem) -> + case Option of + anchor -> tcl2erl:ret_atom([Canvas," itemcget ",AItem," -anchor"]); + bg -> tcl2erl:ret_color([Canvas, " itemcget ", AItem, " -ba"]); + bitmap -> tcl2erl:ret_file([Canvas, " itemcget ", AItem, " -bi"]); + fg -> tcl2erl:ret_color([Canvas, " itemcget ", AItem, " -fo"]); + {pix_val,{X,Y}} -> + {Photo_item, _item} = Gstkid#gstkid.widget_data, + ret_photo_color([Photo_item," get ",coords({X,Y})]); + _ -> {bad_result, {Gstkid#gstkid.objtype, invalid_option, Option}} + end. + +ret_photo_color(Cmd) -> + case gstk:call(Cmd) of + {result,Str} -> + {ok, [R,G,B],[]} = io_lib:fread("~d ~d ~d", Str), + {R,G,B}; + Bad_result -> Bad_result + end. + + +%%------------------------------------------------------------------------------ +%% PRIMITIVES +%%------------------------------------------------------------------------------ +get_widget(#gstkid{widget=Canvas,widget_data={_Photo_item,Item}}) -> + {Canvas,Item}; +get_widget(#gstkid{widget=Canvas,widget_data=Item}) -> + {Canvas,Item}. + +pickout_coords([{coords,Coords} | Rest], Opts) when length(Coords) == 1 -> + case coords(Coords) of + invalid -> + {error, "An image must have two coordinates"}; + RealCoords -> + {RealCoords, lists:append(Rest, Opts)} + end; +pickout_coords([Opt | Rest], Opts) -> + pickout_coords(Rest, [Opt|Opts]); +pickout_coords([], _Opts) -> + {error, "An image must have two coordinates"}. + +coords({X,Y}) when is_number(X),is_number(Y) -> + [gstk:to_ascii(X), " ", gstk:to_ascii(Y), " "]; +coords([{X,Y} | R]) when is_number(X),is_number(Y) -> + [gstk:to_ascii(X), " ", gstk:to_ascii(Y), " ", coords(R)]; +coords({{X1,Y1},{X2,Y2}}) when is_number(X1),is_number(Y1),is_number(X2),is_number(Y2) -> + [gstk:to_ascii(X1), " ", gstk:to_ascii(Y1)," ", + gstk:to_ascii(X2), " ", gstk:to_ascii(Y2)]; +coords([_]) -> %% not a pair + invalid; +coords([]) -> + []. + + +pickout_type([{bitmap,_Str}|_Options]) -> + bitmap; +pickout_type([{gif,_Str}|_Options]) -> + gif; +pickout_type([]) -> + none; +pickout_type([_|Tail]) -> + pickout_type(Tail). + +%% ----- Done ----- + diff --git a/lib/gs/src/gstk_label.erl b/lib/gs/src/gstk_label.erl new file mode 100644 index 0000000000..c5d111d51a --- /dev/null +++ b/lib/gs/src/gstk_label.erl @@ -0,0 +1,182 @@ +%% +%% %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 Label Type +%% ------------------------------------------------------------ + +-module(gstk_label). +%%------------------------------------------------------------------------------ +%% LABEL OPTIONS +%% +%% Attributes: +%% align n,w,s,e,nw,se,ne,sw,center +%% anchor n,w,s,e,nw,se,ne,sw,center +%% bg Color +%% bw Int +%% data Data +%% fg Color +%% font Font +%% height Int +%% highlightbg Color +%% highlightbw Int +%% highlightfg Color +%% justify left|right|center +%% label {text, String} | {image, BitmapFile} +%% padx Int (Pixels) +%% pady Int (Pixels) +%% relief Relief [flat|raised|sunken|ridge|groove] +%% underline Int +%% width Int +%% wraplength Int +%% x Int +%% y Int +%% +%% Commands: +%% setfocus Bool +%% +%% Events: +%% buttonpress [Bool | {Bool, Data}] +%% buttonrelease [Bool | {Bool, Data}] +%% configure [Bool | {Bool, Data}] +%% destroy [Bool | {Bool, Data}] +%% enter [Bool | {Bool, Data}] +%% focus [Bool | {Bool, Data}] +%% keypress [Bool | {Bool, Data}] +%% keyrelease [Bool | {Bool, Data}] +%% leave [Bool | {Bool, Data}] +%% motion [Bool | {Bool, Data}] +%% +%% Read Options: +%% children +%% id +%% parent +%% type +%% +%% Not Implemented: +%% cursor ?????? +%% focus ?????? (-takefocus) +%% + +-export([create/3,config/3,read/3,delete/2,event/5,option/5,read_option/5]). + +-include("gstk.hrl"). + +%%----------------------------------------------------------------------------- +%% MANDATORY INTERFACE FUNCTIONS +%%----------------------------------------------------------------------------- +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : create/3 +%% Purpose : Create a widget of the type defined in this module. +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +create(DB, GstkId, Opts) -> + TkW = gstk_generic:mk_tkw_child(DB,GstkId), + PlacePreCmd = [";place ", TkW], + Ngstkid = GstkId#gstkid{widget=TkW}, + case gstk_generic:make_command(Opts,Ngstkid,TkW,"",PlacePreCmd,DB) of + {error,Reason} -> {error,Reason}; + Cmd when is_list(Cmd) -> + gstk:exec(["label ", TkW,Cmd]), + Ngstkid + end. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : config/3 +%% Purpose : Configure a widget of the type defined in this module. +%% Args : DB - The Database +%% Gstkid - The gstkid of the widget +%% Opts - A list of options for configuring the widget +%% +%% Return : [true | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +config(DB, Gstkid, Opts) -> + TkW = Gstkid#gstkid.widget, + SimplePreCmd = [TkW, " conf"], + PlacePreCmd = [";place ", TkW], + gstk_generic:mk_cmd_and_exec(Opts,Gstkid,TkW,SimplePreCmd,PlacePreCmd,DB). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : read/3 +%% Purpose : Read one option from a widget +%% Args : DB - The Database +%% Gstkid - The gstkid of the widget +%% Opt - An option to read +%% +%% Return : [OptionValue | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +read(DB, Gstkid, Opt) -> + gstk_generic:read_option(DB, Gstkid, Opt). + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : delete/2 +%% Purpose : Delete widget from databas and return tkwidget to destroy +%% Args : DB - The Database +%% Gstkid - The gstkid of the widget +%% +%% Return : TkWidget to destroy +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +delete(DB, Gstkid) -> + gstk_db:delete_widget(DB, Gstkid), + Gstkid#gstkid.widget. + +event(DB, Gstkid, Etype, Edata, Args) -> + gstk_generic:event(DB, Gstkid, Etype, Edata, Args). + + +%%----------------------------------------------------------------------------- +%% MANDATORY FUNCTIONS +%%----------------------------------------------------------------------------- +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : option/4 +%% Purpose : Take care of options +%% Args : Option - An option tuple +%% Gstkid - The gstkid of the widget +%% TkW - The tk-widget +%% DB - The Database +%% +%% Return : A tuple {OptionType, OptionCmd} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +option(Option, _Gstkid, _TkW, _DB,_) -> + case Option of + {underline, Int} -> {s, [" -und ", gstk:to_ascii(Int)]}; + {wraplength, Int} -> {s, [" -wra ", gstk:to_ascii(Int)]}; + _ -> invalid_option + end. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : read_option/4 +%% Purpose : Take care of a read option +%% Args : DB - The Database +%% Gstkid - The gstkid of the widget +%% Option - An option +%% +%% Return : The value of the option or invalid_option +%% [OptionValue | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +read_option(Option,Gstkid,TkW,_DB,_) -> + case Option of + underline -> tcl2erl:ret_int([TkW," cg -und"]); + wraplength -> tcl2erl:ret_int([TkW," cg -wra"]); + _ -> {bad_result, {Gstkid#gstkid.objtype, invalid_option, Option}} + end. + +%%% ----- Done ----- + diff --git a/lib/gs/src/gstk_line.erl b/lib/gs/src/gstk_line.erl new file mode 100644 index 0000000000..19f36f7636 --- /dev/null +++ b/lib/gs/src/gstk_line.erl @@ -0,0 +1,202 @@ +%% +%% %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 Line Type +%% ------------------------------------------------------------ + +-module(gstk_line). + + +%%----------------------------------------------------------------------------- +%% LINE OPTIONS +%% +%% Attributes: +%% arrow none | first | last | both +%% capstyle butt | projecting | round +%% coords [{X1,Y1}, {X2,Y2} | {Xn,Yn}] +%% data Data +%% fg Color +%% joinstyle miter | bevel | round +%% smooth Bool +%% splinesteps Int +%% stipple Bool +%% width Wth +%% +%% Commands: +%% lower +%% move {Dx, Dy} +%% raise +%% scale {Xo, Yo, Sx, Sy} +%% setfocus Bool +%% +%% Events: +%% buttonpress [Bool | {Bool, Data}] +%% buttonrelease [Bool | {Bool, Data}] +%% enter [Bool | {Bool, Data}] +%% keypress [Bool | {Bool, Data}] +%% keyrelease [Bool | {Bool, Data}] +%% leave [Bool | {Bool, Data}] +%% motion [Bool | {Bool, Data}] +%% +%% Read Options: +%% children +%% id +%% parent +%% type +%% +%% Not Implemented: +%% + +-export([create/3, config/3, read/3, delete/2, destroy/3, event/5, + option/5,read_option/5]). + +-include("gstk.hrl"). + +%%----------------------------------------------------------------------------- +%% MANDATORY INTERFACE FUNCTIONS +%%----------------------------------------------------------------------------- +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : create/3 +%% Purpose : Create a widget of the type defined in this module. +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +create(DB, Gstkid, Opts) -> + case pickout_coords(Opts, []) of + {error, Error} -> + {bad_result, Error}; + {Coords, NewOpts} -> + Ngstkid=gstk_canvas:upd_gstkid(DB, Gstkid, Opts), + #gstkid{widget=CanvasTkW}=Ngstkid, + MCmd = [CanvasTkW, " create li ", Coords], + gstk_canvas:mk_cmd_and_call(NewOpts,Ngstkid, CanvasTkW, MCmd, DB) + end. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : config/3 +%% Purpose : Configure a widget of the type defined in this module. +%% Return : [true | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +config(DB, Gstkid, Opts) -> + gstk_canvas:item_config(DB, Gstkid, Opts). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : read/3 +%% Purpose : Read one option from a widget +%% Args : DB - The Database +%% Gstkid - The gstkid of the widget +%% Opt - An option to read +%% +%% Return : [OptionValue | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +read(DB, Gstkid, Opt) -> + Item = Gstkid#gstkid.widget_data, + gstk_generic:read_option(DB,Gstkid,Opt,[gstk:to_ascii(Item)]). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : delete/2 +%% Purpose : Delete widget from databas and return tkwidget to destroy +%% Args : DB - The Database +%% Gstkid - The gstkid of the widget +%% +%% Return : TkWidget to destroy | {Parent, Objmod, Args}. +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +delete(DB, Gstkid) -> + gstk_canvas:item_delete_impl(DB,Gstkid). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : destroy/3 +%% Purpose : Destroy a widget +%% Args : DB - The Database +%% Canvas - The canvas tk widget +%% Item - The item number to destroy +%% +%% Return : [true | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +destroy(_DB, Canvas, Item) -> + gstk:exec([Canvas, " delete ", gstk:to_ascii(Item)]). + + +event(DB, Gstkid, Etype, Edata, Args) -> + gstk_generic:event(DB, Gstkid, Etype, Edata, Args). + +%%----------------------------------------------------------------------------- +%% MANDATORY FUNCTIONS +%%----------------------------------------------------------------------------- +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : option/5 +%% Purpose : Take care of options +%% Args : Option - An option tuple +%% Gstkid - The gstkid of the widget +%% MainW - The main tk-widget +%% Canvas - The canvas tk-widget +%% DB - The Database +%% +%% Return : A tuple {OptionType, OptionCmd} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +option(Option, _Gstkid, _Canvas, _DB, _AItem) -> + case Option of + {arrow, Where} -> {s, [" -arrow ", gstk:to_ascii(Where)]}; + {capstyle, Style} -> {s, [" -ca ", gstk:to_ascii(Style)]}; + {fg, Color} -> {s, [" -f ", gstk:to_color(Color)]}; + {joinstyle, Style} -> {s, [" -jo ", gstk:to_ascii(Style)]}; + {smooth, Bool} -> {s, [" -sm ", gstk:to_ascii(Bool)]}; + {splinesteps, Int} -> {s, [" -sp ", gstk:to_ascii(Int)]}; + {width, Int} -> {s, [" -w ", gstk:to_ascii(Int)]}; + + _ -> invalid_option + end. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : read_option/5 +%% Purpose : Take care of a read option +%% Args : DB - The Database +%% Return : The value of the option or invalid_option +%% [OptionValue | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +read_option(Option, Gstkid, Canvas, _DB, AItem) -> + case Option of + arrow -> tcl2erl:ret_atom([Canvas, " itemcg ",AItem, " -arrow"]); + capstyle -> tcl2erl:ret_atom([Canvas, " itemcg ", AItem, " -ca"]); + fg -> tcl2erl:ret_color([Canvas, " itemcg ", AItem, " -f"]); + joinstyle -> tcl2erl:ret_atom([Canvas, " itemcg ", AItem, " -jo"]); + smooth -> tcl2erl:ret_bool([Canvas, " itemcg ", AItem, " -sm"]); + splinesteps -> tcl2erl:ret_int([Canvas, " itemcg ", AItem, " -sp"]); + stipple -> + tcl2erl:ret_stipple([Canvas," itemcg ",AItem," -stipple"]); + width -> tcl2erl:ret_int([Canvas, " itemcg ", AItem, " -w"]); + _ -> {bad_result, {Gstkid#gstkid.objtype, invalid_option, Option}} + end. + +pickout_coords([{coords,Coords} | Rest], Opts) when length(Coords) >= 2 -> + case gstk_canvas:coords(Coords) of + invalid -> + {error, "A line must have at least four coordinates"}; + RealCoords -> + {RealCoords, lists:append(Rest, Opts)} + end; +pickout_coords([Opt | Rest], Opts) -> + pickout_coords(Rest, [Opt|Opts]); +pickout_coords([], _Opts) -> + {error, "A line must have at least four coordinates"}. + +%% ----- Done ----- + diff --git a/lib/gs/src/gstk_listbox.erl b/lib/gs/src/gstk_listbox.erl new file mode 100644 index 0000000000..4b5dd76b24 --- /dev/null +++ b/lib/gs/src/gstk_listbox.erl @@ -0,0 +1,323 @@ +%% +%% %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 Listbox Type +%% ------------------------------------------------------------ + +-module(gstk_listbox). + +%%----------------------------------------------------------------------------- +%% LISTBOX OPTIONS +%% +%% Attributes: +%% activebg Color +%% anchor n,w,s,e,nw,se,ne,sw,center +%% bc Color +%% bg Color +%% bw Wth +%% data Data +%% fg Color +%% height Int +%% highlightbg Color +%% highlightbw Wth +%% highlightfg Color +%% hscroll Bool | top | bottom +%% items [String, String, ... String] +%% relief Relief +%% scrollbg Color +%% scrollfg Color +%% selectbg Color +%% selectbw Width +%% selectfg Color +%% selection Index | clear +%% selectmode single|browse|multiple|extended +%% vscroll Bool | left | right +%% width Int +%% x Int +%% xselection Bool (Good name?????) +%% y Int +%% +%% Commands: +%% add {Index, String} | String +%% change {Index, String} +%% clear +%% del Index | {FromIdx, ToIdx} +%% get Index +%% see Index +%% selection => [Idx1,Idx2,Idx3...] +%% setfocus Bool +%% size Int +%% +%% Events: +%% buttonpress [Bool | {Bool, Data}] +%% buttonrelease [Bool | {Bool, Data}] +%% click [Bool | {Bool, Data}] +%% configure [Bool | {Bool, Data}] +%% destroy [Bool | {Bool, Data}] +%% doubleclick [Bool | {Bool, Data}] +%% enter [Bool | {Bool, Data}] +%% focus [Bool | {Bool, Data}] +%% keypress [Bool | {Bool, Data}] +%% keyrelease [Bool | {Bool, Data}] +%% leave [Bool | {Bool, Data}] +%% motion [Bool | {Bool, Data}] +%% +%% Read Options: +%% children +%% id +%% parent +%% type +%% + +-export([create/3,config/3,read/3,delete/2,event/5,wid_event/5,option/5, + read_option/5]). + +-include("gstk.hrl"). + +%%----------------------------------------------------------------------------- +%% MANDATORY INTERFACE FUNCTIONS +%%----------------------------------------------------------------------------- +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : create/7 +%% Purpose : Create a widget of the type defined in this module. +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +create(DB, GstkId, Opts) -> + MainW = gstk_generic:mk_tkw_child(DB,GstkId), + Listbox = lists:append(MainW,".z"), + {Vscroll, Hscroll, NewOpts} = gstk_generic:parse_scrolls(Opts), + WidgetD = #so{main=MainW, object=Listbox, + hscroll=Hscroll, vscroll=Vscroll}, + Gstkid=GstkId#gstkid{widget=MainW, widget_data=WidgetD}, + MandatoryCmd = ["so_create listbox ", MainW], + case gstk:call(MandatoryCmd) of + {result, _} -> + SimplePreCmd = [MainW, " conf"], + PlacePreCmd = [";place ", MainW], + case gstk_generic:make_command(NewOpts, Gstkid, MainW,SimplePreCmd, + PlacePreCmd, DB,Listbox) of + {error,Reason} -> {error,Reason}; + Cmd when is_list(Cmd) -> + gstk:exec(Cmd), + gstk:exec([MainW,".sy conf -rel sunken -bo 2;", + MainW,".pad.sx conf -rel sunken -bo 2;",Listbox, + " conf -bo 2 -relief sunken -highlightth 2 -expo 0;"]), + Gstkid + end; + Bad_Result -> + {error, Bad_Result} + end. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : config/3 +%% Purpose : Configure a widget of the type defined in this module. +%% Args : DB - The Database +%% Gstkid - The gstkid of the widget +%% Opts - A list of options for configuring the widget +%% +%% Return : [true | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +config(DB, Gstkid, Options) -> + SO = Gstkid#gstkid.widget_data, + MainW = Gstkid#gstkid.widget, + Listbox = SO#so.object, + NewOpts = gstk_generic:parse_scrolls(Gstkid, Options), + SimplePreCmd = [MainW, " conf"], + PlacePreCmd = [";place ", MainW], + gstk_generic:mk_cmd_and_exec(NewOpts, Gstkid, MainW, + SimplePreCmd, PlacePreCmd, DB,Listbox). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : read/3 +%% Purpose : Read one option from a widget +%% Args : DB - The Database +%% Gstkid - The gstkid of the widget +%% Opt - An option to read +%% +%% Return : [OptionValue | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +read(DB, Gstkid, Opt) -> + SO = Gstkid#gstkid.widget_data, + gstk_generic:read_option(DB, Gstkid, Opt,SO#so.object). + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : delete/2 +%% Purpose : Delete widget from databas and return tkwidget to destroy +%% Args : DB - The Database +%% Gstkid - The gstkid of the widget +%% +%% Return : TkWidget to destroy +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +delete(DB, Gstkid) -> + gstk_db:delete_widget(DB, Gstkid), + Gstkid#gstkid.widget. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : event/5 +%% Purpose : Construct the event and send it to the owner of the widget +%% Args : DB - The Database +%% Gstkid - The gstkid of the widget +%% Etype - The event type +%% Edata - The event data +%% Args - The data from tcl/tk +%% +%% Return : [true | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +event(DB, Gstkid, click, Edata, Args) -> + wid_event(DB, Gstkid, click, Edata, Args); +event(DB, Gstkid, doubleclick, Edata, Args) -> + wid_event(DB, Gstkid, doubleclick, Edata, Args); +event(DB, Gstkid, Etype, Edata, Args) -> + gstk_generic:event(DB, Gstkid, Etype, Edata, Args). + + +%% widget specific events +wid_event(DB, Gstkid, Etype, Edata, _Args) -> + SO = Gstkid#gstkid.widget_data, + TkW = SO#so.object, + CurIdx = tcl2erl:ret_int([TkW," index active;"]), + CurTxt = tcl2erl:ret_str([TkW," get active;"]), + CurSel = tcl2erl:ret_list([TkW," curselection;"]), + Arg2 = [CurIdx,CurTxt,lists:member(CurIdx,CurSel)], + gstk_generic:event(DB, Gstkid, Etype, Edata, Arg2). + + +%%----------------------------------------------------------------------------- +%% MANDATORY FUNCTIONS +%%----------------------------------------------------------------------------- +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : option/5 +%% Purpose : Take care of options +%% Args : Option - An option tuple +%% Gstkid - The gstkid of the widget +%% MainW - The main tk-widget +%% Listbox - The listbox tk-widget +%% DB - The Database +%% +%% Return : A tuple {OptionType, OptionCmd} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +option(Option, Gstkid, MainW,DB, Listbox) -> + case Option of + {items, Items} when is_list(Items) -> + {c, [Listbox," del 0 end ;", Listbox," ins 0 ",item_list(Items)]}; + {selection, {From, To}} when is_integer(From),is_integer(To) -> + {c,[Listbox," sel set ",gstk:to_ascii(From)," " ,gstk:to_ascii(To)]}; + {font, Font} when is_tuple(Font) -> + gstk_db:insert_opt(DB,Gstkid,Option), + {c, [Listbox," conf -font ",gstk_font:choose_ascii(DB,Font)]}; + {selection, clear} -> + {c, [Listbox," sel clear 0 end"]}; + {selection, Idx} when is_integer(Idx) -> + {c, [Listbox, " select set ", gstk:to_ascii(Idx)]}; + {selectmode, Mode} -> + {c, [Listbox, " conf -selectm ", gstk:to_ascii(Mode)]}; + {xselection, Bool} -> + {c, [Listbox, " conf -exportse ", gstk:to_ascii(Bool)]}; + {fg, Color} -> + {c, [Listbox, " conf -fg ", gstk:to_color(Color)]}; + + {del, {From, To}} -> + {c, [Listbox, " del ", integer_to_list(From), " ", + integer_to_list(To)]}; + {del, Idx} -> + {c, [Listbox, " del ", integer_to_list(Idx)]}; + clear -> {c, [Listbox," del 0 end"]}; + {add, {Idx, Str}} -> + {c, [Listbox, " ins ", integer_to_list(Idx), " ", + gstk:to_ascii(Str)]}; + {add, Str} -> + {c, [Listbox," ins end ",gstk:to_ascii(Str)]}; + {change, {Idx, Str}} -> + {c, [Listbox, " del ", integer_to_list(Idx), $;, + Listbox, " ins ", integer_to_list(Idx), " " , + gstk:to_ascii(Str)]}; + {see, Idx} -> + {c, [Listbox," see ",gstk:to_ascii(Idx)]}; + + {setfocus, true} -> {c, ["focus ", MainW]}; + {setfocus, false} -> {c, ["focus ."]}; + + {click, On} -> cbind(DB, Gstkid, Listbox, click, On); + {doubleclick, On} -> cbind(DB, Gstkid, Listbox, doubleclick, On); + _ -> invalid_option + end. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : read_option/3 +%% Purpose : Take care of a read option +%% Args : DB - The Database +%% Gstkid - The gstkid of the widget +%% Option - An option +%% +%% Return : The value of the option or invalid_option +%% [OptionValue | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +read_option(Option,GstkId,_MainW,DB,Listbox) -> + case Option of + fg -> tcl2erl:ret_color([Listbox," cg -fg"]); + font -> gstk_db:opt(DB,GstkId,font,undefined); + selection -> tcl2erl:ret_list([Listbox, " curselection"]); + setfocus -> tcl2erl:ret_focus(Listbox, "focus"); + + items -> tcl2erl:ret_str_list([Listbox, " get 0 end"]); + selectmode -> tcl2erl:ret_atom([Listbox, " cg -selectmode"]); + size -> tcl2erl:ret_int([Listbox, " size"]); + xselection -> tcl2erl:ret_bool([Listbox, " cg -exportsel"]); + {get, Idx} -> tcl2erl:ret_str([Listbox, " get ",gstk:to_ascii(Idx)]); + click -> gstk_db:is_inserted(DB, GstkId, click); + doubleclick -> gstk_db:is_inserted(DB, GstkId, doubleclick); + + _ -> {bad_result, {GstkId#gstkid.objtype, invalid_option, Option}} + end. + + +%%----------------------------------------------------------------------------- +%% PRIMITIVES +%%----------------------------------------------------------------------------- + +item_list([H|T]) -> + [gstk:to_ascii(H),$ |item_list(T)]; +item_list([]) -> + []. + +cbind(DB, Gstkid, Listbox, Etype, {true, Edata}) -> + Button = case Etype of + click -> " <ButtonRelease-1> "; + doubleclick -> " <Double-ButtonRelease-1> " + end, + Eref = gstk_db:insert_event(DB, Gstkid, Etype, Edata), + {c, ["bind " ,Listbox, Button, "{erlsend ", Eref," }"]}; + +cbind(DB, Gstkid, Listbox, Etype, true) -> + cbind(DB, Gstkid, Listbox, Etype, {true, []}); + +cbind(DB, Gstkid, Listbox, Etype, _On) -> + Button = case Etype of + click -> " <Button-1> {}"; + doubleclick -> " <Double-Button-1> {}" + end, + gstk_db:delete_event(DB, Gstkid, Etype), + {c, ["bind ",Listbox, Button]}. + + +%%% ----- Done ----- diff --git a/lib/gs/src/gstk_menu.erl b/lib/gs/src/gstk_menu.erl new file mode 100644 index 0000000000..3957951a35 --- /dev/null +++ b/lib/gs/src/gstk_menu.erl @@ -0,0 +1,266 @@ +%% +%% %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 MENU TYPE +%%------------------------------------------------------------------------------ + +-module(gstk_menu). + +%%------------------------------------------------------------------------------ +%% MENU OPTIONS +%% +%% Attribute: +%% activebg Color +%% activebw Int +%% activefg Color +%% bg Color +%% bw Int +%% data Data +%% disabledfg Color +%% fg Color +%% relief Relief [flat|raised|sunken|ridge|groove] +%% selectcolor Color +%% +%% Commands: +%% setfocus [Bool | {Bool, Data}] +%% +%% Events: +%% buttonpress [Bool | {Bool, Data}] +%% buttonrelease [Bool | {Bool, Data}] +%% configure [Bool | {Bool, Data}] +%% destroy [Bool | {Bool, Data}] +%% enter [Bool | {Bool, Data}] +%% focus [Bool | {Bool, Data}] +%% keypress [Bool | {Bool, Data}] +%% keyrelease [Bool | {Bool, Data}] +%% leave [Bool | {Bool, Data}] +%% motion [Bool | {Bool, Data}] +%% +%% Read Options: +%% children +%% id +%% parent +%% type +%% +%% Not Implemented: +%% post {X,Y} +%% unpost +%% align n,w,s,e,nw,se,ne,sw,center +%% anchor n,w,s,e,nw,se,ne,sw,center +%% cursor ?????? +%% focus ?????? (-takefocus) +%% height Int +%% justify left|right|center (multiline text only) +%% width Int +%% x Int (valid only for popup menus) +%% y Int (valid only for popup menus) +%% + +-export([create/3, config/3, read/3, delete/2, event/5,option/5,read_option/5]). +-export([delete_menuitem/3, insert_menuitem/4, lookup_menuitem_pos/3, + mk_create_opts_for_child/4]). + +-include("gstk.hrl"). + +%%------------------------------------------------------------------------------ +%% MANDATORY INTERFACE FUNCTIONS +%%------------------------------------------------------------------------------ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : create/3 +%% Purpose : Create a widget of the type defined in this module. +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +create(DB, GstkId, Opts) -> + #gstkid{parent=Parent,owner=Owner,objtype=Objtype}=GstkId, + Pgstkid = gstk_db:lookup_gstkid(DB, Parent, Owner), + Oref = gstk_db:counter(DB, Objtype), + PF = gstk_widgets:suffix(Objtype), + case Pgstkid#gstkid.objtype of + menuitem -> + PMenu = Pgstkid#gstkid.parent, + PMgstkid = gstk_db:lookup_gstkid(DB, PMenu, Owner), + PMW = PMgstkid#gstkid.widget, + Index = gstk_menu:lookup_menuitem_pos(DB, PMgstkid, Pgstkid#gstkid.id), + TkW = lists:concat([PMW, PF, Oref]), + Gstkid=GstkId#gstkid{widget=TkW, widget_data=[]}, + MPreCmd = ["menu ", TkW, " -tearoff 0 -relief raised -bo 2"], + MPostCmd = [$;,PMW," entryco ",gstk:to_ascii(Index)," -menu ",TkW], + case gstk_generic:make_command(Opts, Gstkid, TkW, "", "", DB) of + {error,Reason} -> {error,Reason}; + Cmd when is_list(Cmd) -> + gstk:exec([MPreCmd,Cmd,MPostCmd]), + Gstkid + end; + OtherParent -> + true = lists:member(OtherParent, + %% grid+canvas har skumma coord system + [menubutton,window,frame]), + PW = Pgstkid#gstkid.widget, + TkW = lists:concat([PW, PF, Oref]), + Gstkid=GstkId#gstkid{widget=TkW, widget_data=[]}, + MPreCmd = ["menu ", TkW, " -tearoff 0 -relief raised -bo 2 "], + MPostCmd = if OtherParent == menubutton -> + [$;, PW, " conf -menu ", TkW]; + true -> [] + end, + case gstk_generic:make_command(Opts, Gstkid, TkW, "","", DB) of + {error,Reason} -> {error,Reason}; + Cmd when is_list(Cmd) -> + gstk:exec([MPreCmd,Cmd,MPostCmd]), + Gstkid + end + end. + +mk_create_opts_for_child(DB,Cgstkid, Pgstkid, Opts) -> + gstk_generic:mk_create_opts_for_child(DB,Cgstkid,Pgstkid,Opts). + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : config/3 +%% Purpose : Configure a widget of the type defined in this module. +%% Args : DB - The Database +%% Gstkid - The gstkid of the widget +%% Opts - A list of options for configuring the widget +%% +%% Return : [true | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +config(DB, Gstkid, Opts) -> + TkW = Gstkid#gstkid.widget, + PreCmd = [TkW, " conf"], + gstk_generic:mk_cmd_and_exec(Opts, Gstkid, TkW, PreCmd, "", DB). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : read/3 +%% Purpose : Read one option from a widget +%% Args : DB - The Database +%% Gstkid - The gstkid of the widget +%% Opt - An option to read +%% +%% Return : [OptionValue | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +read(DB, Gstkid, Opt) -> + gstk_generic:read_option(DB, Gstkid, Opt). + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : delete/2 +%% Purpose : Delete widget from databas and return tkwidget to destroy +%% Args : DB - The Database +%% Gstkid - The gstkid of the widget +%% +%% Return : TkWidget to destroy +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +delete(DB, Gstkid) -> + gstk_db:delete_widget(DB, Gstkid), + Gstkid#gstkid.widget. + +event(DB, Gstkid, Etype, Edata, Args) -> + gstk_generic:event(DB, Gstkid, Etype, Edata, Args). + +%%------------------------------------------------------------------------------ +%% MANDATORY FUNCTIONS +%%------------------------------------------------------------------------------ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : option/4 +%% Purpose : Take care of options +%% Args : Option - An option tuple +%% Gstkid - The gstkid of the widget +%% TkW - The tk-widget +%% DB - The Database +%% +%% Return : A tuple {OptionType, OptionCmd} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +option(Option, Gstkid, TkW, DB,_) -> + case Option of + {activebw, Int} -> {s, [" -activebo ", gstk:to_ascii(Int)]}; + {disabledfg, Color} -> {s, [" -disabledf ", gstk:to_color(Color)]}; + {selectcolor, Color} -> {s, [" -selectc ", gstk:to_color(Color)]}; + {post_at, {X,Y}} -> post_at(X,Y,Gstkid,TkW,DB); + _ -> invalid_option + end. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : read_option/5 +%% Purpose : Take care of a read option +%% Args : DB - The Database +%% Gstkid - The gstkid of the widget +%% Option - An option +%% +%% Return : The value of the option or invalid_option +%% [OptionValue | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +read_option(Option, Gstkid, TkW, _DB, _AItem) -> + case Option of + activebw -> tcl2erl:ret_int([TkW," cg -activebo"]); + disabledfg -> tcl2erl:ret_color([TkW," cg -disabledfo"]); + selectcolor -> tcl2erl:ret_color([TkW," cg -selectc"]); + _ -> {error,{invalid_option,Option, Gstkid#gstkid.objtype}} + end. + +post_at(X,Y,Gstkid,TkW,DB) -> + Pgstkid = gstk_db:lookup_gstkid(DB, Gstkid#gstkid.parent), + PtkW = Pgstkid#gstkid.widget, + RootX = tcl2erl:ret_int(["winfo rootx ",PtkW]), + RootY = tcl2erl:ret_int(["winfo rooty ",PtkW]), + {c,[" tk_popup ",TkW," ",gstk:to_ascii(RootX+X)," ",gstk:to_ascii(RootY+Y)]}. + + +%%----------------------------------------------------------------------------- +%% PRIMITIVES +%%----------------------------------------------------------------------------- +%%---------------------------------------------------------------------- +%% gstk_db functions for menuitem handling +%% Tk menuitems are numbered from 0, thus we have to recalc the position. +%%---------------------------------------------------------------------- +insert_menuitem(DB, MenuId, ItemId, Pos) -> + Mgstkid = gstk_db:lookup_gstkid(DB, MenuId), + Items = Mgstkid#gstkid.widget_data, + NewItems = insert_at(ItemId, Pos+1, Items), + gstk_db:update_widget(DB, Mgstkid#gstkid{widget_data=NewItems}). + + +delete_menuitem(DB, MenuId, ItemId) -> + Mgstkid = gstk_db:lookup_gstkid(DB, MenuId), + Items = Mgstkid#gstkid.widget_data, + NewItems = lists:delete(ItemId, Items), + gstk_db:insert_widget(DB, Mgstkid#gstkid{widget_data=NewItems}). + + +lookup_menuitem_pos(_DB, Mgstkid, ItemId) -> + Items = Mgstkid#gstkid.widget_data, + find_pos(ItemId, Items) - 1. + +%%---------------------------------------------------------------------- +%% Generic list processing +%%---------------------------------------------------------------------- +find_pos(ItemId, Items) -> + find_pos(ItemId, Items, 1). + +find_pos(_ItemId, [], _N) -> gs:error("Couldn't find item in menu~n", []); +find_pos(ItemId, [ItemId|_Items], N) -> N; +find_pos(ItemId, [_|Items], N) -> + find_pos(ItemId, Items, N + 1). + +insert_at(Elem, 1, L) -> [Elem | L]; +insert_at(Elem, N, [H|T]) -> + [H|insert_at(Elem, N-1, T)]. + +%% ----- Done ----- diff --git a/lib/gs/src/gstk_menubar.erl b/lib/gs/src/gstk_menubar.erl new file mode 100644 index 0000000000..eb2806e14b --- /dev/null +++ b/lib/gs/src/gstk_menubar.erl @@ -0,0 +1,175 @@ +%% +%% %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 Menubar Type +%% ------------------------------------------------------------ + +-module(gstk_menubar). + +%%------------------------------------------------------------------------------ +%% MENUBAR OPTIONS +%% +%% Attributes: +%% bg Color +%% bw Int +%% data Data +%% height Int +%% highlightbg Color +%% highlightbw Int +%% highlightfg Color +%% relief Relief [flat|raised|sunken|ridge|groove] +%% +%% Commands: +%% setfocus [Bool | {Bool, Data}] +%% +%% Events: +%% buttonpress [Bool | {Bool, Data}] +%% buttonrelease [Bool | {Bool, Data}] +%% configure [Bool | {Bool, Data}] +%% destroy [Bool | {Bool, Data}] +%% enter [Bool | {Bool, Data}] +%% focus [Bool | {Bool, Data}] +%% keypress [Bool | {Bool, Data}] +%% keyrelease [Bool | {Bool, Data}] +%% leave [Bool | {Bool, Data}] +%% motion [Bool | {Bool, Data}] +%% +%% Read Options: +%% children +%% id +%% parent +%% type +%% +%% Not Implemented: +%% align How +%% + +-export([create/3,config/3,read/3,delete/2,event/5,option/5,read_option/5, + mk_create_opts_for_child/4]). + +-include("gstk.hrl"). + +%%----------------------------------------------------------------------------- +%% MANDATORY INTERFACE FUNCTIONS +%%----------------------------------------------------------------------------- +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : create/7 +%% Purpose : Create a widget of the type defined in this module. +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +create(DB, GstkId, Opts) -> + TkW = gstk_generic:mk_tkw_child(DB,GstkId), + MPreCmd = ["frame ", TkW], + PlaceCmd = [";place ", TkW], + Ngstkid = GstkId#gstkid{widget=TkW}, + case gstk_generic:make_command(Opts, Ngstkid,TkW, MPreCmd, PlaceCmd, DB) of + {error,Reason} -> {error,Reason}; + Cmd when is_list(Cmd) -> + gstk:exec([Cmd,";pack ", TkW, " -side top -fill x;"]), + Ngstkid + end. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : config/3 +%% Purpose : Configure a widget of the type defined in this module. +%% Args : DB - The Database +%% Gstkid - The gstkid of the widget +%% Opts - A list of options for configuring the widget +%% +%% Return : [true | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +config(DB, Gstkid, Opts) -> + TkW = Gstkid#gstkid.widget, + SimplePreCmd = [TkW, " conf"], + PlacePreCmd = ["place ", TkW], + gstk_generic:mk_cmd_and_exec(Opts,Gstkid,TkW,SimplePreCmd,PlacePreCmd,DB). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : read/3 +%% Purpose : Read one option from a widget +%% Args : Opt - An option to read +%% Return : [OptionValue | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +read(DB, Gstkid, Opt) -> + gstk_generic:read_option(DB, Gstkid, Opt). + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : delete/2 +%% Purpose : Delete widget from databas and return tkwidget to destroy +%% Args : DB - The Database +%% Gstkid - The gstkid of the widget +%% +%% Return : TkWidget to destroy +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +delete(DB, Gstkid) -> + gstk_db:delete_widget(DB, Gstkid), + Gstkid#gstkid.widget. + +event(DB, Gstkid, Etype, Edata, Args) -> + gstk_generic:event(DB, Gstkid, Etype, Edata, Args). + +mk_create_opts_for_child(DB,Cgstkid, Pgstkid, Opts) +when Cgstkid#gstkid.objtype==menubutton -> + case gstk_db:lookup_def(Pgstkid,menubutton,bg) of + false -> + MbarTkW=Pgstkid#gstkid.widget, + Color=tcl2erl:ret_color([MbarTkW," cg -bg"]), + gstk_db:insert_def(Pgstkid,menubutton,{bg,Color}); + _ -> done + end, + gstk_generic:mk_create_opts_for_child(DB,Cgstkid,Pgstkid,Opts). + + +%%----------------------------------------------------------------------------- +%% MANDATORY FUNCTIONS +%%----------------------------------------------------------------------------- +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : option/4 +%% Purpose : Take care of options +%% Args : Option - An option tuple +%% TkW - The tk-widget +%% Return : A tuple {OptionType, OptionCmd} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +option(Option,_Gstkid,_TkW,_DB,_) -> + case Option of + {bg, Color} -> {s, [" -bg ", gstk:to_color(Color)]}; + {height, Height} -> {s, [" -height ", gstk:to_ascii(Height)]}; + _ -> invalid_option + end. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : read_option/5 +%% Purpose : Take care of a read option +%% Return : The value of the option or invalid_option +%% [OptionValue | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +read_option(Option,GstkId,TkW,_DB,_) -> + case Option of + bg -> tcl2erl:ret_color([TkW," cg -bg"]); + height -> tcl2erl:ret_int(["update idletasks;winfo he ",TkW]); + _ -> {bad_result, {GstkId#gstkid.objtype, invalid_option, Option}} + end. + + +%% ----- Done ----- + + diff --git a/lib/gs/src/gstk_menubutton.erl b/lib/gs/src/gstk_menubutton.erl new file mode 100644 index 0000000000..6c5abf600f --- /dev/null +++ b/lib/gs/src/gstk_menubutton.erl @@ -0,0 +1,237 @@ +%% +%% %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 Menubutton Type +%% ------------------------------------------------------------ + +-module(gstk_menubutton). + +%%------------------------------------------------------------------------------ +%% MENUBUTTON OPTIONS +%% +%% Attributes: +%% activebg Color +%% activefg Color +%% align n,w,s,e,nw,se,ne,sw,center +%% anchor n,w,s,e,nw,se,ne,sw,center +%% bg Color +%% bw Int +%% data Data +%% disabledfg Color +%% fg Color +%% font Font +%% height Int +%% highlightbg Color +%% highlightbw Int +%% highlightfg Color +%% justify left|right|center (multiline text only) +%% label {text, String} | {image, BitmapFile} +%% padx Int (Pixels) +%% pady Int (Pixels) +%% relief Relief [flat|raised| sunken | ridge | groove] +%% side left | right (valid only in menubars) +%% underline Int +%% width Int +%% wraplength Int +%% x Int (not valid in menubars) +%% y Int (not valid in menubars) +%% +%% Commands: +%% enable Bool +%% setfocus Bool +%% +%% Events: +%% buttonpress [Bool | {Bool, Data}] +%% buttonrelease [Bool | {Bool, Data}] +%% configure [Bool | {Bool, Data}] +%% destroy [Bool | {Bool, Data}] +%% enter [Bool | {Bool, Data}] +%% focus [Bool | {Bool, Data}] +%% keypress [Bool | {Bool, Data}] +%% keyrelease [Bool | {Bool, Data}] +%% leave [Bool | {Bool, Data}] +%% motion [Bool | {Bool, Data}] +%% +%% Read Options: +%% children +%% id +%% parent +%% type +%% +%% Not Implemented: +%% activate ?????? (kontra enable, true) +%% state ?????? +%% cursor ?????? +%% image ?????? +%% focus ?????? (-takefocus) +%% + +-export([create/3,config/3,read/3,delete/2,event/5,option/5,read_option/5, + mk_create_opts_for_child/4]). + +-include("gstk.hrl"). + +%%----------------------------------------------------------------------------- +%% MANDATORY INTERFACE FUNCTIONS +%%----------------------------------------------------------------------------- +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : create/7 +%% Purpose : Create a widget of the type defined in this module. +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +create(DB, GstkId, Opts) -> + TkW = gstk_generic:mk_tkw_child(DB,GstkId), + NGstkId=GstkId#gstkid{widget=TkW}, + PlacePreCmd = [";place ", TkW], + case gstk_generic:make_command(Opts, NGstkId, TkW, "", PlacePreCmd, DB) of + {error,Reason} -> {error,Reason}; + Cmd when is_list(Cmd) -> + gstk:exec(["menubutton ", TkW," -padx 4 -pady 3",Cmd]), + NGstkId + end. + +mk_create_opts_for_child(DB,Cgstkid, Pgstkid, Opts) -> + gstk_generic:mk_create_opts_for_child(DB,Cgstkid,Pgstkid,Opts). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : config/3 +%% Purpose : Configure a widget of the type defined in this module. +%% Args : DB - The Database +%% Gstkid - The gstkid of the widget +%% Opts - A list of options for configuring the widget +%% +%% Return : [true | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +config(DB, Gstkid, Opts) -> + TkW = Gstkid#gstkid.widget, + SimplePreCmd = [TkW, " conf"], + PlacePreCmd = [";place ", TkW], + gstk_generic:mk_cmd_and_exec(Opts,Gstkid,TkW,SimplePreCmd,PlacePreCmd,DB). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : read/3 +%% Purpose : Read one option from a widget +%% Args : DB - The Database +%% Gstkid - The gstkid of the widget +%% Opt - An option to read +%% +%% Return : [OptionValue | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +read(DB, Gstkid, Opt) -> + gstk_generic:read_option(DB, Gstkid, Opt). + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : delete/2 +%% Purpose : Delete widget from databas and return tkwidget to destroy +%% Args : DB - The Database +%% Gstkid - The gstkid of the widget +%% +%% Return : TkWidget to destroy +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +delete(DB, Gstkid) -> + gstk_db:delete_widget(DB, Gstkid), + Gstkid#gstkid.widget. + +event(DB, Gstkid, Etype, Edata, Args) -> + gstk_generic:event(DB, Gstkid, Etype, Edata, Args). + +%%----------------------------------------------------------------------------- +%% MANDATORY FUNCTIONS +%%----------------------------------------------------------------------------- +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : option/4 +%% Purpose : Take care of options +%% Args : Option - An option tuple +%% Gstkid - The gstkid of the widget +%% TkW - The tk-widget +%% DB - The Database +%% +%% Return : A tuple {OptionType, OptionCmd} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +option(Option, Gstkid, TkW, DB,_) -> + case Option of + {anchor, How} -> fix_anchor(How, Gstkid, TkW, DB); + {disabledfg, Color} -> {s, [" -disabledf ", gstk:to_color(Color)]}; + {height, Height} -> {s, [" -he ", gstk:to_ascii(Height)]}; + {side, Side} -> fix_side(Side, Gstkid, TkW, DB); + {underline, Int} -> {s, [" -und ", gstk:to_ascii(Int)]}; + {width, Width} -> {s, [" -wi ", gstk:to_ascii(Width)]}; + {wraplength, Int} -> {s, [" -wr ", gstk:to_ascii(Int)]}; + {x, X} -> fix_placement(x, X, Gstkid, TkW, DB); + {y, Y} -> fix_placement(y, Y, Gstkid, TkW, DB); + _ -> invalid_option + end. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : read_option/3 +%% Purpose : Take care of a read option +%% Args : DB - The Database +%% Gstkid - The gstkid of the widget +%% Option - An option +%% +%% Return : The value of the option or invalid_option +%% [OptionValue | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +read_option(Option,GstkId,TkW,_DB,_) -> + case Option of + anchor -> tcl2erl:ret_place(anchor, TkW); + disabledfg -> tcl2erl:ret_color([TkW," cg -disabledfo"]); + height -> tcl2erl:ret_int([TkW," cg -he"]); + side -> tcl2erl:ret_pack(side, TkW); + underline -> tcl2erl:ret_int([TkW," cg -underl"]); + width -> tcl2erl:ret_int([TkW," cg -wi"]); + wraplength -> tcl2erl:ret_int([TkW," cg -wr"]); + x -> tcl2erl:ret_place(x, TkW); + y -> tcl2erl:ret_place(y, TkW); + _ -> {error,{invalid_option,Option, GstkId#gstkid.objtype}} + end. + +%%----------------------------------------------------------------------------- +%% PRIMITIVES +%%----------------------------------------------------------------------------- + +fix_placement(Attr, Value, Gstkid, _TkW, DB) -> + Pgstkid = gstk_db:lookup_gstkid(DB, Gstkid#gstkid.parent), + case Pgstkid#gstkid.objtype of + menubar -> invalid_option; + _ -> {p, [" -", atom_to_list(Attr), " ", gstk:to_ascii(Value)]} + end. + + +fix_anchor(How, Gstkid, TkW, DB) -> + Pgstkid = gstk_db:lookup_gstkid(DB, Gstkid#gstkid.parent), + case Pgstkid#gstkid.objtype of + menubar -> {c, ["pack ", TkW, " -an ", gstk:to_ascii(How)]}; + _ -> {p, [" -anch ", gstk:to_ascii(How)]} + end. + + +fix_side(Side, Gstkid, TkW, DB) -> + Pgstkid = gstk_db:lookup_gstkid(DB, Gstkid#gstkid.parent), + case Pgstkid#gstkid.objtype of + menubar -> {c, ["pack ", TkW, " -fill y -si ", gstk:to_ascii(Side)]}; + _ -> none + end. + + +%% ----- Done ----- + diff --git a/lib/gs/src/gstk_menuitem.erl b/lib/gs/src/gstk_menuitem.erl new file mode 100644 index 0000000000..36a9253598 --- /dev/null +++ b/lib/gs/src/gstk_menuitem.erl @@ -0,0 +1,582 @@ +%% +%% %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 Menuitem Type +%% ------------------------------------------------------------ + +-module(gstk_menuitem). + +%%----------------------------------------------------------------------------- +%% MENUITEM OPTIONS +%% +%% Attribute: +%% accelerator String +%% activebg Color +%% activefg Color +%% bg Color +%% color Color (same as fg) +%% data Data +%% fg Color +%% font Font +%% group Atom (valid only for radio type) +%% index Int +%% itemtype normal|check|radio|separator|cascade (|tearoff) +%% label {text, String} | {image, BitmapFile} +%% menu Menu (valid only for cascade type) +%% selectbg Color +%% underline Int +%% value Atom +%% +%% Commands: +%% activate +%% enable Bool +%% invoke +%% +%% Events: +%% click [Bool | {Bool, Data}] +%% +%% Read Options: +%% children +%% id +%% parent +%% type +%% +%% Not Implemented: +%% font Font +%% read menu on cascades +%% + +-export([create/3, config/3, read/3, delete/2, destroy/3, event/5, + option/5,read_option/5,mk_create_opts_for_child/4]). +-include("gstk.hrl"). + +%%----------------------------------------------------------------------------- +%% MANDATORY INTERFACE FUNCTIONS +%%----------------------------------------------------------------------------- +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : create/3 +%% Purpose : Create a widget of the type defined in this module. +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +create(DB, GstkId, Opts) -> + #gstkid{parent=Parent,owner=Owner,id=Id}=GstkId, + Pgstkid = gstk_db:lookup_gstkid(DB, Parent), + TkMenu = Pgstkid#gstkid.widget, + Widget = "", + {Index, Type, Options} = parse_opts(Opts, TkMenu), + PreCmd = [TkMenu, " insert ", gstk:to_ascii(Index)], + InsertArgs = [DB, Parent,Id, Index], + case Type of + check -> + {G, GID, NOpts} = fix_group(Options, DB, Owner), + TypeCmd = " ch", + Ngstkid=GstkId#gstkid{widget=Widget,widget_data={Type, G, GID}}, + GenArgs = [NOpts,Ngstkid,TkMenu,"","",DB,{Type,Index}], + CallArgs = [PreCmd,TypeCmd], + mk_it(GenArgs,CallArgs,InsertArgs,Ngstkid); + radio -> + {G, GID, V, NOpts} = fix_group_and_value(Options, DB, Owner), + Ngstkid=GstkId#gstkid{widget=Widget, widget_data={Type,G,GID,V}}, + TypeCmd = " ra", + GenArgs = [NOpts,Ngstkid,TkMenu,"", "",DB,{Type,Index}], + CallArgs = [PreCmd,TypeCmd], + mk_it(GenArgs,CallArgs,InsertArgs,Ngstkid); + _ -> + Ngstkid=GstkId#gstkid{widget=Widget, widget_data=Type}, + TypeCmd = case Type of + normal -> " co"; + separator -> " se"; + cascade -> " ca" + end, + GenArgs = [Options,Ngstkid,TkMenu,"","",DB,{Type,Index}], + CallArgs = [PreCmd,TypeCmd], + mk_it(GenArgs,CallArgs,InsertArgs,Ngstkid) + end. + +mk_it(GenArgs,CallArgs,InsertArgs,Ngstkid) -> + case apply(gstk_generic,make_command,GenArgs) of + {error,Reason} -> {error,Reason}; + Cmd when is_list(Cmd) -> + case apply(gstk,call,[[CallArgs|Cmd]]) of + {result,_} -> + apply(gstk_menu,insert_menuitem,InsertArgs), + Ngstkid; + Bad_Result -> {error,Bad_Result} + end + end. + +mk_create_opts_for_child(DB,Cgstkid, Pgstkid, Opts) -> + gstk_generic:mk_create_opts_for_child(DB,Cgstkid,Pgstkid,Opts). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : config/3 +%% Purpose : Configure a widget of the type defined in this module. +%% Args : DB - The Database +%% Gstkid - The gstkid of the widget +%% Options - A list of options for configuring the widget +%% +%% Return : [true | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +% FIXME: Could we really trust Index? If we create a menu and put one +% entry in the middle of the meny, don't the entrys after that one +% renumber? + +config(DB, Gstkid, Options) -> + Parent = Gstkid#gstkid.parent, + Pgstkid = gstk_db:lookup_gstkid(DB, Parent), + TkMenu = Pgstkid#gstkid.widget, + case Gstkid#gstkid.widget_data of + {Type, _, _, _} -> + Owner = Gstkid#gstkid.owner, + {NOpts, NGstkid} = fix_group_and_value(Options, DB, Owner, Gstkid), + Index = gstk_menu:lookup_menuitem_pos(DB, Pgstkid, NGstkid#gstkid.id), + PreCmd = [TkMenu, " entryco ", gstk:to_ascii(Index)], + gstk_generic:mk_cmd_and_exec(NOpts,NGstkid,TkMenu,PreCmd,"",DB, + {Type,Index}); + {Type, _, _} -> + Owner = Gstkid#gstkid.owner, + {NOpts, NGstkid} = fix_group(Options, DB, Owner, Gstkid), + Index = gstk_menu:lookup_menuitem_pos(DB, Pgstkid, NGstkid#gstkid.id), + PreCmd = [TkMenu, " entryco ", gstk:to_ascii(Index)], + gstk_generic:mk_cmd_and_exec(NOpts,NGstkid,TkMenu,PreCmd,"",DB, + {Type,Index}); + Type -> + Index = gstk_menu:lookup_menuitem_pos(DB, Pgstkid, Gstkid#gstkid.id), + PreCmd = [TkMenu, " entryco ", gstk:to_ascii(Index)], + gstk_generic:mk_cmd_and_exec(Options,Gstkid,TkMenu,PreCmd,"", + DB, {Type,Index}) + end. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : read/3 +%% Purpose : Read one option from a widget +%% Args : DB - The Database +%% Gstkid - The gstkid of the widget +%% Opt - An option to read +%% +%% Return : [OptionValue | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +read(DB, Gstkid, Opt) -> + gstk_generic:read_option(DB, Gstkid, Opt). + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : delete/2 +%% Purpose : Delete widget from databas and return tkwidget to destroy +%% Args : DB - The Database +%% Gstkid - The gstkid of the widget +%% +%% Return : TkWidget to destroy +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +delete(DB, Gstkid) -> + Parent = Gstkid#gstkid.parent, + Id = Gstkid#gstkid.id, + gstk_db:delete_widget(DB, Gstkid), + case Gstkid#gstkid.widget_data of + {radio, _, Gid, _} -> gstk_db:delete_bgrp(DB, Gid); + {check, _, Gid} -> gstk_db:delete_bgrp(DB, Gid); + _Other -> true + end, + {Parent, Id, gstk_menuitem, [Id, Parent]}. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : destroy/3 +%% Purpose : Destroy a widget +%% Args : Menu - The menu tk widget +%% Item - The index of the menuitem to destroy +%% Return : [true | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +destroy(DB, Id, Parent) -> + Pgstkid = gstk_db:lookup_gstkid(DB, Parent), + PW = Pgstkid#gstkid.widget, + Idx = gstk_menu:lookup_menuitem_pos(DB, Pgstkid, Id), + gstk_menu:delete_menuitem(DB, Parent, Id), + gstk:exec([PW, " delete ", gstk:to_ascii(Idx)]). + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : event/5 +%% Purpose : Construct the event and send it to the owner of the widget +%% Args : Etype - The event type +%% Edata - The event data +%% Args - The data from tcl/tk +%% +%% Return : [true | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +event(DB, Gstkid, Etype, Edata, Args) -> + Arg2 = + case Gstkid#gstkid.widget_data of + {radio, G, _GID, V} -> + [_Grp, Text, Idx | Args1] = Args, + [Text, Idx, G, V | Args1]; + {check, G, _Gid} -> + [Bool, Text, Idx | Args1] = Args, + RBool = case Bool of + 0 -> false; + 1 -> true + end, + [Text, Idx, G, RBool | Args1]; + _Other2 -> + Args + end, + gstk_generic:event(DB, Gstkid, Etype, Edata, Arg2). + + + +%%----------------------------------------------------------------------------- +%% MANDATORY FUNCTIONS +%%----------------------------------------------------------------------------- +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : option/4 +%% Purpose : Take care of options +%% Args : Option - An option tuple +%% TkW - The tk-widget +%% Return : A tuple {OptionType, OptionCmd} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +option({click,true}, _Gstkid, _TkW, _DB, {separator,_Index}) -> + none; % workaround to be able to have {click,true} as default. +option(_Option, _Gstkid, _TkW, _DB, {separator,_Index}) -> + invalid_option; + +option({menu,{Menu,_RestOfExternalId}}, _Gstkid, _TkW, DB, {cascade,_Index}) -> + Mgstkid = gstk_db:lookup_gstkid(DB, Menu), + MenuW = Mgstkid#gstkid.widget, + {s, [" -menu ", MenuW]}; + +option({select,false}, _Gstkid, TkW, _DB, {check,Index}) -> + {c, ["set x [", TkW, " entrycg ", gstk:to_ascii(Index), + " -var];global $x;set $x 0"]}; +option({select,true}, _Gstkid, TkW, _DB, {check,Index}) -> + {c, ["set x [", TkW, " entrycg ", gstk:to_ascii(Index), + " -var];global $x;set $x 1"]}; + +option({value,Val}, _Gstkid, _TkW, _DB, {radio,_Index}) -> + {s, [" -val ", gstk:to_ascii(Val)]}; +option({select,false}, _Gstkid, TkW, _DB, {radio,Index}) -> + {c, ["set x [", TkW, " entrycg ", gstk:to_ascii(Index), + " -var];global $x;set $x {}"]}; +option({select,true}, _Gstkid, TkW, _DB, {radio,Index}) -> + {c, ["set x [", TkW, " entrycg ", gstk:to_ascii(Index), + " -var]; set y [", TkW, " entrycg ", gstk:to_ascii(Index), + " -val]; global $x; set $x $y"]}; + +option(Option, Gstkid, TkW, DB, {Kind,Index}) -> + case Option of + activate -> {c, [TkW, " act ", gstk:to_ascii(Index)]}; + invoke -> {c, [TkW, " inv ", gstk:to_ascii(Index)]}; + {accelerator, Acc} -> {s, [" -acc ", gstk:to_ascii(Acc)]}; + {click, On} -> cbind(On, Gstkid, TkW, Index, Kind, DB); + {font, Font} when is_tuple(Font) -> + gstk_db:insert_opt(DB,Gstkid,Option), + {s, [" -font ", gstk_font:choose_ascii(DB,Font)]}; + {label, {image,Img}} -> {s, [" -bitm @", Img, " -lab {}"]}; + % FIXME: insert -command here..... + % FIXME: how to get value from image entry??? + {label, {text,Text}} -> {s, [" -lab ",gstk:to_ascii(Text)," -bitm {}"]}; + {underline, Int} -> {s, [" -underl ", gstk:to_ascii(Int)]}; + {activebg, Color} -> {s, [" -activeba ", gstk:to_color(Color)]}; + {activefg, Color} -> {s, [" -activefo ", gstk:to_color(Color)]}; + {bg, Color} -> {s, [" -backg ", gstk:to_color(Color)]}; + {enable, true} -> {s, " -st normal"}; + {enable, false} -> {s, " -st disabled"}; + {fg, Color} -> {s, [" -foreg ", gstk:to_color(Color)]}; + _Other -> + case lists:member(Kind,[radio,check]) of + true -> + case Option of + {group,Group} -> {s, [" -var ", gstk:to_ascii(Group)]}; + {selectbg,Col} -> {s,[" -selectc ",gstk:to_color(Col)]}; + _ -> invalid_option + end; + _ -> invalid_option + end + end. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : read_option/5 +%% Purpose : Take care of a read option +%% Return : The value of the option or invalid_option +%% [OptionValue | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +read_option(Option,GstkId,_TkW,DB,_) -> + ItemId = GstkId#gstkid.id, + MenuId = GstkId#gstkid.parent, + MenuGstkid = gstk_db:lookup_gstkid(DB, MenuId), + MenuW = MenuGstkid#gstkid.widget, + Idx = gstk_menu:lookup_menuitem_pos(DB, MenuGstkid, ItemId), + PreCmd = [MenuW, " entrycg ", gstk:to_ascii(Idx)], + case Option of + accelerator -> tcl2erl:ret_str([PreCmd, " -acc"]); + activebg -> tcl2erl:ret_color([PreCmd, " -activeba"]); + activefg -> tcl2erl:ret_color([PreCmd, " -activefo"]); + bg -> tcl2erl:ret_color([PreCmd, " -backg"]); + fg -> tcl2erl:ret_color([PreCmd, " -foreg"]); + group -> read_group(GstkId, Option); + groupid -> read_groupid(GstkId, Option); + index -> Idx; + itemtype -> case GstkId#gstkid.widget_data of + {Type, _, _, _} -> Type; + {Type, _, _} -> Type; + Type -> Type + end; + enable -> tcl2erl:ret_enable([PreCmd, " -st"]); + font -> gstk_db:opt(DB,GstkId,font,undefined); + label -> tcl2erl:ret_label(["list [", PreCmd, " -lab] [", + PreCmd, " -bit]"]); + selectbg -> tcl2erl:ret_color([PreCmd, " -selectco"]); + underline -> tcl2erl:ret_int([PreCmd, " -underl"]); + value -> tcl2erl:ret_atom([PreCmd, " -val"]); + select -> read_select(MenuW, Idx, GstkId); + click -> gstk_db:is_inserted(DB, GstkId, click); + _ -> {bad_result, {GstkId#gstkid.objtype, invalid_option, Option}} + end. + +read_group(Gstkid, Option) -> + case Gstkid#gstkid.widget_data of + {_, G, _, _} -> G; + {_, G, _} -> G; + _Other -> {bad_result,{Gstkid#gstkid.objtype, invalid_option, Option}} + end. + +read_groupid(Gstkid, Option) -> + case Gstkid#gstkid.widget_data of + {_, _, Gid, _} -> Gid; + {_, _, Gid} -> Gid; + _Other -> {bad_result,{Gstkid#gstkid.objtype, invalid_option, Option}} + end. + + + + +read_select(TkMenu, Idx, Gstkid) -> + case Gstkid#gstkid.widget_data of + {radio, _, _, _} -> + Cmd = ["list [set x [", TkMenu, " entrycg ", gstk:to_ascii(Idx), + " -var];global $x;set $x] [", TkMenu, + " entrycg ", gstk:to_ascii(Idx)," -val]"], + case tcl2erl:ret_tuple(Cmd) of + {X, X} -> true; + _Other -> false + end; + {check, _, _} -> + Cmd = ["set x [", TkMenu, " entrycg ", gstk:to_ascii(Idx), + " -var];global $x;set $x"], + tcl2erl:ret_bool(Cmd); + _Other -> + {error,{invalid_option,menuitem,select}} + end. + + + +%%----------------------------------------------------------------------------- +%% PRIMITIVES +%%----------------------------------------------------------------------------- + +%% create version +fix_group_and_value(Opts, DB, Owner) -> + {G, GID, V, NOpts} = fgav(Opts, erlNIL, erlNIL, erlNIL, []), + RV = case V of + erlNIL -> + list_to_atom(lists:concat([v,gstk_db:counter(DB,value)])); + Other0 -> Other0 + end, + NG = case G of + erlNIL -> mrb; + Other1 -> Other1 + end, + RGID = case GID of + erlNIL -> {mrbgrp, NG, Owner}; + Other2 -> Other2 + end, + RG = gstk_db:insert_bgrp(DB, RGID), + {NG, RGID, RV, [{group, RG}, {value, RV} | NOpts]}. + +%% config version +fix_group_and_value(Opts, DB, Owner, Gstkid) -> + {Type, RG, RGID, RV} = Gstkid#gstkid.widget_data, + {G, GID, V, NOpts} = fgav(Opts, RG, RGID, RV, []), + case {G, GID, V} of + {RG, RGID, RV} -> + {NOpts, Gstkid}; + {NG, RGID, RV} -> + NGID = {rbgrp, NG, Owner}, + gstk_db:delete_bgrp(DB, RGID), + NRG = gstk_db:insert_bgrp(DB, NGID), + NGstkid = Gstkid#gstkid{widget_data={Type,NG,NGID,RV}}, + gstk_db:insert_widget(DB, NGstkid), + {[{group, NRG} | NOpts], NGstkid}; + {RG, RGID, NRV} -> + NGstkid = Gstkid#gstkid{widget_data={Type,RG,RGID,NRV}}, + gstk_db:insert_widget(DB, NGstkid), + {[{value,NRV} | NOpts], NGstkid}; + {_, NGID, RV} when NGID =/= RGID -> + gstk_db:delete_bgrp(DB, RGID), + NRG = gstk_db:insert_bgrp(DB, NGID), + NGstkid = Gstkid#gstkid{widget_data={Type,RG,NGID,RV}}, + gstk_db:insert_widget(DB, NGstkid), + {[{group, NRG} | NOpts], NGstkid}; + {_, NGID, NRV} when NGID =/= RGID -> + gstk_db:delete_bgrp(DB, RGID), + NRG = gstk_db:insert_bgrp(DB, NGID), + NGstkid = Gstkid#gstkid{widget_data={Type,RG,NGID,NRV}}, + gstk_db:insert_widget(DB, NGstkid), + {[{group, NRG}, {value,NRV} | NOpts], NGstkid}; + {NG, RGID, NRV} -> + NGID = {rbgrp, NG, Owner}, + gstk_db:delete_bgrp(DB, RGID), + NRG = gstk_db:insert_bgrp(DB, NGID), + NGstkid = Gstkid#gstkid{widget_data={Type,NG,NGID,NRV}}, + gstk_db:insert_widget(DB, NGstkid), + {[{group, NRG}, {value,NRV} | NOpts], NGstkid} + end. + + + +fgav([{group, G} | Opts], _, GID, V, Nopts) -> + fgav(Opts, G, GID, V, Nopts); + +fgav([{groupid, GID} | Opts], G, _, V, Nopts) -> + fgav(Opts, G, GID, V, Nopts); + +fgav([{value, V} | Opts], G, GID, _, Nopts) -> + fgav(Opts, G, GID, V, Nopts); + +fgav([Opt | Opts], G, GID, V, Nopts) -> + fgav(Opts, G, GID, V, [Opt | Nopts]); + +fgav([], Group, GID, Value, Opts) -> + {Group, GID, Value, Opts}. + + +%% check button version +%% create version +fix_group(Opts, DB, Owner) -> + {G, GID, NOpts} = fg(Opts, erlNIL, erlNIL, []), + NG = case G of + erlNIL -> + Vref = gstk_db:counter(DB, variable), + list_to_atom(lists:flatten(["mcb", gstk:to_ascii(Vref)])); + Other1 -> Other1 + end, + RGID = case GID of + erlNIL -> {mcbgrp, NG, Owner}; + Other2 -> Other2 + end, + RG = gstk_db:insert_bgrp(DB, RGID), + {NG, RGID, [{group, RG} | NOpts]}. + +%% config version +fix_group(Opts, DB, Owner, Gstkid) -> + {Type, RG, RGID} = Gstkid#gstkid.widget_data, + {G, GID, NOpts} = fg(Opts, RG, RGID, []), + case {G, GID} of + {RG, RGID} -> + {NOpts, Gstkid}; + {NG, RGID} -> + NGID = {cbgrp, NG, Owner}, + gstk_db:delete_bgrp(DB, RGID), + NRG = gstk_db:insert_bgrp(DB, NGID), + NGstkid = Gstkid#gstkid{widget_data={Type,NG,NGID}}, + gstk_db:insert_widget(DB, NGstkid), + {[{group, NRG} | NOpts], NGstkid}; + {_, NGID} when NGID =/= RGID -> + gstk_db:delete_bgrp(DB, RGID), + NRG = gstk_db:insert_bgrp(DB, NGID), + NGstkid = Gstkid#gstkid{widget_data={Type,RG,NGID}}, + gstk_db:insert_widget(DB, NGstkid), + {[{group, NRG} | NOpts], NGstkid} + end. + + + +fg([{group, G} | Opts], _, GID, Nopts) -> + fg(Opts, G, GID, Nopts); + +fg([{groupid, GID} | Opts], G, _, Nopts) -> + fg(Opts, G, GID, Nopts); + +fg([Opt | Opts], G, GID, Nopts) -> + fg(Opts, G, GID, [Opt | Nopts]); + +fg([], Group, GID, Opts) -> + {Group, GID, Opts}. + + + +parse_opts(Opts, TkMenu) -> + parse_opts(Opts, TkMenu, none, none, []). + + +parse_opts([Option | Rest], TkMenu, Idx, Type, Options) -> + case Option of + {index, I} -> parse_opts(Rest, TkMenu, I, Type, Options); + {itemtype, T} -> parse_opts(Rest, TkMenu, Idx, T, Options); + _Other -> parse_opts(Rest, TkMenu, Idx, Type,[Option | Options]) + end; +parse_opts([], TkMenu, Index, Type, Options) -> + RealIdx = + case Index of + Idx when is_integer(Idx) -> Idx; + last -> find_last_index(TkMenu); + Other -> gs:error("Invalid index ~p~n",[Other]) + end, + {RealIdx, Type, Options}. + +find_last_index(TkMenu) -> + case tcl2erl:ret_int([TkMenu, " index last"]) of + Last when is_integer(Last) -> Last+1; + none -> 0; + Other -> gs:error("Couldn't find index ~p~n",[Other]) + end. + +cbind({true, Edata}, Gstkid, TkMenu, Index, Type, DB) -> + Eref = gstk_db:insert_event(DB, Gstkid, click, Edata), + IdxStr = gstk:to_ascii(Index), + case Type of + normal -> + Cmd = [" -command {erlsend ", Eref, + " \\\"[",TkMenu," entrycg ",IdxStr," -label]\\\" ", + IdxStr,"}"], + {s, Cmd}; + check -> + Cmd = [" -command {erlsend ", Eref, + " \[expr \$[", TkMenu, " entrycg ",IdxStr," -var]\] \\\"[", + TkMenu, " entrycg ",IdxStr," -label]\\\" ",IdxStr,"}"], + {s, Cmd}; + radio -> + Cmd = [" -command {erlsend ", Eref, + " [", TkMenu, " entrycg ",IdxStr," -var] \\\"[", + TkMenu, " entrycg ",IdxStr," -label]\\\" ",IdxStr,"}"], + {s, Cmd}; + _Other -> + none + end; + +cbind({false, _}, Gstkid, _TkMenu, _Index, _Type, DB) -> + gstk_db:delete_event(DB, Gstkid, click), + none; + +cbind(On, Gstkid, TkMenu, Index, Type, DB) when is_atom(On) -> + cbind({On, []}, Gstkid, TkMenu, Index, Type, DB). + + +%%% ----- Done ----- + diff --git a/lib/gs/src/gstk_oval.erl b/lib/gs/src/gstk_oval.erl new file mode 100644 index 0000000000..708986235b --- /dev/null +++ b/lib/gs/src/gstk_oval.erl @@ -0,0 +1,188 @@ +%% +%% %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 Oval Type +%% ------------------------------------------------------------ + +-module(gstk_oval). + +%%----------------------------------------------------------------------------- +%% OVAL OPTIONS +%% +%% Options: +%% bw Int +%% coords [{X1,Y1}, {X2,Y2}] +%% data Data +%% fg Color +%% fill Color +%% stipple Bool +%% +%% Commands: +%% lower +%% move {Dx, Dy} +%% raise +%% scale {Xo, Yo, Sx, Sy} +%% setfocus Bool +%% +%% Events: +%% buttonpress [Bool | {Bool, Data}] +%% buttonrelease [Bool | {Bool, Data}] +%% enter [Bool | {Bool, Data}] +%% keypress [Bool | {Bool, Data}] +%% keyrelease [Bool | {Bool, Data}] +%% leave [Bool | {Bool, Data}] +%% motion [Bool | {Bool, Data}] +%% +%% Read Options: +%% children +%% id +%% parent +%% type +%% +%% Not Implemented: +%% + +-export([create/3, config/3, read/3, delete/2, destroy/3, event/5, + option/5,read_option/5]). + +-include("gstk.hrl"). + +%%----------------------------------------------------------------------------- +%% MANDATORY INTERFACE FUNCTIONS +%%----------------------------------------------------------------------------- +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : create/3 +%% Purpose : Create a widget of the type defined in this module. +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +create(DB, Gstkid, Opts) -> + case gstk_canvas:pickout_coords(Opts, [],oval,2) of + {error, Error} -> + {bad_result, Error}; + {Coords, NewOpts} -> + Ngstkid=gstk_canvas:upd_gstkid(DB, Gstkid, Opts), + #gstkid{widget=CanvasTkW}=Ngstkid, + MCmd = [CanvasTkW, " create ov ", Coords], + gstk_canvas:mk_cmd_and_call(NewOpts,Ngstkid, CanvasTkW, MCmd, DB) + end. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : config/3 +%% Purpose : Configure a widget of the type defined in this module. +%% Return : [true | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +config(DB, Gstkid, Opts) -> + gstk_canvas:item_config(DB, Gstkid, Opts). + + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : read/3 +%% Purpose : Read one option from a widget +%% Args : DB - The Database +%% Gstkid - The gstkid of the widget +%% Opt - An option to read +%% +%% Return : [OptionValue | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +read(DB, Gstkid, Opt) -> + Item = Gstkid#gstkid.widget_data, + gstk_generic:read_option(DB,Gstkid,Opt,[gstk:to_ascii(Item)]). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : delete/2 +%% Purpose : Delete widget from databas and return tkwidget to destroy +%% Args : DB - The Database +%% Gstkid - The gstkid of the widget +%% +%% Return : TkWidget to destroy | {Parent, Objmod, Args}. +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +delete(DB, Gstkid) -> + gstk_canvas:item_delete_impl(DB,Gstkid). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : destroy/3 +%% Purpose : Destroy a widget +%% Args : DB - The Database +%% Canvas - The canvas tk widget +%% Item - The item number to destroy +%% +%% Return : [true | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +destroy(_DB, Canvas, Item) -> + gstk:exec([Canvas, " delete ", gstk:to_ascii(Item)]). + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : event/5 +%% Purpose : Construct the event and send it to the owner of the widget +%% Args : DB - The Database +%% Gstkid - The gstkid of the widget +%% Etype - The event type +%% Edata - The event data +%% Args - The data from tcl/tk +%% +%% Return : [true | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +event(DB, Gstkid, Etype, Edata, Args) -> + gstk_generic:event(DB, Gstkid, Etype, Edata, Args). + + +%%----------------------------------------------------------------------------- +%% MANDATORY FUNCTIONS +%%----------------------------------------------------------------------------- +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : option/5 +%% Purpose : Take care of options +%% Args : Option - An option tuple +%% Gstkid - The gstkid of the widget +%% MainW - The main tk-widget +%% Return : A tuple {OptionType, OptionCmd} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +option(Option, _Gstkid, _Canvas, _DB, _AItem) -> + case Option of + {fg, Color} -> {s, [" -outline ", gstk:to_color(Color)]}; + {bw, Int} -> {s, [" -w ", gstk:to_ascii(Int)]}; + _ -> invalid_option + end. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : read_option/5 +%% Purpose : Take care of a read option +%% Args : DB - The Database +%% Option - An option +%% +%% Return : The value of the option or invalid_option +%% [OptionValue | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +read_option(Option, Gstkid, Canvas, _DB, AItem) -> + case Option of + bw -> tcl2erl:ret_int([Canvas, " itemcg ", AItem, " -w"]); + fg -> tcl2erl:ret_color([Canvas, " itemcg ", AItem," -outline"]); + stipple -> tcl2erl:ret_stipple([Canvas," itemcg ",AItem," -stipple"]); + _ -> {bad_result, {Gstkid#gstkid.objtype, invalid_option, Option}} + end. + + + +%% ----- Done ----- + diff --git a/lib/gs/src/gstk_polygon.erl b/lib/gs/src/gstk_polygon.erl new file mode 100644 index 0000000000..83d032901f --- /dev/null +++ b/lib/gs/src/gstk_polygon.erl @@ -0,0 +1,195 @@ +%% +%% %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 Polygon Type +%% ------------------------------------------------------------ + +-module(gstk_polygon). + + +%%----------------------------------------------------------------------------- +%% POLYGON OPTIONS +%% +%% Attributes: +%% bw Int +%% coords [{X1,Y1}, {X2,Y2} | {Xn,Yn}] +%% data Data +%% fg Color +%% fill Color +%% smooth Bool +%% splinesteps Int +%% stipple Bool +%% +%% Commands: +%% lower +%% move {Dx, Dy} +%% raise +%% scale {Xo, Yo, Sx, Sy} +%% setfocus Bool +%% +%% Events: +%% buttonpress [Bool | {Bool, Data}] +%% buttonrelease [Bool | {Bool, Data}] +%% enter [Bool | {Bool, Data}] +%% keypress [Bool | {Bool, Data}] +%% keyrelease [Bool | {Bool, Data}] +%% leave [Bool | {Bool, Data}] +%% motion [Bool | {Bool, Data}] +%% +%% Read Options: +%% children +%% id +%% parent +%% type +%% + +-export([create/3, config/3, read/3, delete/2, destroy/3, event/5, + option/5,read_option/5]). + +-include("gstk.hrl"). + +%%----------------------------------------------------------------------------- +%% MANDATORY INTERFACE FUNCTIONS +%%----------------------------------------------------------------------------- +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : create/7 +%% Purpose : Create a widget of the type defined in this module. +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +create(DB, Gstkid, Opts) -> + case pickout_coords(Opts, []) of + {error, Error} -> + {bad_result, Error}; + {Coords, NewOpts} -> + Ngstkid=gstk_canvas:upd_gstkid(DB, Gstkid, Opts), + #gstkid{widget=CanvasTkW}=Ngstkid, + MCmd = [CanvasTkW, " create po ", Coords], + gstk_canvas:mk_cmd_and_call(NewOpts, Ngstkid,CanvasTkW, MCmd, DB) + end. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : config/3 +%% Purpose : Configure a widget of the type defined in this module. +%% Return : [true | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +config(DB, Gstkid, Opts) -> + gstk_canvas:item_config(DB, Gstkid, Opts). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : read/3 +%% Purpose : Read one option from a widget +%% Args : DB - The Database +%% Gstkid - The gstkid of the widget +%% Opt - An option to read +%% +%% Return : [OptionValue | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +read(DB, Gstkid, Opt) -> + Item = Gstkid#gstkid.widget_data, + gstk_generic:read_option(DB,Gstkid,Opt,[gstk:to_ascii(Item)]). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : delete/2 +%% Purpose : Delete widget from databas and return tkwidget to destroy +%% Args : DB - The Database +%% Gstkid - The gstkid of the widget +%% +%% Return : TkWidget to destroy | {Parent, Objmod, Args}. +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +delete(DB, Gstkid) -> + gstk_canvas:item_delete_impl(DB,Gstkid). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : destroy/3 +%% Purpose : Destroy a widget +%% Args : DB - The Database +%% Canvas - The canvas tk widget +%% Item - The item number to destroy +%% +%% Return : [true | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +destroy(_DB, Canvas, Item) -> + gstk:exec([Canvas, " delete ", gstk:to_ascii(Item)]). + + +event(DB, Gstkid, Etype, Edata, Args) -> + gstk_generic:event(DB, Gstkid, Etype, Edata, Args). + +%%----------------------------------------------------------------------------- +%% MANDATORY FUNCTIONS +%%----------------------------------------------------------------------------- +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : option/5 +%% Purpose : Take care of options +%% Args : Option - An option tuple +%% Gstkid - The gstkid of the widget +%% MainW - The main tk-widget +%% Canvas - The canvas tk-widget +%% DB - The Database +%% +%% Return : A tuple {OptionType, OptionCmd} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +option(Option, _Gstkid, _Canvas, _DB, _AItem) -> + case Option of + {fg, Color} -> {s, [" -outline ", gstk:to_color(Color)]}; + {bw, Int} -> {s, [" -w ", gstk:to_ascii(Int)]}; + {smooth, Bool} -> {s, [" -sm ", gstk:to_ascii(Bool)]}; + {splinesteps, Int} -> {s, [" -sp ", gstk:to_ascii(Int)]}; + _ -> invalid_option + end. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : read_option/5 +%% Purpose : Take care of a read option +%% Return : The value of the option or invalid_option +%% [OptionValue | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +read_option(Option, Gstkid, Canvas, _DB, AItem) -> + case Option of + bw -> tcl2erl:ret_int([Canvas, " itemcg ", AItem, " -w"]); + fg -> + tcl2erl:ret_color([Canvas, " itemcg ", AItem, " -outline"]); + smooth -> tcl2erl:ret_bool([Canvas, " itemcg ", AItem, " -sm"]); + splinesteps -> tcl2erl:ret_int([Canvas, " itemcg ", AItem, " -sp"]); + stipple -> + tcl2erl:ret_stipple([Canvas," itemcg ",AItem," -stipple"]); + + _ -> {bad_result, {Gstkid#gstkid.objtype, invalid_option, Option}} + end. + +%%----------------------------------------------------------------------------- +%% PRIMITIVES +%%----------------------------------------------------------------------------- + +pickout_coords([{coords,Coords} | Rest], Opts) when length(Coords) >= 2 -> + case gstk_canvas:coords(Coords) of + invalid -> + {error, "A polygon must have at least four coordinates"}; + RealCoords -> + {RealCoords, lists:append(Rest, Opts)} + end; +pickout_coords([Opt | Rest], Opts) -> + pickout_coords(Rest, [Opt|Opts]); +pickout_coords([], _Opts) -> + {error, "A polygon must have at least four coordinates"}. +%% ----- Done ----- + diff --git a/lib/gs/src/gstk_port_handler.erl b/lib/gs/src/gstk_port_handler.erl new file mode 100644 index 0000000000..93f3e58dc2 --- /dev/null +++ b/lib/gs/src/gstk_port_handler.erl @@ -0,0 +1,465 @@ +%% +%% %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% +%% + +%% +%% ------------------------------------------------------------ +%% +%% This is a driver for the 'gstk' application modified to +%% handle events for gs. 'gstk' is a modified standalone wish. +%% +%% FIXME +%% mkdir tcl ; cd tcl +%% ( cd /usr/local/pgm/tcl-8.3.3 ; tar -cf - * ) | tar -xf - +%% ( cd /usr/local/pgm/tk-8.3.3 ; tar -cf - * ) | tar -xf - +%% rm -fr include man bin/tclsh +%% cd .. +%% tar -cf tcl.tar * +%% +%% ------------------------------------------------------------ + +-module(gstk_port_handler). + +-include("gstk.hrl"). + +% The executable can have many names. There is not always +% a plain "wish" program. +% FIXME There has to be a better solution.... +% FIXME Add option in app file or environmen variable. + +-define(WISHNAMES, ["wish85","wish8.5", + "wish84","wish8.4", + "wish83","wish8.3", + "wish82","wish8.2", + "wish"]). + +%% ------------------------------------------------------------ +%% DEBUG FUNCTIONS +%% ------------------------------------------------------------ +-export([exec/1,call/2, + start_link/1,init/2,ping/1,stop/1]). +-export([wait_for_connection/2]). + +-define(START_TIMEOUT , 1000 * 30). +-define(ACCEPT_TIMEOUT, 1000 * 20). + +-define(DEBUGLEVEL, 4). + +-ifdef(DEBUG). + +-define(DBG(DbgLvl,Format, Data),dbg(DbgLvl, Format, Data)). +-define(DBG_STR(DbgLvl, What, Str),dbg_str(DbgLvl, What, Str)). + +dbg(DbgLvl, Format, Data) when DbgLvl =< ?DEBUGLEVEL -> + ok = io:format("DBG: " ++ Format, Data); +dbg(_DbgLvl, _Format, _Data) -> ok. + +dbg_str(DbgLvl, What, Str) when DbgLvl =< ?DEBUGLEVEL -> + ok = io:format("DBG: ~s~s\n", [What,dbg_s(Str)]); +dbg_str(_DbgLvl, _What, _Data) -> ok. + +dbg_s([]) -> + []; +dbg_s([C | Str]) when list(C) -> + [dbg_s(C) | dbg_s(Str)]; +dbg_s([C | Str]) when C >= 20, C < 255 -> + [C | dbg_s(Str)]; +dbg_s([$\n | Str]) -> + ["\\n" | dbg_s(Str)]; +dbg_s([$\r | Str]) -> + ["\\r" | dbg_s(Str)]; +dbg_s([$\t | Str]) -> + ["\\t" | dbg_s(Str)]; +dbg_s([C | Str]) when integer(C) -> + [io_lib:format("\\~.3.0w",[C]) | dbg_s(Str)]. + +-else. + +-define(DBG(DbgLvl,Format, Data), true). +-define(DBG_STR(DbgLvl, What, Str), true). + +-endif. + +%% ------------------------------------------------------------ +%% INTERFACE FUNCTIONS +%% ------------------------------------------------------------ + +% Note: gs is not a true application so this doesn't work :-( +% Communication protocol between Erlang backend and wish program +% that can be set in the application environment, e.i. tested +% with "erl -gs backend_comm socket" +% +% backend_comm = socket | port +% +% We fake reading the application variables from the command line. +% Note that multiple -gs arguments can't be used. + +get_env(App, KeyAtom) -> + KeyStr = atom_to_list(KeyAtom), + ?DBG(1,"Result from init:get_argument(~w): ~p\n", + [KeyAtom,init:get_argument(App)]), + case init:get_argument(App) of + {ok,[[KeyStr,ValStr]]} -> + {ok,list_to_atom(ValStr)}; + _ -> + undefined + end. + +start_link(Gstk) -> + ?DBG(1, "start_link(~w)~n", [Gstk]), +% io:format("STARTS ~p\n",[erlang:localtime()]), + Mode = + % FIXME: Want to use application:get_env() if we where an true app + case {os:type(),get_env(gs,backend_comm)} of + {{win32,_Flavor},undefined} -> + use_socket; + {_OS,undefined} -> + use_port; + {_OS,{ok,socket}} -> + use_socket; + {_OS,{ok,port}} -> + use_port + end, + ?DBG(1,"We use mode: ~w (~w)\n",[Mode,get_env(gs,backend_comm)]), + Pid = spawn_link(gstk_port_handler, init, [Gstk,Mode]), + receive + {Pid, ok} -> + {ok, Pid}; + {Pid, error, Reason} -> + {error, Reason} + after ?START_TIMEOUT -> + {error, timeout} + end. + +call(PortHandler, Cmd) -> + PortHandler ! {call, ["erlcall {",Cmd,$}]}, + receive + {result, Result} -> + ?DBG(1, "call reply: ~p~n", [Result]), + {result, Result}; + {bad_result, Bad_Result} -> + ?DBG(1, "bad call reply: ~p~n", [Bad_Result]), + {bad_result, Bad_Result} + end. + +ping(PortHandler) -> + ?DBG(1, "ping~n", []), + PortHandler ! {ping, self()}, + receive + {pong,_From,PortOrSock} -> {ok,PortOrSock} + end. + +stop(PortHandler) -> + ?DBG(1, "stop~n", []), + PortHandler ! {stop,self()}, + receive + {stopped,PortHandler} -> ok + end. + +%% Purpose: asyncron call to tk +%% too expensive +% FIXME +exec(Cmd) -> + get(port_handler) ! {exec, ["erlexec {",Cmd,$}]}, + ok. + +% in gstk context, but I don't want "ifndef nt40" in other +% modules than this one. +%exec(Cmd) -> +% ?DBG_STR(1, "", ["erlexec {",Cmd,"}"]), +% case get(port) of +% {socket,Sock} -> +% gen_tcp:send(Sock, ["erlexec {",Cmd,$}]); +% {port,Port} -> +% Port ! {get(port_handler),{command,["erlexec {",Cmd,$}]}} +% end, +% ok. + +%% =========================================================================== +%% The server +%% =========================================================================== + +%% --------------------------------------------------------------------- +%% We initiate by starting the wish port program and use the pipe +%% or a socket to communicate with it. +%% +%% gstk: is the pid of the gstk process that started me. +%% all my input (from the port) is forwarded to it. +%%---------------------------------------------------------------------- +-record(state,{out,gstk}). + +init(Gstk, Mode) -> + process_flag(trap_exit,true), + + % ------------------------------------------------------------ + % Set up paths + % ------------------------------------------------------------ + + PrivDir = code:priv_dir(gs), + TclDir = filename:join(PrivDir,"tcl"), + TclBinDir = filename:join(TclDir,"bin"), + TclLibDir = filename:join(TclDir,"lib"), + + InitScript = filename:nativename(filename:join(PrivDir,"gstk.tcl")), + + ?DBG(1, "TclBinDir : ~s\n", [TclBinDir]), + ?DBG(1, "TclLibDir : ~s\n", [TclLibDir]), + ?DBG(1, "InitScript : ~s\n", [InitScript]), + + % ------------------------------------------------------------ + % Search for wish in priv and in system search path + % ------------------------------------------------------------ + + {Wish,Options} = + case filelib:wildcard(filename:join(TclBinDir,"wish*")) of + % If more than one wish in priv we assume they are the same + [PrivWish | _] -> + % ------------------------------------------------ + % We have to set TCL_LIBRARY and TK_LIBRARY because else + % 'wish' will search in the original installation directory + % for 'tclIndex' and this may be an incompatible version on + % the host we run on. + % ------------------------------------------------ + + [TclLibrary] = + filelib:wildcard(filename:join(PrivDir, + "tcl/lib/tcl[1-9]*")), + [TkLibrary] = + filelib:wildcard(filename:join(PrivDir, + "tcl/lib/tk[1-9]*")), + + Opts = [{env,[{"TCL_LIBRARY", TclLibrary}, + {"TK_LIBRARY", TkLibrary}, + {"LD_LIBRARY_PATH",TclLibDir}]}, + {packet,4}], + {PrivWish,Opts}; + _ -> + % We use the system wish program + {search_wish(?WISHNAMES, Gstk),[{packet,4}]} + end, + + + ?DBG(1, "Wish : ~s\n", [Wish]), + + Cmd = + case Mode of + use_socket -> + % ------------------------------------------------------------ + % Set up a listening socket and call accept in another process + % ------------------------------------------------------------ + SocketOpts = + [ + {nodelay, true}, + {packet,4}, + {reuseaddr,true} + ], + % Let OS pick a number + {ok,ListenSocket} = gen_tcp:listen(0, SocketOpts), + {ok,ListenPort} = inet:port(ListenSocket), + + % Wait in another process + spawn_link(?MODULE,wait_for_connection,[self(),ListenSocket]), + lists:concat([Wish," ",InitScript," -- ",PrivDir," ", + ListenPort]); + use_port -> + lists:concat([Wish," ",InitScript," -- ",PrivDir]) + end, + + ?DBG(1, "Port opts :\n~p\n", [Options]), + + % FIXME remove timing if not debugging + Port = + case timer:tc(erlang,open_port,[{spawn, Cmd}, Options]) of + {_T,Port1} when is_port(Port1) -> + ?DBG(1,"open_port takes ~p milliseconds\n",[_T/1000]), + link(Port1), + Port1; + {_T,{error,_Reason1}} -> % FIXME: Why throw away reason?! + ?DBG(1,"ERROR: ~p\n",[_Reason1]), + Gstk ! {self(), error, backend_died}, + exit(normal) + end, + + State = + case Mode of + use_socket -> + % ------------------------------------------------------------ + % Wait for a connection + % ------------------------------------------------------------ + Sock = + receive + {connected,Socket} -> + Socket; + % FIXME: Why throw away reason?! + {'EXIT', _Pid, _Reason2} -> + Gstk ! {self(), error, backend_died}, + exit(normal) + end, + + ?DBG(1,"Got socket ~p~n",[Sock]), + #state{out={socket,Sock}, gstk=Gstk}; + use_port -> + #state{out={port,Port}, gstk=Gstk} + end, + + Gstk ! {self(), ok}, % Tell caller we are prepared + idle(State). + +search_wish([], Gstk) -> + Gstk ! {self(), error, backend_died}, + exit(normal); +search_wish([WishName | WishNames], Gstk) -> + case os:find_executable(WishName) of + false -> + search_wish(WishNames, Gstk); + Wish -> + Wish + end. + +%%---------------------------------------------------------------------- +%% If we use sockets we wait for connection from port prog +%%---------------------------------------------------------------------- + +wait_for_connection(CallerPid, ListenSocket) -> + {ok,Sock} = gen_tcp:accept(ListenSocket, ?ACCEPT_TIMEOUT), + ?DBG(1,"Got accept ~p~p~n",[self(),Sock]), + ok = gen_tcp:controlling_process(Sock,CallerPid), + CallerPid ! {connected,Sock}. + +%% =========================================================================== +%% The main loop +%% =========================================================================== + +idle(State) -> + ?DBG(1, "idle~n", []), +% io:format("IDLE ~p\n",[erlang:localtime()]), + receive + + {call, Cmd} -> + output(State, Cmd), + idle(State); + + {exec, Cmd} -> + collect_exec_calls(Cmd, [], 0, State), + idle(State); + + {_Port, {data, Input}} -> + ?DBG_STR(2, "INPUT[port]: ", [Input]), + handle_input(State, Input), + idle(State); + + {tcp, _Sock, Input} -> + ?DBG_STR(2, "INPUT[sock]: ", [Input]), + handle_input(State, Input), + idle(State); + + {ping,From} -> + From ! {pong,self(),State#state.out}, + idle(State); + + {stop,From} -> + From ! {stopped,self()}; + + % FIXME: We are we not to terminate if watforsocket + % terminated but what about the port??????? + {'EXIT',_Pid,normal} -> + ?DBG(1, "EXIT[~w]: normal~n", [_Pid]), + idle(State); + + {'EXIT',Pid,Reason} -> + %%io:format("Port died when in idle loop!~n"), + ?DBG(1,"EXIT[~w]~n~p~n",[Pid,Reason]), + exit({port_handler,Pid,Reason}); + + Other -> + ?DBG(1,"OTHER: ~p~n",[Other]), + gs:error("gstk_port_handler: got other: ~w~n",[Other]), + idle(State) + end. + +%% ---------------------------------------------------------------------- + +-define(MAXQUEUE, 4). % FIXME find value... + +collect_exec_calls(Cmd, Queue, QueueLen, State) when QueueLen < ?MAXQUEUE -> + receive + {exec, NewCmd} -> +% io:format("collect~p~n", [NewCmd]), + collect_exec_calls(NewCmd, [Cmd | Queue], QueueLen+1, State) + after 0 -> + if + QueueLen == 0 -> + output(State, Cmd); + true -> + output(State, join_cmd_reverse(Cmd, Queue, [])) + end + end; +collect_exec_calls(Cmd, Queue, _QueueLen, State) -> % Queue is full, output + String = join_cmd_reverse(Cmd, Queue, []), +% io:format("queue full: ~p~n", [String]), + output(State, String). + + +join_cmd_reverse(Cmd, [], DeepStr) -> + [DeepStr | Cmd]; +join_cmd_reverse(Cmd, [Cmd1 | Cmds], DeepStr) -> + join_cmd_reverse(Cmd, Cmds, [Cmd1,$; | DeepStr]). + +%% ---------------------------------------------------------------------- +%% +%% Handle incoming data +%% 1 - Event +%% 2 - Reply from call +%% 3 - Bad reply from call +%% 4 - Error +%% 5 - End of message +%% + +handle_input(State,[Type | Data]) -> + GstkPid = State#state.gstk, + case Type of + 1 -> + handle_event(GstkPid,Data); + + 2 -> + GstkPid ! {result, Data}; + + 3 -> + GstkPid ! {bad_result, Data}; + + 4 -> + gs:error("gstk_port_handler: error in input : ~s~n",[Data]) + end. + +%% ---------------------------------------------------------------------- +%% output a command to the port +%% buffer several incoming execs +%% +output(#state{out = {socket,Sock}}, Cmd) -> + ?DBG_STR(1, "OUTPUT[sock]: ", [Cmd]), + ok = gen_tcp:send(Sock, Cmd); + +output(#state{out = {port,Port}}, Cmd) -> + ?DBG_STR(1, "OUTPUT[port]: ", [Cmd]), + Port ! {self(), {command, Cmd}}. + +% FIXME why test list? +handle_event(GstkPid, Bytes) when is_list(Bytes) -> + Event = tcl2erl:parse_event(Bytes), + ?DBG(1,"Event = ~p\n",[Event]), + gstk:event(GstkPid, Event). %% Event is {ID, Etag, Args} diff --git a/lib/gs/src/gstk_radiobutton.erl b/lib/gs/src/gstk_radiobutton.erl new file mode 100644 index 0000000000..fac150e010 --- /dev/null +++ b/lib/gs/src/gstk_radiobutton.erl @@ -0,0 +1,342 @@ +%% +%% %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 Radiobutton Type +%% ------------------------------------------------------------ + +-module(gstk_radiobutton). + +%%------------------------------------------------------------------------------ +%% RADIOBUTTON OPTIONS +%% +%% Attributes: +%% activebg Color +%% activefg Color +%% align n,w,s,e,nw,se,ne,sw,center +%% anchor n,w,s,e,nw,se,ne,sw,center +%% bg Color +%% bw Int +%% data Data +%% disabledfg Color +%% enable Bool +%% fg Color +%% group Atom +%% groupid Groupid +%% height Int +%% highlightbg Color +%% highlightbw Int +%% highlightfg Color +%% justify left|right|center +%% label {text, String} | {image, BitmapFile} +%% padx Int (Pixels) +%% pady Int (Pixels) +%% relief Relief [flat|raised|sunken|ridge|groove] +%% selectbg Color +%% underline Int +%% value Atom +%% width Int +%% wraplength Int +%% x Int +%% y Int +%% +%% Commands: +%% flash +%% invoke +%% select Bool +%% setfocus Bool +%% +%% Events: +%% buttonpress [Bool | {Bool, Data}] +%% buttonrelease [Bool | {Bool, Data}] +%% click [Bool | {Bool, Data}] +%% configure [Bool | {Bool, Data}] +%% destroy [Bool | {Bool, Data}] +%% enter [Bool | {Bool, Data}] +%% focus [Bool | {Bool, Data}] +%% keypress [Bool | {Bool, Data}] +%% keyrelease [Bool | {Bool, Data}] +%% leave [Bool | {Bool, Data}] +%% motion [Bool | {Bool, Data}] +%% +%% Read Options: +%% children +%% id +%% parent +%% type +%% +%% Not Implemented: +%% cursor ?????? +%% focus ?????? (-takefocus) +%% font ?????? +%% + +-export([create/3,config/3,read/3,delete/2,event/5,option/5,read_option/5]). + +-include("gstk.hrl"). + +%%------------------------------------------------------------------------------ +%% MANDATORY INTERFACE FUNCTIONS +%%------------------------------------------------------------------------------ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : create/3 +%% Purpose : Create a widget of the type defined in this module. +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +create(DB, GstkId, Opts) -> + TkW = gstk_generic:mk_tkw_child(DB,GstkId), + {G, GID, V, NOpts} = fix_group_and_value(Opts, DB, GstkId#gstkid.owner), + NGstkId=GstkId#gstkid{widget=TkW,widget_data={G, GID, V}}, + PlacePreCmd = [";place ", TkW], + case gstk_generic:make_command(NOpts, NGstkId, TkW, "", PlacePreCmd, DB) of + {error,Reason} -> {error,Reason}; + Cmd when is_list(Cmd) -> + gstk:exec(["radiobutton ", TkW," -bo 2 -indi true ",Cmd]), + NGstkId + end. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : config/3 +%% Purpose : Configure a widget of the type defined in this module. +%% Args : DB - The Database +%% Gstkid - The gstkid of the widget +%% Opts - A list of options for configuring the widget +%% +%% Return : [true | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +config(DB, Gstkid, Opts) -> + TkW = Gstkid#gstkid.widget, + {NOpts, NGstkid} = fix_group_and_value(Opts, DB, Gstkid#gstkid.owner, Gstkid), + SimplePreCmd = [TkW, " conf"], + PlacePreCmd = [";place ", TkW], + gstk_generic:mk_cmd_and_exec(NOpts,NGstkid,TkW,SimplePreCmd,PlacePreCmd,DB). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : read/3 +%% Purpose : Read one option from a widget +%% Args : DB - The Database +%% Gstkid - The gstkid of the widget +%% Opt - An option to read +%% +%% Return : [OptionValue | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +read(DB, Gstkid, Opt) -> + gstk_generic:read_option(DB, Gstkid, Opt). + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : delete/2 +%% Purpose : Delete widget from databas and return tkwidget to destroy +%% Args : DB - The Database +%% Gstkid - The gstkid of the widget +%% +%% Return : TkWidget to destroy +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +delete(DB, Gstkid) -> + gstk_db:delete_widget(DB, Gstkid), + {_, Gid, _} = Gstkid#gstkid.widget_data, + gstk_db:delete_bgrp(DB, Gid), + Gstkid#gstkid.widget. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : event/5 +%% Purpose : Construct the event and send it to the owner of the widget +%% Args : DB - The Database +%% Gstkid - The gstkid of the widget +%% Etype - The event type +%% Edata - The event data +%% Args - The data from tcl/tk +%% +%% Return : [true | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +event(DB, Gstkid, Etype, Edata, Args) -> + Arg2 = case Etype of + click -> + [Text, _Grp | Rest] = Args, + {G, _Gid, V} = Gstkid#gstkid.widget_data, + [Text, G, V | Rest]; + _Other -> + Args + end, + gstk_generic:event(DB, Gstkid, Etype, Edata, Arg2). + + + +%%------------------------------------------------------------------------------ +%% MANDATORY FUNCTIONS +%%------------------------------------------------------------------------------ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : option/4 +%% Purpose : Take care of options +%% Args : Option - An option tuple +%% Gstkid - The gstkid of the widget +%% TkW - The tk-widget +%% DB - The Database +%% +%% Return : A tuple {OptionType, OptionCmd} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +option(Option, Gstkid, TkW, DB,_) -> + case Option of + {disabledfg, Color} -> {s, [" -disabledforegr ", gstk:to_color(Color)]}; + {group, Group} -> {s, [" -var ", gstk:to_ascii(Group)]}; + {selectbg, Color} -> {s, [" -selectc ", gstk:to_color(Color)]}; + {underline, Int} -> {s, [" -un ", gstk:to_ascii(Int)]}; + {value, V} -> {s, [" -val ", gstk:to_ascii(V)]}; + {wraplength, Int} -> {s, [" -wr ", gstk:to_ascii(Int)]}; + flash -> {c, [TkW, " f;"]}; + invoke -> {c, [TkW, " i;"]}; + {select, true} -> {c, [TkW, " se;"]}; + {select, false} -> {c, [TkW, " des;"]}; + {click, On} -> cbind(DB, Gstkid, click, On); + _ -> invalid_option + end. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : read_option/4 +%% Purpose : Take care of a read option +%% Args : DB - The Database +%% Gstkid - The gstkid of the widget +%% Option - An option +%% +%% Return : The value of the option or invalid_option +%% [OptionValue | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +read_option(Option,Gstkid, TkW,DB,_) -> + case Option of + disabledfg -> tcl2erl:ret_color([TkW," cg -disabledforegr"]); + group -> {G, _, _} = Gstkid#gstkid.widget_data, G; + groupid -> {_, Gid, _} = Gstkid#gstkid.widget_data, Gid; + selectbg -> tcl2erl:ret_color([TkW," cg -selectc"]); + underline -> tcl2erl:ret_int([TkW," cg -un"]); + value -> {_, _, V} = Gstkid#gstkid.widget_data, V; + wraplength -> tcl2erl:ret_int([TkW," cg -wr"]); + + select -> + Cmd = ["list [set x [",TkW," cg -var];global $x;set $x] [", + TkW," cg -val]"], + case tcl2erl:ret_tuple(Cmd) of + {X, X} -> true; + _Other -> false + end; + + click -> gstk_db:is_inserted(DB, Gstkid, click); + _ -> {bad_result, {Gstkid#gstkid.objtype, invalid_option, Option}} + end. + +%%------------------------------------------------------------------------------ +%% PRIMITIVES +%%------------------------------------------------------------------------------ + +%% create version +fix_group_and_value(Opts, DB, Owner) -> + {G, GID, V, NOpts} = fgav(Opts, erlNIL, erlNIL, erlNIL, []), + RV = case V of + erlNIL -> list_to_atom(lists:concat([v,gstk_db:counter(DB,value)])); + Other0 -> Other0 + end, + NG = case G of + erlNIL -> rb; + Other1 -> Other1 + end, + RGID = case GID of + erlNIL -> {rbgrp, NG, Owner}; + Other2 -> Other2 + end, + RG = gstk_db:insert_bgrp(DB, RGID), + {NG, RGID, RV, [{group, RG}, {value, RV} | NOpts]}. + +%% config version +fix_group_and_value(Opts, DB, Owner, Gstkid) -> + {RG, RGID, RV} = Gstkid#gstkid.widget_data, + {G, GID, V, NOpts} = fgav(Opts, RG, RGID, RV, []), + case {G, GID, V} of + {RG, RGID, RV} -> + {NOpts, Gstkid}; + {NG, RGID, RV} -> + NGID = {rbgrp, NG, Owner}, + gstk_db:delete_bgrp(DB, RGID), + NRG = gstk_db:insert_bgrp(DB, NGID), + NGstkid = Gstkid#gstkid{widget_data={NG,NGID,RV}}, + gstk_db:insert_widget(DB, NGstkid), + {[{group, NRG} | NOpts], NGstkid}; + {RG, RGID, NRV} -> + NGstkid = Gstkid#gstkid{widget_data={RG,RGID,NRV}}, + gstk_db:insert_widget(DB, NGstkid), + {[{value,NRV} | NOpts], NGstkid}; + {_, NGID, RV} when NGID =/= RGID -> + gstk_db:delete_bgrp(DB, RGID), + NRG = gstk_db:insert_bgrp(DB, NGID), + NGstkid = Gstkid#gstkid{widget_data={RG,NGID,RV}}, + gstk_db:insert_widget(DB, NGstkid), + {[{group, NRG} | NOpts], NGstkid}; + {_, NGID, NRV} when NGID =/= RGID -> + gstk_db:delete_bgrp(DB, RGID), + NRG = gstk_db:insert_bgrp(DB, NGID), + NGstkid = Gstkid#gstkid{widget_data={RG,NGID,NRV}}, + gstk_db:insert_widget(DB, NGstkid), + {[{group, NRG}, {value,NRV} | NOpts], NGstkid}; + {NG, RGID, NRV} -> + NGID = {rbgrp, NG, Owner}, + gstk_db:delete_bgrp(DB, RGID), + NRG = gstk_db:insert_bgrp(DB, NGID), + NGstkid = Gstkid#gstkid{widget_data={NG,NGID,NRV}}, + gstk_db:insert_widget(DB, NGstkid), + {[{group, NRG}, {value,NRV} | NOpts], NGstkid} + end. + + + +fgav([{group, G} | Opts], _, GID, V, Nopts) -> + fgav(Opts, G, GID, V, Nopts); + +fgav([{groupid, GID} | Opts], G, _, V, Nopts) -> + fgav(Opts, G, GID, V, Nopts); + +fgav([{value, V} | Opts], G, GID, _, Nopts) -> + fgav(Opts, G, GID, V, Nopts); + +fgav([Opt | Opts], G, GID, V, Nopts) -> + fgav(Opts, G, GID, V, [Opt | Nopts]); + +fgav([], Group, GID, Value, Opts) -> + {Group, GID, Value, Opts}. + +%% +%% Config bind +%% +cbind(DB, Gstkid, Etype, On) -> + TkW = Gstkid#gstkid.widget, + Cmd = case On of + {true, Edata} -> + Eref = gstk_db:insert_event(DB, Gstkid, Etype, Edata), + [" -command {erlsend ", Eref, + " \\\"[", TkW, " cg -text]\\\" [", TkW, " cg -var]}"]; + true -> + Eref = gstk_db:insert_event(DB, Gstkid, Etype, ""), + [" -command {erlsend ", Eref, + " \\\"[", TkW, " cg -text]\\\" [", TkW, " cg -var]}"]; + _Other -> + gstk_db:delete_event(DB, Gstkid, Etype), + " -command {}" + end, + {s, Cmd}. + +%% ----- Done ----- + diff --git a/lib/gs/src/gstk_rectangle.erl b/lib/gs/src/gstk_rectangle.erl new file mode 100644 index 0000000000..1e02977c9a --- /dev/null +++ b/lib/gs/src/gstk_rectangle.erl @@ -0,0 +1,184 @@ +%% +%% %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 Rectangle Type +%% ------------------------------------------------------------ + +-module(gstk_rectangle). + +%%----------------------------------------------------------------------------- +%% RECTANGLE OPTIONS +%% +%% Attributes: +%% bw Int +%% coords [{X1,Y1}, {X2,Y2}] +%% data Data +%% fg Color +%% fill Color +%% stipple Bool +%% +%% Commands: +%% lower +%% move {Dx, Dy} +%% raise +%% scale {Xo, Yo, Sx, Sy} +%% setfocus Bool +%% +%% Events: +%% buttonpress [Bool | {Bool, Data}] +%% buttonrelease [Bool | {Bool, Data}] +%% enter [Bool | {Bool, Data}] +%% keypress [Bool | {Bool, Data}] +%% keyrelease [Bool | {Bool, Data}] +%% leave [Bool | {Bool, Data}] +%% motion [Bool | {Bool, Data}] +%% +%% Read Options: +%% children +%% id +%% parent +%% type +%% + + +-export([create/3, config/3, read/3, delete/2, destroy/3, event/5, + option/5,read_option/5]). + +-include("gstk.hrl"). + +%%----------------------------------------------------------------------------- +%% MANDATORY INTERFACE FUNCTIONS +%%----------------------------------------------------------------------------- +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : create/7 +%% Purpose : Create a widget of the type defined in this module. +%% Args : DB - The Database +%% Objmod - An atom, this module +%% Objtype - An atom, the logical widget type +%% Owner - Pid of the creator +%% Name - An atom naming the widget +%% Parent - Gsid of the parent +%% Opts - A list of options for configuring the widget +%% +%% Return : [Gsid_of_new_widget | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +create(DB,Gstkid, Opts) -> + case gstk_canvas:pickout_coords(Opts, [],rectangle,2) of + {error, Error} -> + {bad_result, Error}; + {Coords, NewOpts} -> + gstk_db:insert_opt(DB,Gstkid,gs:pair(coords,Opts)), + Ngstkid=gstk_canvas:upd_gstkid(DB, Gstkid, Opts), + #gstkid{widget=CanvasTkW}=Ngstkid, + MCmd = [CanvasTkW, " create re ", Coords], + gstk_canvas:mk_cmd_and_call(NewOpts, Ngstkid,CanvasTkW, MCmd, DB) + end. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : config/3 +%% Purpose : Configure a widget of the type defined in this module. +%% Return : [true | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +config(DB, Gstkid, Opts) -> + gstk_canvas:item_config(DB, Gstkid, Opts). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : read/3 +%% Purpose : Read one option from a widget +%% Args : DB - The Database +%% Gstkid - The gstkid of the widget +%% Opt - An option to read +%% +%% Return : [OptionValue | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +read(DB, Gstkid, Opt) -> + Item = Gstkid#gstkid.widget_data, + gstk_generic:read_option(DB,Gstkid,Opt,[gstk:to_ascii(Item)]). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : delete/2 +%% Purpose : Delete widget from databas and return tkwidget to destroy +%% Args : DB - The Database +%% Gstkid - The gstkid of the widget +%% +%% Return : TkWidget to destroy | {Parent, Objmod, Args}. +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +delete(DB, Gstkid) -> + gstk_canvas:item_delete_impl(DB,Gstkid). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : destroy/3 +%% Purpose : Destroy a widget +%% Args : DB - The Database +%% Canvas - The canvas tk widget +%% Item - The item number to destroy +%% +%% Return : [true | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +destroy(_DB, Canvas, Item) -> + gstk:exec([Canvas, " delete ", gstk:to_ascii(Item)]). + + +event(DB, Gstkid, Etype, Edata, Args) -> + gstk_generic:event(DB, Gstkid, Etype, Edata, Args). + +%%------------------------------------------------------------------------------ +%% MANDATORY FUNCTIONS +%%------------------------------------------------------------------------------ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : option/5 +%% Purpose : Take care of options +%% Args : Option - An option tuple +%% Gstkid - The gstkid of the widget +%% MainW - The main tk-widget +%% Canvas - The canvas tk-widget +%% DB - The Database +%% +%% Return : A tuple {OptionType, OptionCmd} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +option(Option, _Gstkid, _Canvas, _DB, _AItem) -> + case Option of + {bw, Int} -> {s, [" -w ", gstk:to_ascii(Int)]}; + {fg, Color} -> {s, [" -outline ", gstk:to_color(Color)]}; + _ -> invalid_option + end. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : read_option/5 +%% Purpose : Take care of a read option +%% Args : DB - The Database +%% Option - An option +%% +%% Return : The value of the option or invalid_option +%% [OptionValue | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +read_option(Option, Gstkid, Canvas, _DB, AItem) -> + case Option of + bw -> tcl2erl:ret_int([Canvas, " itemcg ", AItem, " -w"]); + fg -> tcl2erl:ret_color([Canvas," itemcg ", AItem, " -outline"]); + stipple -> + tcl2erl:ret_stipple([Canvas, " itemcg ", AItem, " -stipple"]); + _ -> {bad_result, {Gstkid#gstkid.objtype, invalid_option, Option}} + end. + +%% ----- Done ----- diff --git a/lib/gs/src/gstk_scale.erl b/lib/gs/src/gstk_scale.erl new file mode 100644 index 0000000000..7a929eef94 --- /dev/null +++ b/lib/gs/src/gstk_scale.erl @@ -0,0 +1,214 @@ +%% +%% %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 Scale Type +%% ------------------------------------------------------------ + +-module(gstk_scale). + +%%------------------------------------------------------------------------- +%% SCALE OPTIONS +%% +%% Attributes: +%% activebg Color +%% anchor n,w,s,e,nw,se,ne,sw,center +%% bg Color +%% bw Int +%% data Data +%% fg Color +%% height Int +%% highlightbg Color +%% highlightbw Int +%% highlightfg Color +%% orient vertical | horizontal +%% range {From, To} +%% relief Relief [flat|raised|sunken|ridge|groove] +%% showvalue Bool +%% text String +%% width Int +%% x Int +%% y Int +%% +%% Commands: +%% enable Bool +%% pos Int +%% setfocus Bool +%% +%% Events: +%% buttonpress [Bool | {Bool, Data}] +%% buttonrelease [Bool | {Bool, Data}] +%% click [Bool | {Bool, Data}] +%% destroy [Bool | {Bool, Data}] +%% enter [Bool | {Bool, Data}] +%% focus [Bool | {Bool, Data}] +%% keypress [Bool | {Bool, Data}] +%% keyrelease [Bool | {Bool, Data}] +%% leave [Bool | {Bool, Data}] +%% motion [Bool | {Bool, Data}] +%% +%% Read Options: +%% children +%% id +%% parent +%% type +%% + +-export([create/3,config/3,read/3,delete/2,event/5, + option/5,read_option/5]). + +-include("gstk.hrl"). + +%%------------------------------------------------------------------------------ +%% MANDATORY INTERFACE FUNCTIONS +%%------------------------------------------------------------------------------ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : create/7 +%% Purpose : Create a widget of the type defined in this module. +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +create(DB, GstkId, Opts) -> + TkW = gstk_generic:mk_tkw_child(DB,GstkId), + PlacePreCmd = [";place ", TkW], + Ngstkid = GstkId#gstkid{widget=TkW}, + case gstk_generic:make_command(Opts, Ngstkid, TkW,"", PlacePreCmd, DB) of + {error,Reason} -> {error,Reason}; + Cmd when is_list(Cmd) -> + gstk:exec(["scale ", TkW,Cmd,$;,TkW, + " conf -bo 2 -sliderrelief raised -highlightth 2"]), + Ngstkid + end. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : config/3 +%% Purpose : Configure a widget of the type defined in this module. +%% Args : DB - The Database +%% Gstkid - The gstkid of the widget +%% Opts - A list of options for configuring the widget +%% +%% Return : [true | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +config(DB, Gstkid, Opts) -> + TkW = Gstkid#gstkid.widget, + SimplePreCmd = [TkW, " conf"], + PlacePreCmd = [";place ", TkW], + gstk_generic:mk_cmd_and_exec(Opts,Gstkid,TkW,SimplePreCmd,PlacePreCmd,DB). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : read/3 +%% Purpose : Read one option from a widget +%% Args : DB - The Database +%% Gstkid - The gstkid of the widget +%% Opt - An option to read +%% +%% Return : [OptionValue | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +read(DB, Gstkid, Opt) -> + gstk_generic:read_option(DB, Gstkid, Opt). + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : delete/2 +%% Purpose : Delete widget from databas and return tkwidget to destroy +%% Args : DB - The Database +%% Gstkid - The gstkid of the widget +%% +%% Return : TkWidget to destroy +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +delete(DB, Gstkid) -> + gstk_db:delete_widget(DB, Gstkid), + Gstkid#gstkid.widget. + +event(DB, Gstkid, Etype, Edata, Args) -> + gstk_generic:event(DB, Gstkid, Etype, Edata, Args). + +%%----------------------------------------------------------------------------- +%% MANDATORY FUNCTIONS +%%----------------------------------------------------------------------------- +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : option/4 +%% Purpose : Take care of options +%% Args : Option - An option tuple +%% TkW - The tk-widget +%% +%% Return : A tuple {OptionType, OptionCmd} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +option(Option, Gstkid, TkW, DB,_) -> + case Option of + {activebg, Color} -> {s, [" -activeb ", gstk:to_color(Color)]}; + {orient, How} -> {s, [" -or ", gstk:to_ascii(How)]}; + {range, {From, To}} -> {s, [" -fr ", gstk:to_ascii(From), + " -to ", gstk:to_ascii(To)]}; + {relief, Relief} -> {s, [" -rel ", gstk:to_ascii(Relief)]}; + {bw, Wth} -> {s, [" -bd ", gstk:to_ascii(Wth)]}; + {text, String} -> {s, [" -la ",gstk:to_ascii(String)]}; + {showvalue, Bool} -> {s, [" -showvalue ",gstk:to_ascii(Bool)]}; + {pos, Pos} -> {c, [TkW, " set ", gstk:to_ascii(Pos)]}; + {click, On} -> cbind(DB, Gstkid, click, On); + _ -> invalid_option + end. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : read_option/5 +%% Purpose : Take care of a read option +%% Args : DB - The Database +%% Gstkid - The gstkid of the widget +%% Option - An option +%% +%% Return : The value of the option or invalid_option +%% [OptionValue | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +read_option(Option,Gstkid,TkW,DB,_) -> + case Option of + activebg -> tcl2erl:ret_color([TkW," cg -activeb"]); + orient -> tcl2erl:ret_atom([TkW," cg -ori"]); + range -> + tcl2erl:ret_tuple(["list [",TkW," cg -fr] [",TkW," cg -to]"]); + bw -> tcl2erl:ret_int([TkW," cg -bd"]); + relief -> tcl2erl:ret_atom([TkW, " cg -reli"]); + text -> tcl2erl:ret_str([TkW," cg -lab"]); + showvalue -> tcl2erl:ret_bool([TkW," cg -showvalue"]); + pos -> tcl2erl:ret_int([TkW," get"]); + click -> gstk_db:is_inserted(DB, Gstkid, click); + _ -> {bad_result, {Gstkid#gstkid.objtype, invalid_option, Option}} + end. + +%%----------------------------------------------------------------------------- +%% PRIMITIVES +%%----------------------------------------------------------------------------- + + +%% +%% Config bind +%% +cbind(DB, Gstkid, Etype, On) -> + Cmd = case On of + {true, Edata} -> + Eref = gstk_db:insert_event(DB, Gstkid, Etype, Edata), + [" -command {erlsend ", Eref, "}"]; + true -> + Eref = gstk_db:insert_event(DB, Gstkid, Etype, ""), + [" -command {erlsend ", Eref, "}"]; + _Other -> + gstk_db:delete_event(DB, Gstkid, Etype), + " -command {}" + end, + {s, Cmd}. + +%% ----- Done ----- diff --git a/lib/gs/src/gstk_text.erl b/lib/gs/src/gstk_text.erl new file mode 100644 index 0000000000..1e7101d834 --- /dev/null +++ b/lib/gs/src/gstk_text.erl @@ -0,0 +1,189 @@ +%% +%% %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 Text Type +%% ------------------------------------------------------------ + +-module(gstk_text). + +%%----------------------------------------------------------------------------- +%% TEXT OPTIONS +%% +%% Attributes: +%% anchor n|w|e|s|nw|sw|ne|se|center +%% coords [{X,Y}] +%% data Data +%% fg Color +%% font Font +%% justify left | center | right +%% stipple Bool +%% text String +%% width Int (line length in characters) +%% +%% Commands: +%% lower +%% move {Dx, Dy} +%% raise +%% scale {Xo, Yo, Sx, Sy} +%% setfocus Bool +%% +%% Events: +%% buttonpress [Bool | {Bool, Data}] +%% buttonrelease [Bool | {Bool, Data}] +%% enter [Bool | {Bool, Data}] +%% keypress [Bool | {Bool, Data}] +%% keyrelease [Bool | {Bool, Data}] +%% leave [Bool | {Bool, Data}] +%% motion [Bool | {Bool, Data}] +%% +%% Read Options: +%% children +%% id +%% parent +%% type +%% +%% Not Implemented: +%% fontfamily ?????? Family +%% fontsize ?????? Size +%% style ?????? [bold,italic] +%% + +-export([create/3, config/3, read/3, delete/2, destroy/3, event/5, + option/5,read_option/5]). + +-include("gstk.hrl"). + +%%----------------------------------------------------------------------------- +%% MANDATORY INTERFACE FUNCTIONS +%%---------------------------------------------------------------------------- +create(DB, Gstkid, Opts) -> + case gstk_canvas:pickout_coords(Opts, [],text,1) of + {error, Error} -> + {bad_result, Error}; + {Coords, NewOpts} -> + Ngstkid=gstk_canvas:upd_gstkid(DB, Gstkid, Opts), + #gstkid{widget=CanvasTkW}=Ngstkid, + MCmd = [CanvasTkW, " create te ", Coords], + gstk_canvas:mk_cmd_and_call(NewOpts,Ngstkid,CanvasTkW, MCmd, DB) + end. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : config/3 +%% Purpose : Configure a widget of the type defined in this module. +%% Return : [true | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +config(DB, Gstkid, Opts) -> + gstk_canvas:item_config(DB, Gstkid, Opts). + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : read/3 +%% Purpose : Read one option from a widget +%% Args : DB - The Database +%% Gstkid - The gstkid of the widget +%% Opt - An option to read +%% +%% Return : [OptionValue | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +read(DB, Gstkid, Opt) -> + Item = Gstkid#gstkid.widget_data, + gstk_generic:read_option(DB,Gstkid,Opt,[gstk:to_ascii(Item)]). + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : delete/2 +%% Purpose : Delete widget from databas and return tkwidget to destroy +%% Args : DB - The Database +%% Gstkid - The gstkid of the widget +%% +%% Return : TkWidget to destroy | {Parent, Objmod, Args}. +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +delete(DB, Gstkid) -> + gstk_canvas:item_delete_impl(DB,Gstkid). + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : destroy/3 +%% Purpose : Destroy a widget +%% Args : DB - The Database +%% Canvas - The canvas tk widget +%% Item - The item number to destroy +%% +%% Return : [true | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +destroy(_DB, Canvas, Item) -> + gstk:exec([Canvas, " delete ", gstk:to_ascii(Item)]). + + +event(DB, Gstkid, Etype, Edata, Args) -> + gstk_generic:event(DB, Gstkid, Etype, Edata, Args). + + +%%----------------------------------------------------------------------------- +%% MANDATORY FUNCTIONS +%%----------------------------------------------------------------------------- +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : option/5 +%% Purpose : Take care of options +%% Args : Option - An option tuple +%% MainW - The main tk-widget +%% +%% Return : A tuple {OptionType, OptionCmd} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +option(Option, Gstkid, _Canvas, DB, _AItem) -> + case Option of + {anchor, How} -> {s, [" -anchor ", gstk:to_ascii(How)]}; + {fg, Color} -> {s, [" -fi ", gstk:to_color(Color)]}; + {font, Font} when is_tuple(Font) -> + gstk_db:insert_opt(DB,Gstkid,Option), + {s, [" -fo ", gstk_font:choose_ascii(DB,Font)]}; + {justify, How} -> {s, [" -j ", gstk:to_ascii(How)]}; + {text, Text} -> {s, [" -te ", gstk:to_ascii(Text)]}; + {width, Width} -> {s, [" -w ", gstk:to_ascii(Width)]}; + _ -> invalid_option + end. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : read_option/5 +%% Purpose : Take care of a read option +%% Args : DB - The Database +%% Gstkid - The gstkid of the widget +%% Option - An option +%% +%% Return : The value of the option or invalid_option +%% [OptionValue | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +read_option(Option, Gstkid, Canvas, DB, AItem) -> + case Option of + anchor -> tcl2erl:ret_atom([Canvas, " itemcg ", AItem, " -anchor"]); + fg -> tcl2erl:ret_color([Canvas, " itemcg ", AItem, " -fi"]); + font -> gstk_db:opt(DB,Gstkid,font,undefined); + justify -> tcl2erl:ret_atom([Canvas, " itemcg ", AItem, " -j"]); + stipple -> tcl2erl:ret_stipple([Canvas," itemcg ",AItem," -stipple"]); + text -> tcl2erl:ret_str([Canvas, " itemcg ", AItem, " -te"]); + width -> tcl2erl:ret_int([Canvas, " itemcg ", AItem, " -w"]); + _ -> {bad_result, {Gstkid#gstkid.objtype, invalid_option, Option}} + end. + + +%% ----- Done ----- diff --git a/lib/gs/src/gstk_widgets.erl b/lib/gs/src/gstk_widgets.erl new file mode 100644 index 0000000000..d16c0f7fea --- /dev/null +++ b/lib/gs/src/gstk_widgets.erl @@ -0,0 +1,93 @@ +%% +%% %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(gstk_widgets). + +-export([type2mod/1, objmod/1, suffix/1]). + +-include("gstk.hrl"). + + + + +%% +%% Map primitive types to modules or false (false should not be a module!) +%% +%% ordered for efficiency + +type2mod(window) -> gstk_window; +type2mod(frame) -> gstk_frame; +type2mod(button) -> gstk_button; +type2mod(canvas) -> gstk_canvas; +type2mod(checkbutton) -> gstk_checkbutton; +type2mod(rectangle) -> gstk_rectangle; +type2mod(gs) -> gstk_gs; +type2mod(grid) -> gstk_grid; +type2mod(gridline) -> gstk_gridline; +type2mod(text) -> gstk_text; +type2mod(image) -> gstk_image; +type2mod(label) -> gstk_label; +type2mod(line) -> gstk_line; +type2mod(entry) -> gstk_entry; +type2mod(listbox) -> gstk_listbox; +type2mod(editor) -> gstk_editor; +type2mod(menu) -> gstk_menu; +type2mod(menubar) -> gstk_menubar; +type2mod(menubutton) -> gstk_menubutton; +type2mod(menuitem) -> gstk_menuitem; +type2mod(message) -> gstk_message; +type2mod(oval) -> gstk_oval; +type2mod(polygon) -> gstk_polygon; +type2mod(prompter) -> gstk_prompter; +type2mod(radiobutton) -> gstk_radiobutton; +type2mod(scale) -> gstk_scale; +type2mod(scrollbar) -> gstk_scrollbar; +type2mod(arc) -> gstk_arc; +type2mod(Type) -> {error,{unknown_type, Type}}. + +objmod(#gstkid{objtype=OT}) -> type2mod(OT). + +%% +%% The suffix to add to the parent tk widget +%% +suffix(button) -> ".b"; +suffix(canvas) -> ".c"; +suffix(checkbutton) -> ".cb"; +suffix(editor) -> ".ed"; +suffix(entry) -> ".e"; +suffix(frame) -> ".f"; +suffix(label) -> ".l"; +suffix(listbox) -> ".lb"; +suffix(menu) -> ".m"; +suffix(menubar) -> ".bar"; +suffix(menubutton) -> ".mb"; +suffix(message) -> ".ms"; +suffix(prompter) -> ".p"; +suffix(radiobutton) -> ".rb"; +suffix(scale) -> ".sc"; +suffix(window) -> ".w"; +suffix(Objtype) -> apply(type2mod(Objtype), suffix, []). + + diff --git a/lib/gs/src/gstk_window.erl b/lib/gs/src/gstk_window.erl new file mode 100644 index 0000000000..acac452ed1 --- /dev/null +++ b/lib/gs/src/gstk_window.erl @@ -0,0 +1,369 @@ +%% +%% %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 Window Type. +%% ------------------------------------------------------------ + +-module(gstk_window). + +%%------------------------------------------------------------------------------ +%% WINDOW OPTIONS +%% +%% Attributes: +%% x Int +%% y Int +%% width Int +%% height Int +%% bg Color +%% bw Int +%% relief Relief [flat|raised|sunken|ridge|groove] +%% highlightbw Int +%% highlightbg Color +%% highlightfg Color +%% map Bool +%% iconify Bool +%% title String +%% iconname String +%% iconbitmap Bitmap +%% iconmask Bitmap +%% data Data +%% cursor arrow|busy|cross|hand|help|resize|text +%% +%% Commands: +%% raise +%% lower +%% setfocus Bool +%% +%% Events: +%% configure [Bool | {Bool, Data}] +%% enter [Bool | {Bool, Data}] +%% leave [Bool | {Bool, Data}] +%% motion [Bool | {Bool, Data}] +%% keypress [Bool | {Bool, Data}] +%% keyrelease [Bool | {Bool, Data}] +%% buttonpress [Bool | {Bool, Data}] +%% buttonrelease [Bool | {Bool, Data}] +%% focus [Bool | {Bool, Data}] +%% destroy [Bool | {Bool, Data}] +%% +%% Read options: +%% children +%% id +%% parent +%% type +%% +%% Not Implemented: +%% screen ????????? +%% map +%% unmap +%% iconify +%% deiconify +%% focusmodel [active|passive] (wm focusmodel) +%% + +-export([create/3, config/3, read/3, delete/2, event/5,destroy_win/1]). +-export([option/5,read_option/5,mk_create_opts_for_child/4]). + +-include("gstk.hrl"). +% bind . <1> {puts "x: [expr %X - [winfo rootx .]] y: [expr %Y - [wi rooty .]]"} + +%%----------------------------------------------------------------------------- +%% MANDATORY INTERFACE FUNCTIONS +%%----------------------------------------------------------------------------- +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : create/3 +%% Purpose : Create a widget of the type defined in this module. +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +create(DB, Gstkid, Opts) -> + TkW = gstk_generic:mk_tkw_child(DB,Gstkid), + NGstkid=Gstkid#gstkid{widget=TkW}, + case gstk_generic:make_command(transform_geometry_opts(Opts), + NGstkid, TkW, "", ";", DB) of + {error,Reason} -> {error,Reason}; + Cmd when is_list(Cmd) -> + BindCmd = gstk_generic:bind(DB, Gstkid, TkW, configure, true), +% io:format("\nWINDOW1: ~p\n",[TkW]), +% io:format("\nWINDOW1: ~p\n",[Cmd]), +% io:format("\nWINDOW1: ~p\n",[BindCmd]), + gstk:exec(["toplevel ", TkW,Cmd,$;,BindCmd]), + NGstkid + end. + +mk_create_opts_for_child(DB,Cgstkid, Pgstkid, Opts) -> + gstk_generic:mk_create_opts_for_child(DB,Cgstkid,Pgstkid,Opts). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : config/3 +%% Purpose : Configure a widget of the type defined in this module. +%% Args : DB - The Database +%% Gstkid - The gstkid of the widget +%% Opts - A list of options for configuring the widget +%% +%% Return : [true | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +config(DB, Gstkid, Opts) -> + TkW = Gstkid#gstkid.widget, + SimplePreCmd = [TkW, " conf"], + gstk_generic:mk_cmd_and_exec(transform_geometry_opts(Opts), + Gstkid,TkW,SimplePreCmd,"",DB). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : read/3 +%% Purpose : Read one option from a widget +%% Args : DB - The Database +%% Gstkid - The gstkid of the widget +%% Opt - An option to read +%% +%% Return : [OptionValue | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +read(DB, Gstkid, Opt) -> + gstk_generic:read_option(DB, Gstkid, Opt). + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : delete/2 +%% Purpose : Delete widget from databas and return tkwidget to destroy +%% Args : DB - The Database +%% Gstkid - The gstkid of the widget +%% +%% Return : TkWidget to destroy +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +delete(DB, Gstkid) -> + gstk_db:delete_widget(DB, Gstkid), + Gstkid#gstkid.widget. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : event/5 +%% Purpose : Construct the event and send it to the owner of the widget +%% Args : DB - The Database +%% Gstkid - The gstkid of the widget +%% Etype - The event type +%% Edata - The event data +%% Args - The data from tcl/tk +%% +%% Return : [true | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +event(DB, Gstkid, configure, Edata, Args) -> + [W,H|_] = Args, + gstk_db:insert_opt(DB,Gstkid,{width,W}), + gstk_db:insert_opt(DB,Gstkid,{height,H}), + case gstk_db:opt(DB,Gstkid,configure) of + true -> + apply(gstk_generic,event,[DB,Gstkid,configure,Edata,Args]); + false -> + ok + end; +event(DB, Gstkid, destroy, Edata, Args) -> + spawn(gstk_window,destroy_win,[gstk:make_extern_id(Gstkid#gstkid.id,DB)]), + gstk_generic:event(DB, Gstkid, destroy, Edata, Args); +event(DB, Gstkid, Etype, Edata, Args) -> + gstk_generic:event(DB, Gstkid, Etype, Edata, Args). + +destroy_win(ID) -> + gs:destroy(ID). +%%------------------------------------------------------------------------------ +%% MANDATORY FUNCTIONS +%%------------------------------------------------------------------------------ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : option/4 +%% Purpose : Take care of options +%% Args : Option - An option tuple +%% Gstkid - The gstkid of the widget +%% TkW - The tk-widget +%% DB - The Database +%% +%% Return : A tuple {OptionType, OptionCmd} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%-define(REGEXP,"regexp {(\\d+)x(\\d+)\\+?(-?\\d+)\\+?(-?\\d+)} "). +% FIXME: Is this ok? Always positive? +-define(REGEXP,"regexp {(\\d+)x(\\d+)\\+(\\d+)\\+(\\d+)} "). + +option(Option, Gstkid, TkW, DB,_) -> + case Option of +%% Bug in tcl/tk complicates setting of a single x,y,width,height. + {x, X} -> + {c, + [?REGEXP,"[wm ge ",TkW, "] g w h x y;wm ge ", TkW, + " ${w}x$h",signed(X),"+$y;update idletasks"]}; + {y, Y} -> + {c,[?REGEXP,"[wm ge ",TkW, "] g w h x y;wm ge ", TkW, + " ${w}x$h+$x",signed(Y),"; update idletasks"]}; + {width, Width} when Width >= 0 -> % FIXME: Needed test? + case gstk_db:opt_or_not(DB,Gstkid,width) of + {value,Width} -> none; + _Q -> + gstk_db:insert_opt(DB,Gstkid,{width,Width}), + {c,[?REGEXP,"[wm ge ",TkW, "] g w h x y;wm ge ", TkW," ", + gstk:to_ascii(Width),"x$h+$x+$y;update idletasks"]} + end; + {height, Height} when Height >= 0 -> % FIXME: Needed test? + case gstk_db:opt_or_not(DB,Gstkid,height) of + {value,Height} -> none; + _Q -> % FIXME: Why different? + gstk_db:insert_opt(DB,Gstkid,{height,Height}), + {c, + ["wm ge ",TkW, + " [winfo w ", TkW, "]x",gstk:to_ascii(Height), + ";update idletasks"]} + end; + {width_height, {W,H}} when W >= 0, H >= 0 -> + case {gstk_db:opt_or_not(DB,Gstkid,width), + gstk_db:opt_or_not(DB,Gstkid,height)} of + {{value,W},{value,H}} -> + none; + _OtherSize -> + gstk_db:insert_opt(DB,Gstkid,{height,H}), + gstk_db:insert_opt(DB,Gstkid,{width,W}), + {c, ["update idletasks;wm ge ", TkW, " ", + gstk:to_ascii(W),"x",gstk:to_ascii(H), + ";update idletasks"]} + end; + {xy, {X,Y}} -> + {c, [?REGEXP,"[wm ge ",TkW, "] g w h x y;wm ge ", TkW, + " ${w}x$h", signed(X),signed(Y), + ";update idletasks"]}; + {bg, Color} -> {s, [" -bg ", gstk:to_color(Color)]}; + {map, true} -> {c, ["wm deiconify ", TkW]}; + {map, false} -> {c, ["wm withdraw ", TkW]}; + {configure, On} -> + gstk_db:insert_opt(DB,Gstkid,{configure,On}), + none; + {iconify, true} -> {c, ["wm iconify ", TkW]}; + {iconify, false} -> {c, ["wm deiconify ", TkW]}; + {title, Title} -> {c, ["wm title ", TkW, " " , + gstk:to_ascii(Title)]}; + {iconname, Name} -> {c, ["wm iconn ",TkW, " ", + gstk:to_ascii(Name)]}; + {iconbitmap, Bitmap} -> {c, ["wm iconb ",TkW, " ", + gstk:to_ascii(Bitmap)]}; + {iconmask, Bitmap} -> {c, ["wm iconm ",TkW, " ", + gstk:to_ascii(Bitmap)]}; + raise -> {c, ["raise ", TkW]}; + lower -> {c, ["lower ", TkW]}; + {setfocus, true} -> {c, ["focus ", TkW]}; + {setfocus, false} -> {c, ["focus {}"]}; + {buttonpress, On} -> + Eref = mk_eref(On, DB, Gstkid, buttonpress), + {c,["bind ",TkW," <ButtonPress> ", + event_onoff(["{erlsend ",Eref," %b ",xy_abs_str(TkW),"};"],On)]}; + {buttonrelease, On} -> + Eref = mk_eref(On, DB, Gstkid, buttonrelease), + {c,["bind ",TkW," <ButtonRelease> ", + event_onoff(["{erlsend ",Eref," %b ",xy_abs_str(TkW),"};"],On)]}; + {motion, On} -> + Eref = mk_eref(On, DB, Gstkid, motion), + {c,["bind ",TkW," <Motion> ", + event_onoff(["{erlsend ",Eref," ",xy_abs_str(TkW),"};"],On)]}; + _ -> invalid_option + end. + +xy_abs_str(TkW) -> + ["[expr %X-[winfo rootx ",TkW,"]] [expr %Y-[winfo rooty ",TkW,"]]"]. + +event_onoff(Str, true) -> Str; +event_onoff(_,false) -> "{}". + +mk_eref(false, DB, Gstkid, Etype) -> + gstk_db:delete_event(DB, Gstkid, Etype), + dummy; +mk_eref(true,DB,Gstkid,Etype) -> + gstk_db:insert_event(DB, Gstkid, Etype, []). + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : read_option/3 +%% Purpose : Take care of a read option +%% Args : DB - The Database +%% Gstkid - The gstkid of the widget +%% Option - An option +%% +%% Return : The value of the option or invalid_option +%% [OptionValue | {bad_result, Reason}] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +read_option(Option, Gstkid, TkW, DB,_) -> + case Option of + x -> tcl2erl:ret_x(geo_str(TkW)); + y -> tcl2erl:ret_y(geo_str(TkW)); + width -> tcl2erl:ret_width(geo_str(TkW)); + height -> tcl2erl:ret_height(geo_str(TkW)); + configure -> gstk_db:opt(DB,Gstkid,configure); + bg -> tcl2erl:ret_color([TkW," cg -bg"]); + map -> tcl2erl:ret_mapped(["winfo is ", TkW]); + iconify -> tcl2erl:ret_iconified(["wm st ", TkW]); + title -> tcl2erl:ret_str(["wm ti ", TkW]); + iconname -> tcl2erl:ret_str(["wm iconn ", TkW]); + iconbitmap -> tcl2erl:ret_str(["wm iconb ", TkW]); + iconmask -> tcl2erl:ret_str(["wm iconm ", TkW]); + setfocus -> tcl2erl:ret_focus(TkW, "focus"); + _ -> {bad_result, {Gstkid#gstkid.objtype, invalid_option, Option}} + end. + +geo_str(TkW) -> + ["update idletasks;",?REGEXP,"[wm geometry ", TkW, + "] g w h x y;set tmp \"$w $h $x $y\""]. + + + +%%---------------------------------------------------------------------- +%% PRIMITIVES +%%---------------------------------------------------------------------- + +%% Return {+,-}Int to be used in a geometry option +signed(X) when X>=0 -> + [$+,integer_to_list(X)]; +signed(X) when X<0 -> + integer_to_list(X). + +%%---------------------------------------------------------------------- +%% Purpose: tcl/tk: wm .window geo sets WxH+x+y at one time. +%% flushing every time is expensive. Do (almost) as much as +%% possible in one operation. +%%---------------------------------------------------------------------- +transform_geometry_opts(Opts) -> + {Geo,RestOpts} = collect_geo_opts(Opts,[],[]), + Geo2 = make_atomic(lists:sort(Geo)), + lists:append(Geo2,RestOpts). + +make_atomic([{height,H},{width,W},{x,X},{y,Y}]) -> + [{width_height,{W,H}},{xy,{X,Y}}]; +make_atomic([{height,H},{width,W}|XY]) -> + [{width_height,{W,H}}|XY]; +make_atomic([WH,{x,X},{y,Y}]) -> + [WH,{xy,{X,Y}}]; +make_atomic(L) -> L. + +%%---------------------------------------------------------------------- +%% Returns: {(list of x,y,width,height options),list of other opts} +%%---------------------------------------------------------------------- +collect_geo_opts([{x,X}|Opts],Geo,Rest) -> + collect_geo_opts(Opts,[{x,X}|Geo],Rest); +collect_geo_opts([{y,Y}|Opts],Geo,Rest) -> + collect_geo_opts(Opts,[{y,Y}|Geo],Rest); +collect_geo_opts([{height,H}|Opts],Geo,Rest) -> + collect_geo_opts(Opts,[{height,H}|Geo],Rest); +collect_geo_opts([{width,W}|Opts],Geo,Rest) -> + collect_geo_opts(Opts,[{width,W}|Geo],Rest); +collect_geo_opts([Opt|Opts],Geo,Rest) -> + collect_geo_opts(Opts,Geo,[Opt|Rest]); +collect_geo_opts([],Geo,Rest) -> {Geo,Rest}. + +%%% ----- Done ----- diff --git a/lib/gs/src/tcl2erl.erl b/lib/gs/src/tcl2erl.erl new file mode 100644 index 0000000000..8845cf0b9a --- /dev/null +++ b/lib/gs/src/tcl2erl.erl @@ -0,0 +1,457 @@ +%% +%% %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% +%% + +%% +%% ------------------------------------------------------------ +%% +%% Handle conversion from tcl string to erlang terms +%% +%% ------------------------------------------------------------ + +-module(tcl2erl). + +-export([parse_event/1, + ret_int/1, + ret_atom/1, + ret_str/1, + ret_tuple/1, + ret_pack/2, + ret_place/2, + ret_x/1, + ret_y/1, + ret_width/1, + ret_height/1, + ret_list/1, + ret_str_list/1, + ret_label/1, + ret_mapped/1, + ret_iconified/1, + ret_focus/2, + ret_file/1, + ret_bool/1, + ret_enable/1, + ret_color/1, + ret_stipple/1]). + +-include("gstk.hrl"). + + + +%% ---------------------------------------- +%% Parse an incoming event represented as +%% a list of bytes +%% +parse_event(Bytes) -> + {[$#|ID], Cont1} = first_word(Bytes), + {Etag, Cont} = first_word(Cont1), + {tokens, Toks} = scan(Cont), + {term_seq, Args}= parse_term_seq(Toks), + {list_to_integer(ID), Etag, Args}. + + +%%---first word returns {Word,Cont}---%% +first_word(Bytes) -> + fw(Bytes,[]). + +fw([],Ack) -> + {lists:reverse(Ack),[]}; +fw([$ |R],Ack) -> + {lists:reverse(Ack),R}; +fw([Char|R],Ack) -> + fw(R,[Char|Ack]). + + +%% --------------------------------------------- +%% str_to_term(Str) +%% Transforms a string to the corresponding Erlang +%% term. Note that the string "Hello" will be +%% transformed to an Erlang atom: 'Hello' . +%% If it is impossible to convert the string into +%% a term the original string is just returned. +%% str_to_term(Str) <---> {string, Str} or {term, Term} +%% 'so that we can be able to tell if conversion succeded or not.' +%% + +str_to_term(Str) -> + {tokens,Tokens} = scan(Str), + case catch parse_term(Tokens) of + {_Type, Term,[]} -> {term,Term}; + _ -> {string, Str} + end. + + +%% --------------------------------------------- +%% Simple Parser. ;-) +%% Parses tokens or fails. +%% Better catch result. +%% Tokens should be generated by scan. +%% parse_term(Toks) <----> {term, Term, Cont} +%% parse_call(Toks) <----> {call, Mod, Fun, Args, Cont} +%% parse_list(Toks) <----> {list, ListTerm, Cont} +%% parse_tuple(Toks) <----> {tuple, TupleTerm, Cont} +%% parse_fun_args(Toks) <-> {fun_args, FunArgs, Cont} %% like (arg1, arg2...) +%% parse_term_seq(Toks) <-> {term_seq, Term_Sequence} %% no continuation +%% + +parse_term([{var,Var}|R]) -> {var,Var,R}; +parse_term([{atom,Atom}|R]) -> {atom,Atom,R}; +parse_term([{float,Float}|R]) -> {float,Float,R}; +parse_term([{integer,Integer}|R]) -> {integer,Integer,R}; +parse_term([{string,String}|R]) -> {string,String,R}; +parse_term(['-',{integer,Integer}|R]) -> {integer,-Integer,R}; +parse_term(['-',{float,Float}|R]) -> {float,-Float,R}; +parse_term(['+',{integer,Integer}|R]) -> {integer,Integer,R}; +parse_term(['+',{float,Float}|R]) -> {float,Float,R}; +parse_term(['['|R]) -> {list,_Term,_C}=parse_list(['['|R]); +parse_term(['{'|R]) -> {tuple,_Term,_C}=parse_tuple(['{'|R]); +parse_term([Char|R]) -> {char,Char,R}. + +%%--- parse list --- +parse_list(['[',']'|C]) -> + {list, [], C}; +parse_list(['['|R]) -> + {list,_List,_C}= list_args(R,[]). + +list_args(Toks,Ack) -> + cont_list(parse_term(Toks),Ack). + +cont_list({_Tag, Term,[','|C]},Ack) -> + list_args(C,[Term|Ack]); +cont_list({_Tag, Term,[']'|C]},Ack) -> + {list,lists:reverse([Term|Ack]),C}. + +%%--- parse tuple --- +parse_tuple(['{','}'|C]) -> + {tuple,{}, C}; +parse_tuple(['{'|R]) -> + {tuple,_Tuple,_C}=tuple_args(R,[]). + +tuple_args(Toks,Ack) -> + cont_tuple(parse_term(Toks),Ack). + +cont_tuple({_Tag, Term,[','|C]},Ack) -> + tuple_args(C,[Term|Ack]); +cont_tuple({_Tag, Term,['}'|C]},Ack) -> + {tuple,list_to_tuple(lists:reverse([Term|Ack])),C}. + +%%--- parse sequence of terms --- +parse_term_seq(Toks) -> + p_term_seq(Toks,[]). + +p_term_seq([],Ack) -> + {term_seq, lists:reverse(Ack)}; % never any continuation left +p_term_seq(Toks,Ack) -> + {_Type,Term,C} = parse_term(Toks), + p_term_seq(C,[Term|Ack]). + + + +%% ---------------------------------------- +%% Simple Scanner + +scan(Bytes) -> + {tokens, scan(Bytes,[])}. + +scan([],Ack) -> + lists:reverse(Ack); +scan([$ |R],Ack) -> % delete whitespace + scan(R,Ack); +scan([X|R],Ack) when is_integer(X),X>=$a,X=<$z -> + scan_atom(R,[X],Ack); +scan([X|R],Ack) when is_integer(X),X>=$A,X=<$Z -> + scan_var(R,[X],Ack); +scan([X|R],Ack) when is_integer(X),X>=$0,X=<$9 -> + scan_number(R,[X],Ack); +scan([$"|R],Ack) -> + scan_string(R,[],Ack); +scan([X|R],Ack) when is_integer(X) -> + scan(R,[list_to_atom([X])|Ack]). + +scan_atom([X|R],Ack1,Ack2) when is_integer(X),X>=$a,X=<$z -> + scan_atom(R,[X|Ack1],Ack2); +scan_atom([X|R],Ack1,Ack2) when is_integer(X),X>=$A,X=<$Z -> + scan_atom(R,[X|Ack1],Ack2); +scan_atom([X|R],Ack1,Ack2) when is_integer(X),X>=$0,X=<$9 -> + scan_atom(R,[X|Ack1],Ack2); +scan_atom([$_|R],Ack1,Ack2) -> + scan_atom(R,[$_|Ack1],Ack2); +scan_atom(L,Ack1,Ack2) -> + scan(L,[{atom,list_to_atom(lists:reverse(Ack1))}|Ack2]). + +scan_var([X|R],Ack1,Ack2) when is_integer(X),X>=$a,X=<$z -> + scan_var(R,[X|Ack1],Ack2); +scan_var([X|R],Ack1,Ack2) when is_integer(X),X>=$A,X=<$Z -> + scan_var(R,[X|Ack1],Ack2); +scan_var([X|R],Ack1,Ack2) when is_integer(X),X>=$0,X=<$9 -> + scan_var(R,[X|Ack1],Ack2); +scan_var([$_|R],Ack1,Ack2) -> + scan_var(R,[$_|Ack1],Ack2); +scan_var(L,Ack1,Ack2) -> + scan(L,[{var,list_to_atom(lists:reverse(Ack1))}|Ack2]). + +scan_number([X|R],Ack1,Ack2) when is_integer(X),X>=$0,X=<$9 -> + scan_number(R,[X|Ack1],Ack2); +scan_number([$.|R],Ack1,Ack2) -> + scan_float(R,[$.|Ack1],Ack2); +scan_number(L,Ack1,Ack2) -> + scan(L,[{integer,list_to_integer(lists:reverse(Ack1))}|Ack2]). + +scan_float([X|R],Ack1,Ack2) when is_integer(X),X>=$0,X=<$9 -> + scan_float(R,[X|Ack1],Ack2); +scan_float(L,Ack1,Ack2) -> + Float = list_to_float(lists:reverse(Ack1)), + Int = trunc(Float), + if + Int==Float -> + scan(L,[{integer,Int}|Ack2]); + true -> + scan(L,[{float,Float}|Ack2]) + end. + + +scan_string([$"|R],Ack1,Ack2) -> + scan(R,[{string,lists:reverse(Ack1)}|Ack2]); +scan_string([X|R],Ack1,Ack2) when is_integer(X) -> + scan_string(R,[X|Ack1],Ack2); +scan_string([],_Ack1,_Ack2) -> + throw({error,"unterminated string."}). + + + +%% ---------- Checking Return values ----------- +%% Used by read to return a proper type or fail. + +ret_int(Str) -> + case gstk:call(Str) of + {result, Result} -> + {_,Value} = str_to_term(Result), + Value; + Bad_result -> Bad_result + end. + +ret_atom(Str) -> + case gstk:call(Str) of + {result, Result} -> + {_,Value} = str_to_term(Result), + Value; + Bad_result -> Bad_result + end. + +ret_str(Str) -> + case gstk:call(Str) of + {result, Val} -> Val; + Bad_result -> Bad_result + end. + +ret_tuple(Str) -> + case gstk:call(Str) of + {result,S} -> + {tokens,Toks} = scan(S), + {term_seq,Seq} = parse_term_seq(Toks), + list_to_tuple(Seq); + Bad_result -> Bad_result + end. + +%%---------------------------------------------------------------------- +%% Returns: Coords or error. +%%---------------------------------------------------------------------- +ret_pack(Key, TkW) -> + Str = ret_list(["pack info ", TkW]), + pick_out(Str, Key). + +ret_place(Key, TkW) -> + Str = ret_list(["place info ", TkW]), + pick_out(Str, Key). + +pick_out([Key, Value | _Rest], Key) -> Value; +pick_out([Key, {} | _Rest], Key) -> 0; +pick_out(['-' | Rest], Key) -> pick_out(Rest, Key); +pick_out([_, _ | Rest], Key) -> pick_out(Rest, Key); +pick_out(Other, _Key) -> Other. + + +ret_x(Str) -> + case ret_geometry(Str) of + {_W,_H,X,_Y} -> X; + Other -> Other + end. + +ret_y(Str) -> + case ret_geometry(Str) of + {_W,_H,_X,Y} -> Y; + Other -> Other + end. + +ret_width(Str) -> + case ret_geometry(Str) of + {W,_H,_X,_Y} -> W; + Other -> Other + end. + +ret_height(Str) -> + case ret_geometry(Str) of + {_W,H,_X,_Y} -> H; + Other -> Other + end. + + + +ret_geometry(Str) -> + case ret_tuple(Str) of + {W,H,X,Y} when is_atom(H) -> + [_|Height]=atom_to_list(H), + {W,list_to_integer(Height),X,Y}; + Other -> Other + end. + +ret_list(Str) -> + case gstk:call(Str) of + {result,S} -> + {tokens,Toks} = scan(S), + {term_seq,Seq} = parse_term_seq(Toks), + Seq; + Bad_result -> Bad_result + end. + +ret_str_list(Str) -> + case gstk:call(Str) of + {result,S} -> + mk_quotes0(S,[]); + Bad_result -> Bad_result + end. + + +ret_label(Str) -> + case ret_str_list(Str) of + [[], [$@|Img]] -> {image, Img}; + [Text, []] -> {text, Text}; + Bad_Result -> Bad_Result + end. + + + +ret_mapped(Str) -> + case ret_int(Str) of + 1 -> true; + 0 -> false; + Bad_Result -> Bad_Result + end. + + +ret_iconified(Str) -> + case ret_atom(Str) of + iconic -> true; + normal -> false; + Bad_Result -> Bad_Result + end. + + +ret_focus(W, Str) -> + case gstk:call(Str) of + {result, W} -> true; + _ -> false + end. + + +ret_file(Str) -> + case gstk:call(Str) of + {result, [$@|File]} -> File; + {result, []} -> []; + Bad_result -> Bad_result + end. + + +ret_bool(Str) -> + case ret_int(Str) of + 1 -> true; + 0 -> false; + Bad_Result -> Bad_Result + end. + +ret_enable(Str) -> + case ret_atom(Str) of + normal -> true; + active -> true; + disabled -> false; + Bad_Result -> Bad_Result + end. + + + +ret_color(Str) -> + case gstk:call(Str) of + {result,[$#,R1,G1,B1]} -> + {hex2dec([R1,$0]),hex2dec([G1,$0]),hex2dec([B1,$0])}; + {result,[$#,R1,R2,G1,G2,B1,B2]} -> + {hex2dec([R1,R2]),hex2dec([G1,G2]),hex2dec([B1,B2])}; + {result,[$#,R1,R2,_R3,G1,G2,_G3,B1,B2,_B3]} -> + {hex2dec([R1,R2]),hex2dec([G1,G2]),hex2dec([B1,B2])}; + {result,[$#,R1,R2,_R3,_R4,G1,G2,_G3,_G4,B1,B2,_B3,_B4]} -> + {hex2dec([R1,R2]),hex2dec([G1,G2]),hex2dec([B1,B2])}; + {result,[Char|Word]} when Char>=$A, Char=<$Z -> + list_to_atom([Char+32|Word]); + {result,[Char|Word]} when Char>=$a, Char=<$z -> + list_to_atom([Char|Word]); + {result,Color} -> + gs:error("error in tcl2erl:ret_color got ~w.~n",[Color]); + Bad_result -> Bad_result + end. + + +ret_stipple(Str) -> + case gstk:call(Str) of + {result, _Any} -> true; + _Other -> false + end. + + +%% ------------------------------------------------------------ +%% Hexadecimal to Decimal converter +%% + +hex2dec(Hex) -> hex2dec(Hex,0). + +hex2dec([H|T],N) when H>=$0,H=<$9 -> + hex2dec(T,(N bsl 4) bor (H-$0)); +hex2dec([H|T],N) when H>=$a,H=<$f -> + hex2dec(T,(N bsl 4) bor (H-$a+10)); +hex2dec([H|T],N) when H>=$A,H=<$F -> + hex2dec(T,(N bsl 4) bor (H-$A+10)); +hex2dec([],N) -> N. + + +mk_quotes0([${|T],Res) -> mk_quotes2(T,"",Res); +mk_quotes0([$ |T],Res) -> mk_quotes0(T,Res); +mk_quotes0([$\\,X |T],Res) -> mk_quotes1(T,[X],Res); +mk_quotes0([X|T],Res) -> mk_quotes1(T,[X],Res); +mk_quotes0([],Res) -> lists:reverse(Res). + +mk_quotes1([$}|T],Ack,Res) -> mk_quotes0(T,[lists:reverse(Ack)|Res]); +mk_quotes1([$\\,X |T],Ack,Res) -> mk_quotes1(T,[X|Ack],Res); +mk_quotes1([$ |T],Ack,Res) -> mk_quotes0(T,[lists:reverse(Ack)|Res]); +mk_quotes1([X|T],Ack,Res) -> mk_quotes1(T,[X|Ack],Res); +mk_quotes1([],Ack,Res) -> lists:reverse([lists:reverse(Ack)|Res]). + +%% grouped using {bla bla} syntax +mk_quotes2([$}|T],Ack,Res) -> mk_quotes0(T,[lists:reverse(Ack)|Res]); +mk_quotes2([$\\,X |T],Ack,Res) -> mk_quotes2(T,[X|Ack],Res); +mk_quotes2([X|T],Ack,Res) -> mk_quotes2(T,[X|Ack],Res); +mk_quotes2([],Ack,Res) -> lists:reverse([lists:reverse(Ack)|Res]). + + diff --git a/lib/gs/src/tool_file_dialog.erl b/lib/gs/src/tool_file_dialog.erl new file mode 100644 index 0000000000..6b2c2e8c81 --- /dev/null +++ b/lib/gs/src/tool_file_dialog.erl @@ -0,0 +1,445 @@ +%% +%% %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% +%% + +%% +-module(tool_file_dialog). +-export([start/1]). + +-record(opts, {type, % open | save | multiselect + dir, % string() Current directory + file, % string() Filename, no path + extensions, % [string()] Filtered file extensions + hidden}). % [{Dir, [File]}] Hidden files per dir. + +-define(WIDTH, 250). +-define(HEIGHT, 400). +-define(BTNW, 65). +-define(BTNH, 30). + +%% start(Opts) -> {ok, AbsFile, Dir} | {error,cancel} | pid() +%% Opts = [Opt] +%% Opt = {type, open|save|multiselect} +%% | {extensions, [string()]} % For example ".erl" +%% | {dir, string()} % Absolute path +%% ! {file, string() % Filename (no path) +%% AbsFile = string() +%% Dir = string() +%% An open/save dialog returns {ok, AbsFile, Dir} or {error,cancel} +%% (the latter, ridiculous, return value is kept for backwards +%% compatibility reasons only). +%% +%% A multiselect box returns a pid and delivers messages on the form: +%% {select, AbsFile} | {close, Dir} +%% +%% Dir is the current directory displayed and can be used to start a +%% a new filedialog with the same directory. + +start(Opts0) -> + Opts = parse_opts(Opts0), + Self = self(), + case Opts#opts.type of + multiselect -> + spawn_link(fun() -> init(Self, Opts) end); + _Type -> % open | save + spawn_link(fun() -> init(Self, Opts) end), + receive + {fd_result, Res} -> + Res + end + end. + +parse_opts(Opts) -> + {ok, CWD} = file:get_cwd(), + DefOpts = #opts{type=open, dir=CWD, file="NoName", + extensions=[], hidden=[]}, + parse_opts(Opts, DefOpts). + +parse_opts([{type, Type}|Opts], DefOpts) -> + if + Type==open; Type==save; Type==multiselect -> + parse_opts(Opts, DefOpts#opts{type=Type}); + true -> + erlang:error(badarg, [{type,Type}]) + end; +parse_opts([{extensions, Exts}|Opts], DefOpts) -> + case lists:all(fun(Ext) -> is_list(Ext) end, Exts) of + true -> + parse_opts(Opts, DefOpts#opts{extensions=Exts}); + false -> + erlang:error(badarg, [{extension, Exts}]) + end; +parse_opts([{dir, Dir}|Opts], DefOpts) -> + case filelib:is_dir(Dir) of + true -> + case filename:pathtype(Dir) of + absolute -> + parse_opts(Opts, DefOpts#opts{dir=Dir}); + _ -> + parse_opts(Opts, + DefOpts#opts{dir=filename:absname(Dir)}) + end; + false -> + erlang:error(badarg, [{dir, Dir}]) + end; +parse_opts([{file, Name}|Opts], DefOpts) -> + if + is_list(Name) -> + parse_opts(Opts, DefOpts#opts{file=Name}); + true -> + erlang:error(badarg, [{file, Name}]) + end; +parse_opts([_|Opts], DefOpts) -> % ignore unknown options + parse_opts(Opts, DefOpts); +parse_opts([], DefOpts) -> + DefOpts. + +%%--Loop---------------------------------------------------------------- + +init(From, Opts) -> + make_window(Opts), + loop(From, {?WIDTH,?HEIGHT}, Opts). + +loop(From, {OldW,OldH}=Size, Opts) -> + receive + + %% Window is closed + {gs, win, destroy, _, _} when Opts#opts.type==multiselect -> + From ! {close, Opts#opts.dir}; + {gs, win, destroy, _, _} -> + From ! {fd_result, {error, cancel}}; + + %% Window is moved or resized + {gs, win, configure, _, [OldW,OldH|_]} -> + loop(From, Size, Opts); + {gs, win, configure, _, [W,H|_]} -> + gs:config(resizer, [{width,W},{height,H}]), + loop(From, {W,H}, Opts); + + %% Up button is selected + {gs, up, click, _, _} -> + Opts2 = set_dir(up, Opts), + loop(From, Size, Opts2); + + %% A listbox item (dir or file) is selected + {gs, lb, click, _, [_I,Item|_]} -> + Entry = case lists:last(Item) of + $/ -> ""; + _Ch -> Item + end, + gs:config(entry, {text,Entry}), + loop(From, Size, Opts); + + %% A listbox item (dir or file) is double-clicked + {gs, lb, doubleclick, _, [_I,Item|_]} -> + case lists:last(Item) of + $/ -> do_select({dir, Item}, From, Size, Opts); + _Ch -> do_select({file, Item}, From, Size, Opts) + end; + + %% Open/Save/Select button is selected + {gs, select, click, _, _} -> + case gs:read(entry, text) of + "" -> + case gs:read(lb, selection) of + [] -> + gs:config(select, beep), + loop(From, Size, Opts); + [I] -> + Item = gs:read(lb, {get,I}), + case lists:last(Item) of + $/ -> + do_select({dir, Item}, + From, Size, Opts); + _Ch -> + do_select({file, Item}, + From, Size, Opts) + end + end; + Item -> do_select(Item, From, Size, Opts) + end; + + %% 'Return' is pressed + {gs, entry, keypress, _, ['Return'|_]} -> + case gs:read(entry, text) of + "" -> + gs:config(select, beep), + loop(From, Size, Opts); + Item -> + do_select(Item, From, Size, Opts) + end; + + %% All button is selected (multiselect dialog) + {gs, all, click, _, _} -> + {_Dirs, Files} = select_all(), + lists:foreach(fun(File) -> + AbsFile = filename:join(Opts#opts.dir, + File), + From ! {select, AbsFile} + end, + Files), + From ! {close, Opts#opts.dir}; + + %% Cancel button is selected (open/save dialog) + {gs, cancel, click, _, _} -> + From ! {fd_result, {error, cancel}}; + + %% Close button is selected (multiselect dialog) + {gs, close, click, _, _} -> + From ! {close, Opts#opts.dir}; + + Msg -> + io:format("GOT: ~p~n", [Msg]), + loop(From, Size, Opts) + end. + +do_select({dir, Name}, From, Size, Opts) -> + do_select_dir(filename:join(Opts#opts.dir, Name), From, Size, Opts); +do_select({file, Name}, From, Size, Opts) -> + do_select_file(filename:join(Opts#opts.dir, Name), From, Size,Opts); +do_select(Entry, From, Size, Opts) -> + AbsName = case filename:pathtype(Entry) of + absolute -> Entry; + _ -> filename:join(Opts#opts.dir, Entry) + end, + case filelib:is_dir(AbsName) of + true -> do_select_dir(AbsName, From, Size, Opts); + false -> do_select_file(AbsName, From, Size, Opts) + end. + +do_select_dir(Dir, From, Size, Opts) -> + Opts2 = set_dir(Dir, Opts), + loop(From, Size, Opts2). + +do_select_file(File, From, Size, Opts) -> + case filelib:is_file(File) of + true when Opts#opts.type==multiselect -> + From ! {select, File}, + Opts2 = update(File, Opts), + loop(From, Size, Opts2); + true -> % open | save + From ! {fd_result, {ok, File, Opts#opts.dir}}; + false when Opts#opts.type==save -> + case filelib:is_dir(filename:dirname(File)) of + true -> + From ! {fd_result, {ok, File, Opts#opts.dir}}; + false -> + gs:config(select, beep), + loop(From, Size, Opts) + end; + false -> % multiselect | open + gs:config(select, beep), + loop(From, Size, Opts) + end. + +%%--Common GUI functions------------------------------------------------ + +-define(UPW, 35). +-define(UPH, 30). +-define(ENTRYH, 30). + +make_window(Opts) -> + GS = gs:start(), + + Title = case Opts#opts.type of + open -> "Open File"; + save -> "Save File"; + multiselect -> "Select Files" + end, + + Font = case gs:read(GS, {choose_font,{screen,[],12}}) of + Font0 when element(1, Font0)==screen -> + Font0; + _ -> + gs:read(GS, {choose_font,{courier,[],12}}) + end, + + gs:window(win, GS, [{title,Title}, + {width,?WIDTH}, {height,?HEIGHT}, + {configure,true}]), + + Marg = {fixed,5}, + Parent = gs:frame(resizer, win, [{packer_x,[Marg,{stretch,1},Marg]}, + {packer_y,[Marg, + {stretch,10}, + {stretch,1,2*?BTNH}, + Marg]}]), + gs:frame(btnframe, resizer, [{packer_x, [{stretch,1}, + {fixed,?BTNW}, + {stretch,1}, + {fixed,?BTNW}, + {stretch,1}, + {fixed,?BTNW}, + {stretch,1}]}, + {packer_y, [{stretch,1}, + {fixed,?BTNH}, + {stretch,1}]}, + {pack_x,2}, {pack_y,3}]), + + gs:frame(frame, Parent, [{packer_x,[{fixed,?UPW},{stretch,1}]}, + {packer_y,[{fixed,?UPH},{fixed,?ENTRYH}, + {stretch,1}]}, + {pack_x,2}, {pack_y,2}]), + + Fup = filename:join([code:priv_dir(gs),"bitmap","fup.bm"]), + gs:button(up, frame, [{label,{image, Fup}}, + {pack_x,1}, {pack_y,1}]), + gs:label(infodir, frame, [{label,{text," Dir:"}}, {font,Font}, + {pack_x,2}, {pack_y,1}, {align,w}]), + gs:label(l1, frame, [{label,{text,"File:"}}, {font,Font}, {align,e}, + {pack_x,1}, {pack_y,2}]), + + gs:entry(entry, frame, [{font,Font}, {keypress,true}, + {pack_x,2}, {pack_y,2}]), + gs:listbox(lb, frame, [{font,Font}, {pack_x,{1,2}}, {pack_y,3}, + {selectmode,single}, + {vscroll,right}, + {click,true}, {doubleclick,true}]), + + set_dir(Opts#opts.dir, Opts), + + case Opts#opts.type of + multiselect -> + gs:button(select, btnframe, [{label,{text,"Select"}}, + {font,Font}, + {pack_x,2}, {pack_y,2}]), + gs:button(all, btnframe, [{label,{text,"All"}}, {font,Font}, + {pack_x,4}, {pack_y,2}]), + gs:button(close,btnframe,[{label,{text,"Done"}}, + {font,Font}, + {pack_x,6}, {pack_y,2}]); + Type -> + Text = case Type of + open -> "Open"; + save -> "Save" + end, + gs:button(select, btnframe, [{label,{text,Text}}, + {font,Font}, + {pack_x,2}, {pack_y,2}]), + gs:button(cancel, btnframe, [{label,{text,"Cancel"}}, + {font,Font}, + {pack_x,6}, {pack_y,2}]) + end, + + gs:config(resizer, [{width,?WIDTH}, {height,?HEIGHT}]), + gs:config(win, {map,true}). + +%% update(AbsFile, Opts) -> Opts' +update(AbsFile, Opts) -> + Dir = filename:dirname(AbsFile), + File = filename:basename(AbsFile), + + %% Hide the file + Hidden0 = Opts#opts.hidden, + Hidden = case lists:keysearch(Dir, 1, Hidden0) of + {value, {_Dir, Files}} -> + lists:keyreplace(Dir, 1, Hidden0, + {Dir, [File|Files]}); + false -> + [{Dir, [File]} | Hidden0] + end, + Opts2 = Opts#opts{hidden=Hidden}, + set_dir(Dir, Opts2). + +%% select_all() -> {Dirs, Files} +select_all() -> + Is = lists:seq(0, gs:read(lb, size)-1), + sort_selected(Is, [], []). + +sort_selected([I|Is], Dirs, Files) -> + FileOrDir = gs:read(lb, {get,I}), + case lists:last(FileOrDir) of + $/ -> + sort_selected(Is, [drop_last(FileOrDir)|Dirs], Files); + _Ch -> + sort_selected(Is, Dirs, [FileOrDir|Files]) + end; +sort_selected([], Dirs, Files) -> + {Dirs, Files}. + +drop_last(Str) -> + lists:sublist(Str, length(Str)-1). + +%% set_dir(Dir0, Opts) -> Opts' +%% Dir0 = up | string() absolute path only +set_dir(Dir0, Opts) -> + Dir = if + Dir0==up -> filename:dirname(Opts#opts.dir); + true ->Dir0 + end, + + case filelib:is_dir(Dir) of + true -> + gs:config(frame, {cursor,busy}), + gs:config(lb, clear), + Items = get_files(Dir, Opts#opts.hidden, + Opts#opts.extensions), + case Opts#opts.type of + save -> + gs:config(entry, {text,Opts#opts.file}); + _ -> + gs:config(entry, {text,""}) + end, + gs:config(lb, [{items,Items}]), + gs:config(lb, {selection, clear}), + gs:config(infodir, {label,{text,["Dir: "|Dir]}}), + gs:config(frame, {cursor,parent}), + Opts#opts{dir=Dir}; + false -> + gs:config(select, beep), + Opts + end. + +get_files(Dir, Hidden, Exts) -> + {ok, Items0} = file:list_dir(Dir), + + Items = case lists:keysearch(Dir, 1, Hidden) of + {value, {_Dir, HiddenHere}} -> + lists:filter(fun(Item0) -> + not lists:member(Item0, + HiddenHere) + end, + Items0); + false -> + Items0 + end, + + get_files(Dir, Items, [], [], Exts). + +get_files(Dir, [Item0|Items], Dirs, Files, Exts) -> + Item = filename:join(Dir, Item0), + case filelib:is_dir(Item) of + true -> + get_files(Dir, Items, [Item0++"/"|Dirs], Files, Exts); + false -> + case filelib:is_regular(Item) of + true when Exts==[] -> + get_files(Dir, Items, Dirs, [Item0|Files], Exts); + true -> + case lists:member(filename:extension(Item), Exts) of + true -> + get_files(Dir,Items,Dirs,[Item0|Files],Exts); + false -> + get_files(Dir, Items, Dirs, Files, Exts) + end; + false -> + get_files(Dir, Items, Dirs, Files, Exts) + end + end; +get_files(_Dir, [], Dirs, Files, _Exts) -> + lists:sort(Dirs) ++ lists:sort(Files). diff --git a/lib/gs/src/tool_utils.erl b/lib/gs/src/tool_utils.erl new file mode 100644 index 0000000000..697dd07151 --- /dev/null +++ b/lib/gs/src/tool_utils.erl @@ -0,0 +1,434 @@ +%% +%% %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% +%% + +%% +-module(tool_utils). +-include_lib("kernel/include/file.hrl"). + +%%%--------------------------------------------------------------------- +%%% Auxiliary functions to be used by the tools (internal module) +%%%--------------------------------------------------------------------- + +%% External exports +-export([open_help/2]). +-export([file_dialog/1]). +-export([notify/2, confirm/2, confirm_yesno/2, request/2]). + +-record(state, {type, % notify | confirm[_yesno] | request + win, % gsobj(), window + entry, % gsobj(), entry + in_focus, % 0 | 1 | undefined Entry is in focus + is_cursor, % bool() | undefined Cursor is over Entry + buttons, % [gsobj()], buttons + highlighted % int() highlighted buttone + }). + + +%%---------------------------------------------------------------------- +%% open_help(Parent, File) +%% Parent = gsobj() (GS root object or parent window) +%% File = string() | nofile +%% View the help file File, which can be an URL, an HTML file or a text +%% file. +%% This function is OS dependant. +%% Unix: Assumes Netscape is up & running, and use Netscape remote +%% commands to display the file. +%% NT: If File is a file, use the NT command 'start' which will open the +%% default tool for viewing the file. +%% If File is an URL, try to view it using Netscape.exe which +%% requires that the path Netscape.exe must be in TBD. +%% (TEMPORARY solution..., can be done better) +%%---------------------------------------------------------------------- +open_help(Parent, nofile) -> + notify(Parent, "Sorry, no help information exists"); +open_help(Parent, File) -> + case application:get_env(kernel, browser_cmd) of + undefined -> + open_help_default(Parent, File); + {ok, Cmd} when is_list(Cmd) -> + spawn(os, cmd, [Cmd ++ " " ++ File]); + {ok, {M, F, A}} -> + apply(M, F, [File|A]); + _Other -> + Str = ["Bad Kernel configuration parameter browser_cmd", + "Do not know how to display help file"], + notify(Parent, Str) + end. + +open_help_default(Parent, File) -> + Cmd = case file_type(File) of + + %% Local file + local -> + case os:type() of + {unix,Type} -> + case Type of + darwin -> "open " ++ File; + _Else -> "netscape -remote \"openURL(file:" ++ File ++ ")\"" + end; + {win32,_AnyType} -> + "start " ++ filename:nativename(File); + + _Other -> + unknown + end; + + %% URL + remote -> + case os:type() of + {unix,Type} -> + case Type of + darwin -> "open " ++ File; + _Else -> "netscape -remote \"openURL(file:" ++ File ++ ")\"" + end; + {win32,_AnyType} -> + "netscape.exe -h " ++ regexp:gsub(File,"\\\\","/"); + _Other -> + unknown + end; + + Error -> % {error,Reason} + Error + end, + + if + is_list(Cmd) -> + spawn(os, cmd, [Cmd]); + Cmd==unknown -> + Str = ["Sorry, do not know how to", + "display HTML files at this platform"], + notify(Parent, Str); + true -> + {error, Reason} = Cmd, + Str = file:format_error(Reason), + notify(Parent, [File,Str]) + end. + +%% file_type(File) -> local | remote | {error,Reason} +%% File = string() +%% Reason - see file(3) +%% Returns local if File is an existing, readable file +%% Returns remote if File is a remote URL (ie begins with 'http:') +file_type(File) -> + case File of + "http://"++_URL -> + remote; + _ -> + %% HTML files can have a tag (<name>.html#tag), this must be + %% removed when checking if the file exists + File2 = case filename:extension(File) of + ".html#"++_Index -> + filename:rootname(File)++".html"; + _ -> + File + end, + + case file:read_file_info(File2) of + {ok, FileInfo} when FileInfo#file_info.type==regular, + FileInfo#file_info.access/=none -> + local; + {ok, FileInfo} when FileInfo#file_info.type/=regular -> + {error,einval}; + {ok, FileInfo} when FileInfo#file_info.access==none -> + {error,eacces}; + Error -> + Error + end + end. + + +%%---------------------------------------------------------------------- +%% file_dialog(Options) -> tbd +%%---------------------------------------------------------------------- +file_dialog(Options) -> + tool_file_dialog:start(Options). + + +%%---------------------------------------------------------------------- +%% notify(Parent, Strings) -> ok +%% confirm(Parent, Strings) -> ok | cancel +%% confirm_yesno(Parent, Strings) -> yes | no | cancel +%% request(Parent, Strings) -> {ok,string()} | cancel +%% Parent = gsobj() (GS root object or parent window) +%% Strings = string() | [string()] +%% Opens a window with the specified message (Strings) and locks the GUI +%% until the user confirms the message. +%% If the Parent argument is the parent window, the help window will be +%% centered above it, otherwise it can end up anywhere on the screen. +%% A 'notify' window contains an 'Ok' button. +%% A 'confirm' window contains an 'Ok' and a 'Cancel' button. +%% A 'confirm_yesno' window contains a 'Yes', a 'No', and a 'Cancel' +%% button. +%% A 'request' window contains an entry, an 'Ok' and a 'Cancel' button. +%%---------------------------------------------------------------------- +-define(Wlbl, 130). +-define(Hlbl, 30). +-define(Hent, 30). +-define(Wbtn, 50). +-define(Hbtn, 30). +-define(PAD, 10). + +notify(Parent, Strings) -> + help_win(notify, Parent, Strings). +confirm(Parent, Strings) -> + help_win(confirm, Parent, Strings). +confirm_yesno(Parent, Strings) -> + help_win(confirm_yesno, Parent, Strings). +request(Parent, Strings) -> + help_win(request, Parent, Strings). + +help_win(Type, Parent, Strings) -> + GenOpts = [{keypress,true}], + GenOpts2 = [{font,{screen,12}} | GenOpts], + Buttons = buttons(Type), + Nbtn = length(Buttons), + + %% Create the window and its contents + Win = gs:create(window, Parent, [{title,title(Type)} | GenOpts]), + Top = gs:create(frame, Win, GenOpts), + Lbl = gs:create(label, Top, [{align,c}, {justify,center}|GenOpts2]), + Mid = if + Type==request -> gs:create(frame, Win, GenOpts); + true -> ignore + end, + Ent = if + Type==request -> + Events = [{setfocus,true}, + {focus,true},{enter,true},{leave,true}], + gs:create(entry, Mid, GenOpts2++Events); + true -> ignore + end, + Bot = gs:create(frame, Win, GenOpts), + + %% Find out minimum size required for label, entry and buttons + Font = gs:read(Parent, {choose_font, {screen,12}}), + Text = insert_newlines(Strings), + {Wlbl0,Hlbl0} = gs:read(Lbl, {font_wh,{Font,Text}}), + {_Went0,Hent0} = gs:read(Lbl, {font_wh,{Font,"Entry"}}), + {Wbtn0,Hbtn0} = gs:read(Lbl, {font_wh,{Font,"Cancel"}}), + + %% Compute size of the objects and adjust the graphics accordingly + Wbtn = max(Wbtn0+10, ?Wbtn), + Hbtn = max(Hbtn0+10, ?Hbtn), + Hent = max(Hent0+10, ?Hent), + Wlbl = max(Wlbl0, max(Nbtn*Wbtn+(Nbtn-1)*?PAD, ?Wlbl)), + Hlbl = max(Hlbl0, ?Hlbl), + + Wwin = ?PAD+Wlbl+?PAD, + + Htop = ?PAD+Hlbl, + Hmid = if Type==request -> ?PAD+Hent; true -> 0 end, + Hbot = ?PAD+Hbtn+?PAD, + Hwin = Htop+Hmid+Hbot, + + case catch get_coords(Parent, Wwin, Hwin) of + {Xw, Yw} when is_integer(Xw), is_integer(Yw) -> + gs:config(Win, [{x,Xw}, {y,Yw}]); + _ -> + ignore + end, + + gs:config(Win, [ {width,Wwin},{height,Hwin}]), + + gs:config(Top, [{x,0}, {y,0}, {width,Wwin},{height,Htop}]), + gs:config(Lbl, [{x,?PAD},{y,?PAD}, {width,Wlbl},{height,Hlbl}]), + + gs:config(Mid, [{x,0}, {y,Htop}, {width,Wwin},{height,Hmid}]), + gs:config(Ent, [{x,?PAD},{y,?PAD}, {width,Wlbl},{height,Hent}]), + + gs:config(Bot, [{x,0}, {y,Htop+Hmid},{width,Wwin},{height,Hbot}]), + + %% Insert the label text + gs:config(Lbl, {label,{text,Text}}), + + %% Add the buttons + Xbtns = xbuttons(Buttons, Wbtn, Wwin, Wlbl), + BtnObjs = + lists:map(fun({Btext,BX}) -> + gs:create(button, Bot, [{x,BX-1}, {y,?PAD-1}, + {width,Wbtn+2}, + {height,Hbtn+2}, + {label,{text,Btext}}, + {data,data(Btext)} + | GenOpts2]) + end, + Xbtns), + Highlighted = highlight(undef, 1, BtnObjs), + + gs:config(Win, [{map,true}]), + + State = if + Type==request -> + #state{in_focus=1, is_cursor=false}; + true -> + #state{} + end, + event_loop(State#state{type=Type, win=Win, entry=Ent, + buttons=BtnObjs, highlighted=Highlighted}). + +title(notify) -> "Notification"; +title(confirm) -> "Confirmation"; +title(confirm_yesno) -> "Confirmation"; +title(request) -> "Request". + +buttons(notify) -> ["Ok"]; +buttons(confirm) -> ["Ok", "Cancel"]; +buttons(confirm_yesno) -> ["Yes", "No", "Cancel"]; +buttons(request) -> ["Ok", "Cancel"]. + +data("Ok") -> {helpwin,ok}; +data("Yes") -> {helpwin,yes}; +data("No") -> {helpwin,no}; +data("Cancel") -> {helpwin,cancel}. + +max(X, Y) when X>Y -> X; +max(_X, Y) -> Y. + +get_coords(Parent, W, H) -> + case gs:read(Parent, x) of + X when is_integer(X) -> + case gs:read(Parent, y) of + Y when is_integer(Y) -> + case gs:read(Parent, width) of + W0 when is_integer(W0) -> + case gs:read(Parent, height) of + H0 when is_integer(H0) -> + {round((X+W0/2)-W/2), + round((Y+H0/2)-H/2)}; + _ -> error + end; + _ -> error + end; + _ -> error + end; + _ -> error + end. + +xbuttons([B], Wbtn, Wwin, _Wlbl) -> + [{B, round(Wwin/2-Wbtn/2)}]; +xbuttons([B1,B2], Wbtn, Wwin, Wlbl) -> + Margin = (Wwin-Wlbl)/2, + [{B1,round(Margin)}, {B2,round(Wwin-Margin-Wbtn)}]; +xbuttons([B1,B2,B3], Wbtn, Wwin, Wlbl) -> + Margin = (Wwin-Wlbl)/2, + [{B1,round(Margin)}, + {B2,round(Wwin/2-Wbtn/2)}, + {B3,round(Wwin-Margin-Wbtn)}]. + +highlight(Prev, New, BtnObjs) when New>0, New=<length(BtnObjs) -> + if + Prev==undef -> ignore; + true -> + gs:config(lists:nth(Prev, BtnObjs), [{highlightbw,0}]) + end, + gs:config(lists:nth(New, BtnObjs), [{highlightbw,1}, + {highlightbg,black}]), + New; +highlight(Prev, _New, _BtnObjs) -> % New is outside allowed range + Prev. + +event_loop(State) -> + receive + GsEvent when element(1, GsEvent)==gs -> + case handle_event(GsEvent, State) of + {continue, NewState} -> + event_loop(NewState); + + {return, Result} -> + gs:destroy(State#state.win), + Result + end + end. + +handle_event({gs,_,click,{helpwin,Result},_}, State) -> + if + State#state.type/=request; Result==cancel -> + {return, Result}; + + State#state.type==request, Result==ok -> + case gs:read(State#state.entry, text) of + "" -> + {continue, State}; + Info -> + {return, {ok, Info}} + end + end; + +%% When the entry (Type==request) is in focus and the mouse pointer is +%% over it, don't let 'Left'|'Right' keypresses affect which button is +%% selected +handle_event({gs,Ent,enter,_,_}, #state{entry=Ent}=State) -> + {continue, State#state{is_cursor=true}}; +handle_event({gs,Ent,leave,_,_}, #state{entry=Ent}=State) -> + {continue, State#state{is_cursor=false}}; +handle_event({gs,Ent,focus,_,[Int|_]}, #state{entry=Ent}=State) -> + {continue, State#state{in_focus=Int}}; + +handle_event({gs,Win,keypress,_,['Right'|_]}, #state{win=Win}=State) -> + if + State#state.type==request, + State#state.in_focus==1, State#state.is_cursor==true -> + {continue, State}; + true -> + Prev = State#state.highlighted, + New = highlight(Prev, Prev+1, State#state.buttons), + {continue, State#state{highlighted=New}} + end; +handle_event({gs,Win,keypress,_,['Left'|_]}, #state{win=Win}=State) -> + if + State#state.type==request, + State#state.in_focus==1, State#state.is_cursor==true -> + {continue, State}; + true -> + Prev = State#state.highlighted, + New = highlight(Prev, Prev-1, State#state.buttons), + {continue, State#state{highlighted=New}} + end; + +handle_event({gs,Ent,keypress,_,['Tab'|_]}, #state{entry=Ent}=State) -> + gs:config(hd(State#state.buttons), {setfocus,true}), + gs:config(Ent, {select,clear}), + {continue, State#state{in_focus=0}}; + +handle_event({gs,Win,keypress,_,['Return'|_]}, #state{win=Win}=State) -> + Selected = lists:nth(State#state.highlighted, State#state.buttons), + Data = gs:read(Selected, data), + handle_event({gs,Win,click,Data,undef}, State); + +handle_event({gs,Win,destroy,_,_}, #state{win=Win}=State) -> + if + State#state.type==notify -> {return, ok}; + true -> {return, cancel} + end; + +%% Flush any other GS events +handle_event({gs,_Obj,_Event,_Data,_Arg}, State) -> + {continue, State}. + +%% insert_newlines(Strings) => string() +%% Strings - string() | [string()] +%% If Strings is a list of strings, return a string where all these +%% strings are concatenated with newlines in between,otherwise return +%% Strings. +insert_newlines([String|Rest]) when is_list(String),Rest/=[]-> + String ++ "\n" ++ insert_newlines(Rest); +insert_newlines([Last]) -> + [Last]; +insert_newlines(Other) -> + Other. |