aboutsummaryrefslogtreecommitdiffstats
path: root/lib/gs/src/gstk_menu.erl
diff options
context:
space:
mode:
Diffstat (limited to 'lib/gs/src/gstk_menu.erl')
-rw-r--r--lib/gs/src/gstk_menu.erl266
1 files changed, 266 insertions, 0 deletions
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 -----
generated by cgit v1.2.3 (git 2.25.1) at 2024-07-11 21:31:55 +0000