diff options
Diffstat (limited to 'lib/gs/src/gstk_generic.erl')
| -rw-r--r-- | lib/gs/src/gstk_generic.erl | 1089 |
1 files changed, 0 insertions, 1089 deletions
diff --git a/lib/gs/src/gstk_generic.erl b/lib/gs/src/gstk_generic.erl deleted file mode 100644 index db4e2fdff4..0000000000 --- a/lib/gs/src/gstk_generic.erl +++ /dev/null @@ -1,1089 +0,0 @@ -%% -%% %CopyrightBegin% -%% -%% Copyright Ericsson AB 1996-2016. All Rights Reserved. -%% -%% Licensed under the Apache License, Version 2.0 (the "License"); -%% you may not use this file except in compliance with the License. -%% You may obtain a copy of the License at -%% -%% http://www.apache.org/licenses/LICENSE-2.0 -%% -%% Unless required by applicable law or agreed to in writing, software -%% distributed under the License is distributed on an "AS IS" BASIS, -%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -%% See the License for the specific language governing permissions and -%% limitations under the License. -%% -%% %CopyrightEnd% -%% - -%% - --module(gstk_generic). --compile([{nowarn_deprecated_function,{gs,assq,2}}]). - --export([out_opts/8, - read_option/5, - mk_tkw_child/2, - merge_default_options/3, - merge_default_options/2, - opts_for_child/3, - mk_cmd_and_exec/4, - mk_cmd_and_exec/5, - mk_cmd_and_exec/6, - mk_cmd_and_exec/7, - make_command/5, - make_command/6, - make_command/7, - read_option/4, - handle_external_opt_call/9, - handle_external_read/1, - gen_anchor/9, - gen_anchor/5, - gen_height/9, - gen_height/5, - gen_width/9, - gen_width/5, - gen_x/9, - gen_x/5, - gen_y/9, - gen_y/5, - gen_raise/9, - gen_raise/5, - gen_lower/9, - gen_lower/5, - gen_enable/9, - gen_enable/5, - gen_align/9, - gen_align/5, - gen_justify/9, - gen_justify/5, - gen_padx/9, - gen_padx/5, - gen_pady/9, - gen_pady/5, - gen_font/9, - gen_font/5, - gen_label/9, - gen_label/5, - gen_activebg/9, - gen_activebg/5, - gen_activefg/9, - gen_activefg/5, - gen_default/9, - gen_relief/9, - gen_relief/5, - gen_bw/9, - gen_bw/5, - gen_font_wh/5, - gen_choose_font/5, - gen_data/9, - gen_data/5, - gen_pack_x/9, - gen_pack_x/5, - gen_pack_y/9, - gen_pack_y/5, - gen_pack_xy/9, - gen_flush/9, - gen_flush/5, - gen_keep_opt/9, - gen_children/5, - make_extern_id/2, - gen_id/5, - gen_parent/5, - gen_type/5, - gen_beep/9, - gen_setfocus/9, - gen_setfocus/5, - gen_buttonpress/9, - gen_buttonpress/5, - gen_buttonrelease/9, - gen_buttonrelease/5, - gen_configure/9, - gen_configure/5, - gen_destroy/9, - gen_destroy/5, - gen_enter/9, - gen_enter/5, - gen_focus_ev/9, - gen_focus_ev/5, - gen_keypress/9, - gen_keypress/5, - gen_keyrelease/9, - gen_keyrelease/5, - gen_leave/9, - gen_leave/5, - gen_motion/9, - gen_motion/5, - gen_highlightbw/9, - gen_highlightbw/5, - gen_highlightbg/9, - gen_highlightbg/5, - gen_highlightfg/9, - gen_highlightfg/5, - gen_selectbw/9, - gen_selectbw/5, - gen_selectfg/9, - gen_selectfg/5, - gen_selectbg/9, - gen_selectbg/5, - gen_fg/9, - gen_fg/5, - gen_bg/9, - gen_bg/5, - gen_so_activebg/9, - gen_so_activebg/5, - gen_so_bc/9, - gen_so_bc/5, - gen_so_scrollfg/9, - gen_so_scrollfg/5, - gen_so_scrollbg/9, - gen_so_scrollbg/5, - obj/1, - gen_so_bg/9, - gen_so_bg/5, - gen_so_selectbw/9, - gen_so_selectbw/5, - gen_so_selectfg/9, - gen_so_selectfg/5, - gen_so_selectbg/9, - gen_so_selectbg/5, - gen_so_scrolls/9, - gen_so_hscroll/5, - gen_so_vscroll/5, - cursors/0, - gen_cursor/9, - gen_cursor/5, - gen_citem_coords/9, - gen_citem_coords/5, - gen_citem_fill/9, - gen_citem_fill/5, - gen_citem_lower/9, - gen_citem_raise/9, - gen_citem_move/9, - move_coords/3, - add_to_coords/3, - gen_citem_setfocus/9, - gen_citem_setfocus/5, - gen_citem_buttonpress/9, - gen_citem_buttonrelease/9, - gen_citem_enter/9, - gen_citem_keypress/9, - gen_citem_keyrelease/9, - gen_citem_leave/9, - gen_citem_motion/9, - scrolls_vh/3, - parse_scrolls/1, - parse_scrolls/2, - parse_scrolls/4, - bind/5, - bind/6, - ebind/6, - eunbind/6, - item_bind/6, - item_ebind/6, - item_eunbind/5, - event/5, - read_option/3, - make_command/4, - mk_create_opts_for_child/4]). - --include("gstk.hrl"). --include("gstk_generic.hrl"). - -%%---------------------------------------------------------------------- -%% Returns: a new unique TkWidget (string()) -%%---------------------------------------------------------------------- -mk_tkw_child(DB,#gstkid{parent=P,objtype=Ot}) -> - Pgstkid = gstk_db:lookup_gstkid(DB, P), - PW = Pgstkid#gstkid.widget, - Oref = gstk_db:counter(DB, Ot), - PF = gstk_widgets:suffix(Ot), - _TkW = lists:concat([PW, PF, Oref]). - -%%---------------------------------------------------------------------- -%% Purpose: Merges options. Opts have higher priority than BuiltIn -%% (and ParentOpts have higher than BuiltIn) -%% Returns: A list of new options. -%%---------------------------------------------------------------------- -merge_default_options(ParOpts, BuildInOpts, Opts) -> - %% parents options first - Tmp=merge_default_options(ParOpts, lists:sort(Opts)), - merge_default_options(BuildInOpts,Tmp). - -merge_default_options([Def|Ds],[Opt|Os]) - when element(1,Def) < element(1,Opt) -> - [Def | merge_default_options(Ds,[Opt|Os])]; - -merge_default_options([Def|Ds],[Opt|Os]) - when element(1,Def) > element(1,Opt) -> - [Opt | merge_default_options([Def|Ds],Os)]; - -merge_default_options([Def|Ds],[Opt|Os]) - when element(1,Def) == element(1,Opt) -> - [Opt | merge_default_options(Ds,Os)]; - -merge_default_options(Defs,[Opt|Os]) -> - [Opt | merge_default_options(Defs,Os)]; - -merge_default_options([],Opts) -> Opts; -merge_default_options(Defs,[]) -> Defs. - -opts_for_child(DB,Childtype,ParId) -> - case gs_widgets:container(Childtype) of - true -> - gstk_db:default_container_opts(DB,ParId,Childtype); - false -> - gstk_db:default_opts(DB,ParId,Childtype) - end. - -mk_create_opts_for_child(DB,#gstkid{objtype=ChildType}, Pgstkid, Opts) -> - merge_default_options( - opts_for_child(DB,ChildType,Pgstkid#gstkid.id), - gs_widgets:default_options(ChildType), - Opts). - -mk_cmd_and_exec(Opts,Gstkid,Scmd,DB) -> - TkW = Gstkid#gstkid.widget, - mk_cmd_and_exec(Opts,Gstkid,TkW,Scmd,[";place ", TkW],DB,dummy). -mk_cmd_and_exec(Opts,Gstkid,Scmd,Pcmd,DB) -> - mk_cmd_and_exec(Opts,Gstkid,Gstkid#gstkid.widget,Scmd,Pcmd,DB,dummy). -mk_cmd_and_exec(Options, Gstkid, TkW, SCmd, PCmd, DB) -> - mk_cmd_and_exec(Options, Gstkid, TkW, SCmd, PCmd, DB,dummy). -mk_cmd_and_exec(Options, Gstkid, TkW, SCmd, PCmd, DB,ExtraArg) -> - case gstk_generic:make_command(Options,Gstkid,TkW,SCmd,PCmd,DB,ExtraArg) of - {error,Reason} -> {error,Reason}; - Cmd when is_list(Cmd) -> - gstk:exec(Cmd) - end. - -%%---------------------------------------------------------------------- -%% SCmd: SimplePreCommand - prepended to simple (s) options -%% PCmd: PlacePreCommand - prepended to placer (p) options -%% (should start with ';' (at least if preceeded with simple cmds)) -%% Comment: If some function changes the gstkid, -%% it's responsible for storing it in the DB. -%%---------------------------------------------------------------------- -make_command(Opts,Gstkid,Scmd,DB) -> - TkW = Gstkid#gstkid.widget, - make_command(Opts,Gstkid,TkW,Scmd,[";place ", TkW],DB,dummy). -make_command(Opts,Gstkid,Scmd,Pcmd,DB) -> - make_command(Opts,Gstkid,Gstkid#gstkid.widget,Scmd,Pcmd,DB,dummy). -make_command(Options, Gstkid, TkW, SCmd, PCmd, DB) -> - make_command(Options, Gstkid, TkW, SCmd, PCmd, DB,dummy). -make_command(Options, Gstkid, TkW, SCmd, PCmd, DB,ExtraArg) -> - case out_opts(Options, Gstkid, TkW, DB, ExtraArg, [], [], []) of - {[], [], []} -> []; - {Si, [], []} -> [SCmd, Si,$;]; - {[], Pl, []} -> [PCmd, Pl,$;]; - {[], [], Co} -> [$;,Co]; - {[], Pl, Co} -> [PCmd, Pl, $;, Co]; - {Si, [], Co} -> [SCmd, Si, $;, Co]; - {Si, Pl, []} -> [SCmd, Si, PCmd, Pl, $;]; - {Si, Pl, Co} -> [SCmd, Si, PCmd, Pl, $;, Co]; - {error,Reason} -> {error,Reason} - end. - -read_option(DB,Gstkid,Opt) -> - read_option(DB,Gstkid,Gstkid#gstkid.widget,Opt,dummy). -read_option(DB,Gstkid,Opt,ExtraArg) -> - read_option(DB,Gstkid,Gstkid#gstkid.widget,Opt,ExtraArg). - -%%---------------------------------------------------------------------- -%% Args: Args is [Gstkid, TkW, DB, ExtraArg] -%% Comment: An optimization:don't reconstruct the arg list for apply each time. -%% This is the option-engine so we should optimize. -%%---------------------------------------------------------------------- -handle_external_opt_call([Opt|Options],Gstkid,TkW,DB,ExtraArg,ExtRes,S,P,C) -> - case ExtRes of - {s, Cmd} -> - out_opts(Options,Gstkid, TkW,DB, ExtraArg, [Cmd|S], P, C); - {p, Cmd} -> - out_opts(Options, Gstkid,TkW,DB, ExtraArg, S, [Cmd|P], C); - {c, Cmd} -> - out_opts(Options, Gstkid,TkW,DB, ExtraArg,S, P, [Cmd,$;|C]); - none -> - out_opts(Options, Gstkid,TkW,DB,ExtraArg, S, P, C); - % {s, NGstkid, Cmd} -> - % out_opts(Options,NGstkid,TkW,DB,ExtraArg, [Cmd|S], P, C); - % {p, NGstkid, Cmd} -> - % out_opts(Options,NGstkid,TkW,DB,ExtraArg, S, [Cmd|P], C); - {c, NGstkid, Cmd} -> - out_opts(Options,NGstkid,TkW,DB, ExtraArg,S,P,[Cmd,$;|C]); - {none, NGstkid} -> - out_opts(Options,NGstkid,TkW,DB, ExtraArg, S, P, C); - {sp,{Scmd,Pcmd}} -> - out_opts(Options,Gstkid,TkW,DB,ExtraArg,[Scmd|S],[Pcmd|P],C); - invalid_option -> - {error,{invalid_option,Gstkid#gstkid.objtype,Opt}}; - break -> % a hack. it is possible to abort generic option handling at - %% any time (without even inserting the gstkid inte to DB (for - %% performance reasons)). - {S, P, C} - end. - -handle_external_read(Res) -> - %% We have removed dead code here that attempted to translate - %% a bad return value from {bad_result,{A,B,C}} to {error,{A,B,C}}. - %% Since the gs application is deprecated, we don't want to introduce - %% a potential incompatibility; thus we have removed the dead code - %% instead of correcting it. - Res. - -%%---------------------------------------------------------------------- -%% Generic options -%%---------------------------------------------------------------------- - -gen_anchor(How,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,[" -anc ", gstk:to_ascii(How)|P],C). -gen_anchor(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> - tcl2erl:ret_place(anchor, TkW). - -gen_height(Height,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - gstk_db:insert_opt(DB,Gstkid,{height,Height}), - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S, - [" -he ", gstk:to_ascii(Height)|P],C). -gen_height(_Opt,Gstkid,_TkW,DB,_ExtraArg) -> - gstk_db:opt(DB,Gstkid,height). - -gen_width(Width,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - gstk_db:insert_opt(DB,Gstkid,{width,Width}), - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S, - [" -wi ", gstk:to_ascii(Width)|P],C). -gen_width(_Opt,Gstkid,_TkW,DB,_ExtraArg) -> - gstk_db:opt(DB,Gstkid,width). - -gen_x(X,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - gstk_db:insert_opt(DB,Gstkid,{x,X}), - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S, - [" -x ", gstk:to_ascii(X)|P],C). -gen_x(_Opt,Gstkid,_TkW,DB,_ExtraArg) -> - gstk_db:opt(DB,Gstkid,x). - -gen_y(Y,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - gstk_db:insert_opt(DB,Gstkid,{y,Y}), - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S, - [" -y ", gstk:to_ascii(Y)|P],C). -gen_y(_Opt,Gstkid,_TkW,DB,_ExtraArg) -> - gstk_db:opt(DB,Gstkid,y). - -gen_raise(_,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,["raise ", TkW,$;|C]). -gen_raise(_Opt,_Gstkid,_TkW,_DB,_ExtraArg) -> - undefined. - -gen_lower(_,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,["lower ", TkW,$;|C]). -gen_lower(_Opt,_Gstkid,_TkW,_DB,_ExtraArg) -> - undefined. - -gen_enable(true,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,[" -st normal"|S],P,C); -gen_enable(false,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,[" -st disabled"|S],P,C). -gen_enable(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> - tcl2erl:ret_enable([TkW, " cg -st"]). - -gen_align(How,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,[" -an ", gstk:to_ascii(How)|S],P,C). -gen_align(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> - tcl2erl:ret_atom([TkW, " cg -anch"]). - -gen_justify(How,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,[" -ju ", gstk:to_ascii(How)|S],P,C). -gen_justify(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> - tcl2erl:ret_atom([TkW, " cg -ju"]). - -gen_padx(Pad,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,[" -padx ", gstk:to_ascii(Pad)|S],P,C). -gen_padx(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> - tcl2erl:ret_atom([TkW, " cg -padx"]). - -gen_pady(Pad,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,[" -pady ", gstk:to_ascii(Pad)|S],P,C). -gen_pady(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> - tcl2erl:ret_atom([TkW, " cg -pady"]). - - -gen_font(Font,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - gstk_db:insert_opt(DB,Gstkid,{font,Font}), - out_opts(Opts,Gstkid,TkW,DB,ExtraArg, - [" -font ", gstk_font:choose_ascii(DB,Font)|S],P,C). -gen_font(_Opt,Gstkid,_TkW,DB,_ExtraArg) -> - gstk_db:opt(DB,Gstkid,font,undefined). - -gen_label({text,Text},Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,[" -text ", gstk:to_ascii(Text), " -bi {}"|S],P,C); -gen_label({image,Img},Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - I2 = re:replace(Img, [92,92], "/", [global,{return,list}]), - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,[" -bi \"@", I2, "\" -text {}"|S],P,C). -gen_label(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> - case gstk:call([TkW, " cg -bit"]) of - {result, [$@|Image]} -> {image,Image}; - _Nope -> - case gstk:call([TkW, " cg -text"]) of - {result, Txt} -> {text, Txt}; - Bad_Result -> Bad_Result - end - end. - -gen_activebg(Color,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,[" -activeba ", gstk:to_color(Color)|S],P,C). -gen_activebg(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> - tcl2erl:ret_color([TkW, " cg -activeba"]). - -gen_activefg(Color,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,[" -activef ", gstk:to_color(Color)|S],P,C). -gen_activefg(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> - tcl2erl:ret_color([TkW, " cg -activef"]). - - -gen_default(Opt,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - case Opt of - {all, {font, Font}} -> - C2 = ["option a *",tl(TkW), % have to remove preceeding dot - "*font ",gstk_font:choose_ascii(DB, Font)], - gstk_db:insert_def(Gstkid,grid,{font,Font}), - gstk_db:insert_def(Gstkid,text,{font,Font}), - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,[C2,$;|C]); - {buttons, {font, Font}} -> - C2 = ["option a *",tl(TkW), % have to remove preceeding dot - ".Button.font ",gstk_font:choose_ascii(DB, Font)], - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,[C2,$;|C]); - {buttons,{Key,Val}} -> - gstk_db:insert_def(Gstkid,button,{Key,Val}), - gstk_db:insert_def(Gstkid,checkbutton,{Key,Val}), - gstk_db:insert_def(Gstkid,radiobutton,{Key,Val}), - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,C); - {ObjType, {Key,Val}} -> - gstk_db:insert_def(Gstkid,ObjType,{Key,Val}), - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) - end. - - -gen_relief(Relief,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,[" -reli ",gstk:to_ascii(Relief)|S],P,C). -gen_relief(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> - tcl2erl:ret_atom([TkW, " cg -reli"]). - -gen_bw(Wth,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,[" -bd ", gstk:to_ascii(Wth)|S],P,C). -gen_bw(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> - tcl2erl:ret_int([TkW, " cg -bd"]). - - - -gen_font_wh({font_wh,{Font, Txt}},_Gstkid,_TkW,DB,_) -> - gstk_font:width_height(DB, gstk_font:choose(DB,Font), Txt). - -gen_choose_font({choose_font,Font},_Gstkid,_TkW,DB,_ExtraArg) -> - gstk_font:choose(DB,Font). - -gen_data(Data,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - gstk_db:insert_opt(DB,Gstkid,{data,Data}), - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,C). -gen_data(_Opt,Gstkid,_TkW,DB,_ExtraArg) -> - gstk_db:opt(DB,Gstkid,data). - -gen_pack_x({Start,Stop},Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - gstk_db:insert_opt(DB,Gstkid,{pack_x,{Start,Stop}}), - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,C); -gen_pack_x(Col,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) when is_integer(Col) -> - gstk_db:insert_opt(DB,Gstkid,{pack_x,{Col,Col}}), - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,C). -gen_pack_x(_Opt,Gstkid,_TkW,DB,_ExtraArg) -> - gstk_db:opt(DB,Gstkid,pack_x, undefined). - -gen_pack_y({Start,Stop},Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - gstk_db:insert_opt(DB,Gstkid,{pack_y,{Start,Stop}}), - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,C); -gen_pack_y(Row,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) when is_integer(Row) -> - gstk_db:insert_opt(DB,Gstkid,{pack_y,{Row,Row}}), - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,C). -gen_pack_y(_Opt,Gstkid,_TkW,DB,_ExtraArg) -> - gstk_db:opt(DB,Gstkid,pack_y, undefined). - -gen_pack_xy({Col,Row},Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) - when is_integer(Col), is_integer(Row) -> - gstk_db:insert_opt(DB,Gstkid,{pack_x,{Col,Col}}), - gstk_db:insert_opt(DB,Gstkid,{pack_y,{Row,Row}}), - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,C); -gen_pack_xy({Col,{StartRow,StopRow}},Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) - when is_integer(Col) -> - gstk_db:insert_opt(DB,Gstkid,{pack_x,{Col,Col}}), - gstk_db:insert_opt(DB,Gstkid,{pack_y,{StartRow,StopRow}}), - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,C); -gen_pack_xy({{StartCol,StopCol},Row},Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) - when is_integer(Row) -> - gstk_db:insert_opt(DB,Gstkid,{pack_x,{StartCol,StopCol}}), - gstk_db:insert_opt(DB,Gstkid,{pack_y,{Row,Row}}), - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,C); -gen_pack_xy({Col,Row},Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - gstk_db:insert_opt(DB,Gstkid,{pack_x,Col}), - gstk_db:insert_opt(DB,Gstkid,{pack_y,Row}), - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,C). - - -gen_flush(_Opt,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - tcl2erl:ret_int(["update idletasks;expr 1+1"]), - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,C). -gen_flush(_Opt,_Gstkid,_TkW,_DB,_ExtraArg) -> - tcl2erl:ret_int(["update idletasks;expr 1+1"]). - - % a hidden impl option. -gen_keep_opt(Opt,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - gstk_db:insert_opt(DB,Gstkid,Opt), - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,C). - -gen_children(_Opt,Gstkid,_TkW,DB,_ExtraArg) -> - make_extern_id(gstk_db:lookup_kids(DB, Gstkid#gstkid.id), DB). - -make_extern_id([Id|Ids], DB) -> - [gstk:make_extern_id(Id, DB) | make_extern_id(Ids, DB)]; -make_extern_id([], _) -> []. - -gen_id(_Opt,#gstkid{id=Id},_TkW,DB,_ExtraArg) -> - gstk:make_extern_id(Id, DB). - -gen_parent(_Opt,Gstkid,_TkW,DB,_ExtraArg) -> - gstk:make_extern_id(Gstkid#gstkid.parent, DB). - -gen_type(_Opt,Gstkid,_TkW,_DB,_ExtraArg) -> - Gstkid#gstkid.objtype. - -gen_beep(_,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,["bell;",$;|C]). - -gen_setfocus(true,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,["focus ", TkW,$;|C]); -gen_setfocus(false,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,["focus .",$;|C]). - -gen_setfocus(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> - tcl2erl:ret_focus(TkW, "focus"). - -gen_buttonpress(On,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - Cmd = bind(DB, Gstkid, TkW, buttonpress, On), - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,[Cmd,$;|C]). -gen_buttonpress(_Opt,Gstkid,_TkW,DB,_ExtraArg) -> - gstk_db:is_inserted(DB, Gstkid, buttonpress). - -gen_buttonrelease(On,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - Cmd = bind(DB, Gstkid, TkW, buttonrelease, On), - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,[Cmd,$;|C]). -gen_buttonrelease(_Opt,Gstkid,_TkW,DB,_ExtraArg) -> - gstk_db:is_inserted(DB,Gstkid,buttonrelease). - -gen_configure(On,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - Cmd = bind(DB, Gstkid, TkW, configure, On), - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,[Cmd,$;|C]). -gen_configure(_Opt,Gstkid,_TkW,DB,_ExtraArg) -> - gstk_db:is_inserted(DB,Gstkid,configure). - -gen_destroy(On,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - Cmd = bind(DB, Gstkid, TkW, destroy, On), - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,[Cmd,$;|C]). -gen_destroy(_Opt,Gstkid,_TkW,DB,_ExtraArg) -> - gstk_db:is_inserted(DB,Gstkid,destroy). - -gen_enter(On,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - Cmd = bind(DB, Gstkid, TkW, enter, On), - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,[Cmd,$;|C]). -gen_enter(_Opt,Gstkid,_TkW,DB,_ExtraArg) -> - gstk_db:is_inserted(DB,Gstkid,enter). - -gen_focus_ev(On,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - Cmd = bind(DB, Gstkid, TkW, focus, On), - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,[Cmd,$;|C]). -gen_focus_ev(_Opt,Gstkid,_TkW,DB,_ExtraArg) -> - gstk_db:is_inserted(DB,Gstkid,focus). - -gen_keypress(On,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - Cmd = bind(DB, Gstkid, TkW, keypress, On), - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,[Cmd,$;|C]). -gen_keypress(_Opt,Gstkid,_TkW,DB,_ExtraArg) -> - gstk_db:is_inserted(DB,Gstkid,keypress). - -gen_keyrelease(On,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - Cmd = bind(DB, Gstkid, TkW, keyrelease, On), - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,[Cmd,$;|C]). -gen_keyrelease(_Opt,Gstkid,_TkW,DB,_ExtraArg) -> - gstk_db:is_inserted(DB,Gstkid,keyrelease). - -gen_leave(On,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - Cmd = bind(DB, Gstkid, TkW, leave, On), - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,[Cmd,$;|C]). -gen_leave(_Opt,Gstkid,_TkW,DB,_ExtraArg) -> - gstk_db:is_inserted(DB,Gstkid,leave). - -gen_motion(On,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - Cmd = bind(DB, Gstkid, TkW, motion, On), - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,[Cmd,$;|C]). -gen_motion(_Opt,Gstkid,_TkW,DB,_ExtraArg) -> - gstk_db:is_inserted(DB,Gstkid,motion). - -gen_highlightbw(Wth,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,[" -highlightt ", gstk:to_ascii(Wth)|S],P,C). -gen_highlightbw(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> - tcl2erl:ret_int([TkW, " cg -highlightt"]). - -gen_highlightbg(Color,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,[" -highlightb ", gstk:to_color(Color)|S],P,C). -gen_highlightbg(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> - tcl2erl:ret_color([TkW, " cg -highlightb"]). - -gen_highlightfg(Color,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,[" -highlightc ", gstk:to_color(Color)|S],P,C). -gen_highlightfg(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> - tcl2erl:ret_color([TkW, " cg -highlightc"]). - - -gen_selectbw(Width,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,[TkW, " conf -selectbo ", gstk:to_ascii(Width),$;|C]). -gen_selectbw(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> - tcl2erl:ret_int([TkW," cg -selectbo"]). - -gen_selectfg(Color,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,[TkW, " conf -selectfo ", gstk:to_color(Color),$;|C]). -gen_selectfg(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> - tcl2erl:ret_color([TkW," cg -selectfo"]). - -gen_selectbg(Color,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,[TkW, " conf -selectba ", gstk:to_color(Color),$;|C]). -gen_selectbg(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> - tcl2erl:ret_color([TkW," cg -selectba"]). - -gen_fg(Color,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,[" -fg ", gstk:to_color(Color)|S],P,C). -gen_fg(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> - tcl2erl:ret_color([TkW, " cg -fg"]). - -gen_bg(Color,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,[" -bg ", gstk:to_color(Color)|S],P,C). -gen_bg(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> - tcl2erl:ret_color([TkW, " cg -bg"]). - -%%---------------------------------------------------------------------- -%% Generic functions for scrolled objects -%%---------------------------------------------------------------------- -gen_so_activebg(Color,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - Col = gstk:to_color(Color), - C2 = [TkW, ".sy conf -activeba ", Col,$;, - TkW, ".pad.sx conf -activeba ", Col], - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,[C2,$;|C]). -gen_so_activebg(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> - tcl2erl:ret_color([TkW,".sy cg -activeba"]). - -gen_so_bc(Color,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - Col = gstk:to_color(Color), - C2= [TkW, " conf -bg ", Col,$;, - TkW, ".sy conf -highlightba ", Col,$;, - TkW, ".pad.it conf -bg ", Col,$;, - TkW, ".pad.sx conf -highlightba ", Col], - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,[C2,$;|C]). -gen_so_bc(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> - tcl2erl:ret_color([TkW," cg -bg"]). - -gen_so_scrollfg(Color,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - Col = gstk:to_color(Color), - C2=[TkW, ".sy conf -bg ", Col,$;, - TkW, ".pad.sx conf -bg ", Col], - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,[C2,$;|C]). -gen_so_scrollfg(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> - tcl2erl:ret_color([TkW,".sy cg -bg"]). - - -gen_so_scrollbg(Color,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - Col = gstk:to_color(Color), - C2 = [TkW, ".sy conf -troughc ", Col, $;, - TkW, ".pad.sx conf -troughc ", Col], - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,[C2,$;|C]). - -gen_so_scrollbg(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> - tcl2erl:ret_color([TkW,".sy cg -troughc"]). - -obj(#gstkid{widget_data=SO}) -> - SO#so.object. - -gen_so_bg(Color,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - C2= [obj(Gstkid), " conf -bg ", gstk:to_color(Color)], - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,[C2,$;|C]). -gen_so_bg(_Opt,Gstkid,_TkW,_DB,_ExtraArg) -> - tcl2erl:ret_color([obj(Gstkid)," cg -bg"]). - -gen_so_selectbw(Width,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - C2 = [obj(Gstkid), " conf -selectbo ", gstk:to_ascii(Width)], - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,[C2,$;|C]). -gen_so_selectbw(_Opt,Gstkid,_TkW,_DB,_ExtraArg) -> - tcl2erl:ret_int([obj(Gstkid)," cg -selectbo"]). - -gen_so_selectfg(Color,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - C2 = [obj(Gstkid), " conf -selectfo ", gstk:to_color(Color)], - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,[C2,$;|C]). -gen_so_selectfg(_Opt,Gstkid,_TkW,_DB,_ExtraArg) -> - tcl2erl:ret_color([obj(Gstkid)," cg -selectfo"]). - -gen_so_selectbg(Color,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - C2 = [obj(Gstkid), " conf -selectba ", gstk:to_color(Color)], - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,S,P,[C2,$;|C]). -gen_so_selectbg(_Opt,Gstkid,_TkW,_DB,_ExtraArg) -> - tcl2erl:ret_color([obj(Gstkid)," cg -selectba"]). - -gen_so_scrolls({Vscroll, Hscroll},Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - SO = Gstkid#gstkid.widget_data, - NewSO = SO#so{hscroll=Hscroll, vscroll=Vscroll}, - C2 = scrolls_vh(TkW, Vscroll, Hscroll), - Ngstkid = Gstkid#gstkid{widget_data=NewSO}, - gstk_db:update_widget(DB,Ngstkid), - out_opts(Opts,Ngstkid,TkW,DB,ExtraArg,S,P,[C2,$;|C]). - - % read-only -gen_so_hscroll(_Opt,#gstkid{widget_data=SO},_TkW,_DB,_) -> - SO#so.hscroll. - - % read-only -gen_so_vscroll(_Opt,#gstkid{widget_data=SO},_TkW,_DB,_) -> - SO#so.vscroll. - -cursors() -> [{arrow,"top_left_arrow"},{busy,"watch"},{cross,"X_cursor"}, - {hand,"hand2"},{help,"question_arrow"},{resize,"fleur"}, - {text,"xterm"}]. - -gen_cursor(parent,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,[" -cur {}"|S],P,C); -gen_cursor(Cur,Opts,Gstkid,TkW,DB,ExtraArg,S,P,C) -> - case gs:assq(Cur,cursors()) of - {value, TxtCur} -> - out_opts(Opts,Gstkid,TkW,DB,ExtraArg,[" -cur ",TxtCur|S],P,C); - _ -> - {error,{invalid_cursor,Gstkid#gstkid.objtype,Cur}} - end. -gen_cursor(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> - case tcl2erl:ret_str([TkW," cg -cur"]) of - "" -> parent; - Txt when is_list(Txt) -> - case lists:keysearch(Txt,2,cursors()) of - {value,{Cur,_}} -> Cur; - _ -> {bad_result, read_cursor} - end; - Bad_Result -> Bad_Result - end. - -gen_citem_coords(Coords,Opts,Gstkid,TkW,DB,AItem,S,P,C) -> - gstk_db:insert_opt(DB,Gstkid,{coords,Coords}), - out_opts(Opts,Gstkid,TkW,DB,AItem,S,P, - [TkW, " coords ", AItem," ",gstk_canvas:coords(Coords),$;|C]). -gen_citem_coords(_Opt,Gstkid,_TkW,DB,_ExtraArg) -> - gstk_db:opt(DB,Gstkid, coords). - -gen_citem_fill(none,Opts,Gstkid,TkW,DB,AItem,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,AItem,[" -f {}"|S],P,C); -gen_citem_fill(Color,Opts,Gstkid,TkW,DB,AItem,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,AItem,[" -f ",gstk:to_color(Color)|S],P,C). -gen_citem_fill(_Opt,_Gstkid,TkW,_DB,AItem) -> - tcl2erl:ret_color([TkW, " itemcg ", AItem, " -f"]). - -gen_citem_lower(_,Opts,Gstkid,TkW,DB,AItem,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,AItem,S,P, - [TkW, " lower ", AItem,$;|C]). - -gen_citem_raise(_,Opts,Gstkid,TkW,DB,AItem,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,AItem,S,P, - [TkW, " raise ", AItem,$;|C]). - -gen_citem_move({Dx,Dy},Opts,Gstkid,TkW,DB,AItem,S,P,C) -> - NewCoords = move_coords(Dx,Dy,gstk_db:opt(DB,Gstkid,coords)), - gstk_db:insert_opt(DB,Gstkid,NewCoords), - out_opts(Opts,Gstkid,TkW,DB,AItem,S,P, - [TkW, " move ", AItem, " ", - gstk:to_ascii(Dx), " ", gstk:to_ascii(Dy),$;|C]). - -move_coords(Dx,Dy,Coords) -> - Coords2 = add_to_coords(Dx,Dy, Coords), - {coords,Coords2}. - -add_to_coords(Dx,Dy,[{X,Y}|Coords]) -> - [{X+Dx,Y+Dy}|add_to_coords(Dx,Dy,Coords)]; -add_to_coords(_,_,[]) -> []. - - -gen_citem_setfocus(true,Opts,Gstkid,TkW,DB,AItem,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,AItem,S,P, - [TkW, " focus ", AItem,$;|C]); -gen_citem_setfocus(false,Opts,Gstkid,TkW,DB,AItem,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,AItem,S,P, - [TkW, " focus {}",$;|C]). -gen_citem_setfocus(_Opt,_Gstkid,TkW,_DB,_ExtraArg) -> - tcl2erl:ret_focus(gstk:to_ascii(bug_aitem),[TkW, " focus"]). - -gen_citem_buttonpress(On,Opts,Gstkid,TkW,DB,AItem,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,AItem,S,P, - [item_bind(DB, Gstkid, TkW, AItem,buttonpress, On),$;|C]). -gen_citem_buttonrelease(On,Opts,Gstkid,TkW,DB,AItem,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,AItem,S,P, - [item_bind(DB,Gstkid,TkW,AItem,buttonrelease, On),$;|C]). -gen_citem_enter(On,Opts,Gstkid,TkW,DB,AItem,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,AItem,S,P, - [item_bind(DB, Gstkid, TkW, AItem, enter, On),$;|C]). - -gen_citem_keypress(On,Opts,Gstkid,TkW,DB,AItem,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,AItem,S,P, - [item_bind(DB, Gstkid, TkW, AItem, keypress, On),$;|C]). -gen_citem_keyrelease(On,Opts,Gstkid,TkW,DB,AItem,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,AItem,S,P, - [item_bind(DB, Gstkid, TkW, AItem, keyrelease, On),$;|C]). - -gen_citem_leave(On,Opts,Gstkid,TkW,DB,AItem,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,AItem,S,P, - [item_bind(DB, Gstkid, TkW, AItem, leave, On),$;|C]). -gen_citem_motion(On,Opts,Gstkid,TkW,DB,AItem,S,P,C) -> - out_opts(Opts,Gstkid,TkW,DB,AItem,S,P, - [item_bind(DB, Gstkid, TkW, AItem, motion, On),$;|C]). - - -scrolls_vh(W, V, true) -> scrolls_vh(W, V, bottom); -scrolls_vh(W, true, H) -> scrolls_vh(W, left, H); -scrolls_vh(W, left, bottom) -> ["so_bottom_left ",W]; -scrolls_vh(W, left, top) -> ["so_top_left ",W]; -scrolls_vh(W, left, _) -> ["so_left ",W]; -scrolls_vh(W, right, bottom) -> ["so_bottom_right ",W]; -scrolls_vh(W, right, top) -> ["so_top_right ",W]; -scrolls_vh(W, right, _) -> ["so_right ",W]; -scrolls_vh(W, _, bottom) -> ["so_bottom ",W]; -scrolls_vh(W, _, top) -> ["so_top ",W]; -scrolls_vh(W, _, _) -> ["so_plain ",W]. - -%% create version -parse_scrolls(Opts) -> - {Vscroll, Hscroll, NewOpts} = parse_scrolls(Opts, false, false, []), - {Vscroll, Hscroll, [{scrolls, {Vscroll, Hscroll}} | NewOpts]}. - -%% config version -parse_scrolls(Gstkid, Opts) -> - SO = Gstkid#gstkid.widget_data, - Vscroll = SO#so.vscroll, - Hscroll = SO#so.hscroll, - case parse_scrolls(Opts, Vscroll, Hscroll, []) of - {Vscroll, Hscroll, Opts} -> Opts; - {NewVscroll, NewHscroll, NewOpts} -> - [{scrolls, {NewVscroll, NewHscroll}} | NewOpts] - end. - - -parse_scrolls([Option | Rest], Vscroll, Hscroll, Opts) when is_tuple(Option) -> - case element(1, Option) of - vscroll -> - parse_scrolls(Rest, element(2, Option), Hscroll, Opts); - hscroll -> - parse_scrolls(Rest, Vscroll, element(2, Option), Opts); - _ -> - parse_scrolls(Rest, Vscroll, Hscroll, [Option | Opts]) - end; - -parse_scrolls([Option | Rest], Vscroll, Hscroll, Opts) -> - parse_scrolls(Rest, Vscroll, Hscroll, [Option | Opts]); - -parse_scrolls([], Vscroll, Hscroll, Opts) -> - {Vscroll, Hscroll, Opts}. - - -%% -%% Event bind main function -%% -%% Should return a list of tcl commands or invalid_option -%% -%% WS = Widget suffix for complex widgets -%% -bind(DB, Gstkid, TkW, Etype, On) -> - WD = Gstkid#gstkid.widget_data, - TkW2 = if is_record(WD, so) -> - WD#so.object; - true -> TkW - end, - case bind(DB, Gstkid, TkW2, Etype, On, "") of - invalid_option -> invalid_option; - Cmd -> - Cmd - end. - -bind(DB, Gstkid, TkW, Etype, On, WS) -> - case On of - true -> ebind(DB, Gstkid, TkW, Etype, WS, ""); - false -> eunbind(DB, Gstkid, TkW, Etype, WS, ""); - {true, Edata} -> ebind(DB, Gstkid, TkW, Etype, WS, Edata); - {false, Edata} -> eunbind(DB, Gstkid, TkW, Etype, WS, Edata); - _ -> invalid_option - end. - - -%% -%% Event bind on -%% -%% Should return a list of tcl commands or invalid_option -%% -%% WS = Widget suffix for complex widgets -%% -ebind(DB, Gstkid, TkW, Etype, WS, Edata) -> - Eref = gstk_db:insert_event(DB, Gstkid, Etype, Edata), - P = ["bind ", TkW, WS], - Cmd = case Etype of - motion -> [P, " <Motion> {erlsend ", Eref, " %x %y}"]; - keypress -> - [P, " <KeyPress> {erlsend ", Eref," %K %N 0 0};", - P, " <Shift-KeyPress> {erlsend ", Eref, " %K %N 1 0};", - P, " <Control-KeyPress> {erlsend ", Eref, " %K %N 0 1};", - P," <Control-Shift-KeyPress> {erlsend ", Eref," %K %N 1 1}"]; - keyrelease -> - [P, " <KeyRelease> {erlsend ", Eref," %K %N 0 0};", - P, " <Shift-KeyRelease> {erlsend ", Eref, " %K %N 1 0};", - P, " <Control-KeyRelease> {erlsend ", Eref, " %K %N 0 1};", - P," <Control-Shift-KeyRelease> {erlsend ",Eref," %K %N 1 1}"]; - buttonpress -> - [P, " <ButtonPress> {erlsend ", Eref, " %b %x %y}"]; - buttonrelease -> - [P, " <ButtonRelease> {erlsend ", Eref, " %b %x %y}"]; - leave -> [P, " <Leave> {erlsend ", Eref, "}"]; - enter -> [P, " <Enter> {erlsend ", Eref, "}"]; - destroy -> - [P, " <Destroy> {if {\"%W\"==\"", [TkW, WS], - "\"} {erlsend ", Eref, "}}"]; - focus -> - [P, " <FocusIn> {erlsend ", Eref, " 1};" , - P, " <FocusOut> {erlsend ", Eref, " 0}"]; - configure -> - [P, " <Configure> {if {\"%W\"==\"", [TkW, WS], - "\"} {erlsend ", Eref, " %w %h %x %y}}"] - end, - Cmd. - - -%% -%% Unbind event -%% -%% Should return a list of tcl commands -%% Already checked for validation in bind/5 -%% -%% WS = Widget suffix for complex widgets -%% -eunbind(DB, Gstkid, TkW, Etype, WS, _Edata) -> - gstk_db:delete_event(DB, Gstkid, Etype), - P = ["bind ", TkW, WS], - Cmd = case Etype of - motion -> - [P, " <Motion> {}"]; - keypress -> - [P, " <KeyPress> {};", - P, " <Shift-KeyPress> {};", - P, " <Control-KeyPress> {};", - P, " <Control-Shift-KeyPress> {}"]; - keyrelease -> - [P, " <KeyRelease> {};", - P, " <Shift-KeyRelease> {};", - P, " <Control-KeyRelease> {};", - P, " <Control-Shift-KeyRelease> {}"]; - buttonpress -> - [P, " <ButtonPress> {}"]; - buttonrelease -> - [P, " <ButtonRelease> {}"]; - leave -> - [P, " <Leave> {}"]; - enter -> - [P, " <Enter> {}"]; - destroy -> - [P, " <Destroy> {}"]; - focus -> - [P, " <FocusIn> {};", - P, " <FocusOut> {}"]; - configure -> - [P, " <Configure> {}"] - end, - Cmd. - - -%% -%% Event item bind main function -%% -%% Should return a list of tcl commands or invalid_option -%% -item_bind(DB, Gstkid, Canvas, Item, Etype, On) -> - case On of - true -> item_ebind(DB, Gstkid, Canvas, Item, Etype, ""); - {true, Edata} -> item_ebind(DB, Gstkid, Canvas, Item, Etype, Edata); - _Other -> item_eunbind(DB, Gstkid, Canvas, Item, Etype) - end. - -%% -%% Event bind on -%% -%% Should return a list of tcl commands or invalid_option -%% -item_ebind(DB, Gstkid, Canvas, Item, Etype, Edata) -> - Eref = gstk_db:insert_event(DB, Gstkid, Etype, Edata), - P = [Canvas, " bind ", Item], - case Etype of - enter -> [P, " <Enter> {erlsend ", Eref, "}"]; - leave -> [P, " <Leave> {erlsend ", Eref, "}"]; - motion -> [P, " <Motion> {erlsend ", Eref, " [", - Canvas, " canvasx %x] [", Canvas, " canvasy %y] %x %y}"]; - keypress -> - [P, " <Key> {erlsend ", Eref," %K %N 0 0 [", - Canvas, " canvasx %x] [", Canvas, " canvasy %y]};", - P, " <Shift-Key> {erlsend ", Eref, " %K %N 1 0 [", - Canvas, " canvasx %x] [", Canvas, " canvasy %y]};", - P, " <Control-Key> {erlsend ", Eref, " %K %N 0 1 [", - Canvas, " canvasx %x] [", Canvas, " canvasy %y]};", - P, " <Control-Shift-Key> {erlsend ", Eref," %K %N 1 1 [", - Canvas, " canvasx %x] [", Canvas, " canvasy %y]}"]; - keyrelease -> - [P, " <KeyRelease> {erlsend ", Eref," %K %N 0 0 [", - Canvas, " canvasx %x] [", Canvas, " canvasy %y]};", - P, " <Shift-KeyRelease> {erlsend ", Eref, " %K %N 1 0 [", - Canvas, " canvasx %x] [", Canvas, " canvasy %y]};", - P, " <Control-KeyRelease> {erlsend ", Eref, " %K %N 0 1 [", - Canvas, " canvasx %x] [", Canvas, " canvasy %y]};", - P, " <Control-Shift-KeyRelease> {erlsend ", Eref," %K %N 1 1[", - Canvas, " canvasx %x] [", Canvas, " canvasy %y]}"]; - buttonpress -> - [P, " <Button> {erlsend ", Eref, " %b [", - Canvas, " canvasx %x] [", Canvas, " canvasy %y] %x %y}"]; - buttonrelease -> - [P, " <ButtonRelease> {erlsend ", Eref, " %b [", - Canvas, " canvasx %x] [", Canvas, " canvasy %y] %x %y}"] - end. - - -%% -%% Unbind event -%% -%% Should return a list of tcl commands -%% Already checked for validation in bind/5 -%% -item_eunbind(DB, Gstkid, Canvas, Item, Etype) -> - gstk_db:delete_event(DB, Gstkid, Etype), - P = [Canvas, " bind ", Item], - Cmd = case Etype of - enter -> [P, " <Enter> {}"]; - leave -> [P, " <Leave> {}"]; - motion -> [P, " <Motion> {}"]; - keypress -> - [P, " <KeyPress> {};", - P, " <Shift-KeyPress> {};", - P, " <Control-KeyPress> {};", - P, " <Control-Shift-KeyPress> {}"]; - keyrelease -> - [P, " <KeyRelease> {};", - P, " <Shift-KeyRelease> {};", - P, " <Control-KeyRelease> {};", - P, " <Control-Shift-KeyRelease> {}"]; - buttonpress -> [P, " <Button> {}"]; - buttonrelease -> [P, " <ButtonRelease> {}"] - end, - Cmd. - - - -event(DB, Gstkid, Etype, _Edata, Args) -> - #gstkid{owner=Ow,id=Id} = Gstkid, - Data = gstk_db:opt(DB,Gstkid,data), - gs_frontend:event(get(gs_frontend),Ow,{gs,Id,Etype,Data,Args}). |