The R13B03 release.OTP_R13B03

1 files changed, 319 insertions, 0 deletions

diff --git a/lib/gs/src/gstk_image.erl b/lib/gs/src/gstk_image.erl
new file mode 100644
index 0000000000..5ad37cf6de
--- /dev/null
+++ b/lib/gs/src/gstk_image.erl
@@ -0,0 +1,319 @@
+%%
+%% %CopyrightBegin%
+%% 
+%% Copyright Ericsson AB 1996-2009. All Rights Reserved.
+%% 
+%% The contents of this file are subject to the Erlang Public License,
+%% Version 1.1, (the "License"); you may not use this file except in
+%% compliance with the License. You should have received a copy of the
+%% Erlang Public License along with this software. If not, it can be
+%% retrieved online at http://www.erlang.org/.
+%% 
+%% Software distributed under the License is distributed on an "AS IS"
+%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See
+%% the License for the specific language governing rights and limitations
+%% under the License.
+%% 
+%% %CopyrightEnd%
+%%
+
+%%
+%% ------------------------------------------------------------
+%% Basic Image Type
+%% ------------------------------------------------------------
+
+-module(gstk_image).
+
+%%-----------------------------------------------------------------------------
+%% 			    BITMAP OPTIONS
+%%
+%%  Attributes:
+%%	anchor			n|w|e|s|nw|sw|ne|se|center
+%%	bg			Color
+%%	bitmap			String
+%%	coords			[{X,Y}]
+%%	data			Data
+%%	fg			Color
+%%
+%% Attributes for gifs only:
+%%      pix_val                 {{X,Y},Color}|{{{X1,Y1},{X2,Y2}},Color]
+%%      save                    String
+%%      refresh
+%%
+%%  Commands:
+%%	lower
+%%	move			{Dx, Dy}
+%%	raise
+%%	scale			{Xo, Yo, Sx, Sy}
+%%	setfocus		Bool
+%%
+%%  Events:
+%%	buttonpress		[Bool | {Bool, Data}]
+%%	buttonrelease		[Bool | {Bool, Data}]
+%%	enter			[Bool | {Bool, Data}]
+%%	keypress		[Bool | {Bool, Data}]
+%%	keyrelease		[Bool | {Bool, Data}]
+%%	leave			[Bool | {Bool, Data}]
+%%	motion			[Bool | {Bool, Data}]
+%%
+%%  Read Options:
+%%      pix_val                 {X,Y}
+%%	children
+%%	id
+%%	parent
+%%	type
+%%
+%%  Not Implemented:
+%%
+
+-export([create/3, config/3, read/3, delete/2, destroy/3, event/5,
+	 option/5,read_option/5]).
+
+-include("gstk.hrl").
+
+%%------------------------------------------------------------------------------
+%%			MANDATORY INTERFACE FUNCTIONS
+%%------------------------------------------------------------------------------
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% Function   	: create/7
+%% Purpose    	: Create a widget of the type defined in this module.
+%% Args        	: DB	  - The Database
+%%		  Objmod  - An atom, this module
+%%		  Objtype - An atom, the logical widget type
+%%		  Owner   - Pid of the creator
+%%		  Name    - An atom naming the widget
+%%		  Parent  - Gsid of the parent
+%%		  Opts    - A list of options for configuring the widget
+%%
+%% Return 	: [Gsid_of_new_widget | {bad_result, Reason}]
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+create(DB, Gstkid, Opts) ->
+    case pickout_type(Opts) of
+	bitmap ->
+	    create(bitmap,DB, Gstkid, Opts);
+	_gif ->  %%Default gif
+	    create(gif,DB, Gstkid, Opts)
+    end.
+
+create(gif,DB, Gstkid, Opts) ->
+    case pickout_coords(Opts, []) of
+	{error, Error} ->
+	    {bad_result, Error};
+	{Coords, NewOpts} ->
+	    CCmd = "image create photo",
+	    case tcl2erl:ret_atom(CCmd) of
+		Photo_item when is_atom(Photo_item) ->
+		    #gstkid{parent=Parent,owner=Owner,id=Id}=Gstkid,
+		    Pgstkid = gstk_db:lookup_gstkid(DB, Parent, Owner),
+		    SO = Pgstkid#gstkid.widget_data,
+		    CanvasTkW = SO#so.object,
+		    Photo_item_s = atom_to_list(Photo_item),
+		    gstk_db:insert_opt(DB,Id,gs:pair(coords,Opts)),
+		    Ngstkid=Gstkid#gstkid{widget=CanvasTkW,
+				       widget_data={Photo_item_s,unknown}},
+		    gstk_db:update_widget(DB,Ngstkid),
+		    MCmd = [CanvasTkW," create image ",Coords," -image ", 
+			   Photo_item_s," -anchor nw"],
+		    case gstk_canvas:make_command(NewOpts, Ngstkid,
+						 CanvasTkW, MCmd, DB) of
+			{error,Reason} -> {error,Reason};
+			Cmd when is_list(Cmd) ->
+			    case tcl2erl:ret_int(Cmd) of
+				Item when is_integer(Item) ->
+				    %% buu, not nice
+				    G2 = gstk_db:lookup_gstkid(DB,Id),
+				    NewWidget = {Photo_item_s,Item},
+				    NewGstkid = G2#gstkid{widget_data=NewWidget},
+				    gstk_db:insert_widget(DB, NewGstkid),
+				    NewGstkid;
+				Bad_result ->
+				    {error,Bad_result}
+			    end
+		    end;
+		Bad_result ->
+		    {error,Bad_result}
+	    end
+    end;
+
+create(bitmap,DB, Gstkid, Opts) ->
+    case pickout_coords(Opts, []) of
+	{error, Error} ->
+	    {bad_result, Error};
+	{Coords, NewOpts} ->
+	    #gstkid{parent=Parent,owner=Owner,id=Id}=Gstkid,
+	    Pgstkid = gstk_db:lookup_gstkid(DB, Parent, Owner),
+	    SO = Pgstkid#gstkid.widget_data,
+	    CanvasTkW = SO#so.object,
+	    gstk_db:insert_opt(DB,Id,gs:pair(coords,Opts)),
+	    Ngstkid=Gstkid#gstkid{widget=CanvasTkW, widget_data=no_item},
+	    gstk_db:update_widget(DB,Ngstkid),
+	    MCmd = [CanvasTkW," create bi ", Coords],
+	    gstk_canvas:mk_cmd_and_call(NewOpts,Ngstkid, CanvasTkW, MCmd,DB)
+    end.
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% Function   	: config/3
+%% Purpose    	: Configure a widget of the type defined in this module.
+%% Args        	: DB	  - The Database
+%%		  Gstkid   - The gstkid of the widget
+%%		  Opts    - A list of options for configuring the widget
+%%
+%% Return 	: [true | {bad_result, Reason}]
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+config(DB, Gstkid, Opts) ->
+    {Canvas, Item} = get_widget(Gstkid),
+    AItem = gstk:to_ascii(Item),
+    SCmd = [Canvas, " itemconf ", AItem],
+    gstk_canvas:mk_cmd_and_exec(Opts, Gstkid, Canvas, AItem, SCmd, DB).
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% Function   	: read/3
+%% Purpose    	: Read one option from a widget
+%% Args        	: DB	  - The Database
+%%		  Gstkid   - The gstkid of the widget
+%%		  Opt     - An option to read
+%%
+%% Return 	: [OptionValue | {bad_result, Reason}]
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+read(DB, Gstkid, Opt) ->
+    {_, Item} = get_widget(Gstkid),
+    gstk_generic:read_option(DB,Gstkid,Opt,[gstk:to_ascii(Item)]).
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% Function   	: delete/2
+%% Purpose    	: Delete widget from databas and return tkwidget to destroy
+%% Args        	: DB	  - The Database
+%%		  Gstkid   - The gstkid of the widget
+%%
+%% Return 	: TkWidget to destroy | {Parent, Objmod, Args}.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+delete(DB, Gstkid) ->
+    gstk_db:delete_widget(DB, Gstkid),
+    #gstkid{parent=P,id=ID}=Gstkid,
+    {Canvas, Item} = get_widget(Gstkid),
+    {P, ID, gstk_image, [Canvas, Item]}.
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% Function   	: destroy/3
+%% Purpose    	: Destroy a widget
+%% Args        	: DB	  - The Database
+%%		  Canvas  - The canvas tk widget
+%%		  Item    - The item number to destroy
+%%
+%% Return 	: [true | {bad_result, Reason}]
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+destroy(_DB, Canvas, Item) ->
+    gstk:exec([Canvas, " delete ", gstk:to_ascii(Item)]).
+
+
+event(DB, Gstkid, Etype, Edata, Args) ->
+    gstk_generic:event(DB, Gstkid, Etype, Edata, Args).
+
+%%------------------------------------------------------------------------------
+%%			MANDATORY FUNCTIONS
+%%------------------------------------------------------------------------------
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% Function   	: option/5
+%% Purpose    	: Take care of options
+%% Args        	: Option  - An option tuple
+%%		  Gstkid   - The gstkid of the widget
+%%		  MainW   - The main tk-widget
+%%		  Canvas  - The canvas tk-widget
+%%		  DB	  - The Database
+%%
+%% Return 	: A tuple {OptionType, OptionCmd}
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+option(Option, Gstkid, _Canvas, _DB, _AItem) ->
+    case Option of
+	{bitmap,     Bitmap} ->
+	    {ok, BF,_} = regexp:gsub(Bitmap, [92,92], "/"),
+	    {s, [" -bi @", BF]};
+	{load_gif,       File} -> 
+	    {ok, F2,_} = regexp:gsub(File, [92,92], "/"),
+	    {Photo_item, _item} = Gstkid#gstkid.widget_data,
+	    {c,[Photo_item, " configure -file ", gstk:to_ascii(F2)]};
+	{pix_val,  {Coords,Color}} ->
+	    {Photo_item, _item} = Gstkid#gstkid.widget_data,
+	    {c, [Photo_item, " put ", gstk:to_color(Color), " -to ", 
+		 coords(Coords)]};
+	{save_gif, Name} ->
+	    {Photo_item, _item} = Gstkid#gstkid.widget_data,
+	    {c, [Photo_item, " write ", gstk:to_ascii(Name)]};
+	{fg,          Color} -> {s, [" -fo ", gstk:to_color(Color)]};
+	{bg,          Color} -> {s, [" -ba ", gstk:to_color(Color)]};
+	{anchor,         How} -> {s, [" -anchor ", gstk:to_ascii(How)]};
+	_ -> invalid_option
+    end.
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% Function   	: read_option/5
+%% Return 	: The value of the option or invalid_option
+%%		  [OptionValue | {bad_result, Reason}]
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+read_option(Option, Gstkid, Canvas, _DB, AItem) ->
+    case Option of
+	anchor   -> tcl2erl:ret_atom([Canvas," itemcget ",AItem," -anchor"]);
+	bg       -> tcl2erl:ret_color([Canvas, " itemcget ", AItem, " -ba"]);
+	bitmap   -> tcl2erl:ret_file([Canvas, " itemcget ", AItem, " -bi"]);
+	fg       -> tcl2erl:ret_color([Canvas, " itemcget ", AItem, " -fo"]);
+	{pix_val,{X,Y}} ->
+	    {Photo_item, _item} = Gstkid#gstkid.widget_data,
+	    ret_photo_color([Photo_item," get ",coords({X,Y})]);
+	_ -> {bad_result, {Gstkid#gstkid.objtype, invalid_option, Option}}
+    end.
+
+ret_photo_color(Cmd) ->
+    case gstk:call(Cmd) of
+	{result,Str} ->
+	    {ok, [R,G,B],[]} = io_lib:fread("~d ~d ~d", Str),
+	    {R,G,B};
+	Bad_result -> Bad_result
+    end.
+
+
+%%------------------------------------------------------------------------------
+%%			       PRIMITIVES
+%%------------------------------------------------------------------------------
+get_widget(#gstkid{widget=Canvas,widget_data={_Photo_item,Item}}) ->
+    {Canvas,Item};
+get_widget(#gstkid{widget=Canvas,widget_data=Item}) ->
+    {Canvas,Item}.
+
+pickout_coords([{coords,Coords} | Rest], Opts) when length(Coords) == 1 ->
+    case coords(Coords) of
+	invalid ->
+	    {error, "An image must have two coordinates"};
+	RealCoords ->
+	    {RealCoords, lists:append(Rest, Opts)}
+    end;
+pickout_coords([Opt | Rest], Opts) ->
+    pickout_coords(Rest, [Opt|Opts]);
+pickout_coords([], _Opts) ->
+    {error, "An image must have two coordinates"}.
+
+coords({X,Y}) when is_number(X),is_number(Y) ->
+    [gstk:to_ascii(X), " ", gstk:to_ascii(Y), " "];
+coords([{X,Y} | R]) when is_number(X),is_number(Y) ->
+    [gstk:to_ascii(X), " ", gstk:to_ascii(Y), " ", coords(R)];
+coords({{X1,Y1},{X2,Y2}}) when is_number(X1),is_number(Y1),is_number(X2),is_number(Y2) ->
+    [gstk:to_ascii(X1), " ", gstk:to_ascii(Y1)," ",
+     gstk:to_ascii(X2), " ", gstk:to_ascii(Y2)];
+coords([_]) -> %% not a pair
+    invalid;
+coords([]) ->
+    [].
+
+
+pickout_type([{bitmap,_Str}|_Options]) ->
+    bitmap;
+pickout_type([{gif,_Str}|_Options])  ->
+    gif;
+pickout_type([]) ->
+    none;
+pickout_type([_|Tail]) ->
+    pickout_type(Tail).
+
+%% ----- Done -----
+