diff options
Diffstat (limited to 'lib/gs/src/gstk_generic.erl')
| -rw-r--r-- | lib/gs/src/gstk_generic.erl | 1087 |
1 files changed, 1087 insertions, 0 deletions
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}). |