The R13B03 release.OTP_R13B03

1 files changed, 323 insertions, 0 deletions

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 -----