The R13B03 release.OTP_R13B03

1 files changed, 396 insertions, 0 deletions

diff --git a/lib/gs/src/gstk_editor.erl b/lib/gs/src/gstk_editor.erl
new file mode 100644
index 0000000000..3e0c8240e4
--- /dev/null
+++ b/lib/gs/src/gstk_editor.erl
@@ -0,0 +1,396 @@
+%%
+%% %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 Editor Type
+%% ------------------------------------------------------------
+
+-module(gstk_editor).
+
+%%------------------------------------------------------------------------------
+%% 			    CANVAS OPTIONS
+%%
+%%  Attributes:
+%%	activebg		Color
+%%	anchor			n,w,s,e,nw,se,ne,sw,center
+%%	bc			Color
+%%	bg			Color
+%%	bw			Wth
+%%	data			Data
+%%	fg			Color
+%%      font                    Font
+%%	height			Int
+%%	highlightbg		Color
+%%	highlightbw		Wth
+%%	highlightfg		Color
+%%	hscroll			Bool | top | bottom
+%%	insertbg		Color
+%%	insertbw		Wth
+%%      insertpos               {Row,Col}|'end'  (Row: 1..Max, Col: 0..Max)
+%%	justify			left|right|center
+%%	padx			Int   (Pixels)
+%%	pady			Int   (Pixels)
+%%	relief			Relief
+%%	scrollbg		Color
+%%	scrollfg		Color
+%%	selectbg		Color
+%%	selectbw		Width
+%%	selectfg		Color
+%%	vscroll			Bool | left | right
+%%	width			Int
+%%	wrap			none | char | word
+%%	x			Int
+%%	y			Int
+%%
+%%
+%%  Commands:
+%%	clear
+%%	del			{FromIdx, ToIdx} 
+%%	enable			Bool
+%%	file			String
+%%	get			{FromIdx, ToIdx} => Text
+%%	insert			{Index, Text}Index = [insert,{Row,lineend},end,{Row,Col}]
+%%	setfocus		Bool
+%%
+%%  Events:
+%%	buttonpress		[Bool | {Bool, Data}]
+%%	buttonrelease		[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
+%%
+
+%.t tag names 2.7 -> red blue (blue �r f�rgen)
+%.t tag add blue 2.1 2.10    tagga text
+%.t tag configure blue -foregr blue skapa tag
+% .t index end -> MaxRows.cols
+% .t yview moveto (Row-1)/MaxRows
+
+-export([create/3, config/3, read/3, delete/2,event/5,option/5,read_option/5]).
+
+-include("gstk.hrl").
+
+%%-----------------------------------------------------------------------------
+%%			MANDATORY INTERFACE FUNCTIONS
+%%-----------------------------------------------------------------------------
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% Function   	: create/3
+%% Purpose    	: Create a widget of the type defined in this module.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+create(DB, Gstkid, Opts) ->
+    MainW = gstk_generic:mk_tkw_child(DB,Gstkid),
+    Editor = lists:append(MainW,".z"),
+    {Vscroll, Hscroll, NewOpts} = gstk_generic:parse_scrolls(Opts),
+    WidgetD = #so{main=MainW, object=Editor,
+		 hscroll=Hscroll, vscroll=Vscroll,misc=[{1,white}]},
+    NGstkid=Gstkid#gstkid{widget=MainW, widget_data=WidgetD},
+    gstk_db:insert_widget(DB,NGstkid),
+    MandatoryCmd = ["so_create text ", MainW],
+    case gstk:call(MandatoryCmd) of
+	{result, _} ->
+	    SimplePreCmd = [MainW, " conf"],
+	    PlacePreCmd = [";place ", MainW],
+	    case gstk_generic:make_command(NewOpts, NGstkid, MainW, SimplePreCmd,
+					  PlacePreCmd, DB,Editor) of
+		{error,Reason} -> {error,Reason};
+		Cmd ->
+		    gstk:exec(Cmd),
+		    gstk:exec(
+		      [Editor," conf -bo 2 -relief sunken -highlightth 2;",
+		       MainW,".sy conf -rel sunken -bo 2;",
+		       MainW,".pad.sx conf -rel sunken -bo 2;",
+		       Editor, " tag co c1 -for white;"]),
+		    ok
+	    end
+    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,
+    Editor = SO#so.object,
+    NewOpts =
+	case {gs:assq(vscroll,Options),gs:assq(hscroll,Options)} of
+	    {false,false} -> Options;
+	    _ -> gstk_generic:parse_scrolls(Gstkid, Options)
+	end,
+    SimplePreCmd = [MainW, " conf"],
+    PlacePreCmd = [";place ", MainW],
+    gstk_generic:mk_cmd_and_exec(NewOpts, Gstkid, MainW, SimplePreCmd,
+				PlacePreCmd, DB, Editor).
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% 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.
+
+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
+%%		  Editor  - The Editor tk-widget
+%%		  DB	  - The Database
+%%
+%% Return 	: A tuple {OptionType, OptionCmd}
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+option(Option, Gstkid, _MainW, DB, Editor) ->
+    case Option of
+	{font,Font} when is_tuple(Font) ->   
+	    gstk_db:insert_opt(DB,Gstkid,Option),
+	    {c, [Editor, " conf -font ", gstk_font:choose_ascii(DB,Font)]};
+	{font_style, {{Start,End},Font}} -> % should be only style
+	    {Tag,Ngstkid} = get_style_tag(DB,Editor,Font,Gstkid),
+	    gstk_db:update_widget(DB,Ngstkid),
+	    {c, Ngstkid, [Editor, " tag ad ", Tag, " ", p_index(Start), " ",
+			 p_index(End)]};
+	{fg, {{Start,End},Color}} ->
+	    {Tag,Ngstkid} = get_color_tag(Editor,Color,Gstkid),
+	    gstk_db:update_widget(DB,Ngstkid),
+	    {c, Ngstkid, [Editor, " tag ad ", Tag, " ", p_index(Start), " ",
+			 p_index(End)]};
+	{padx,          Pad} -> {c, [Editor," conf -padx ",gstk:to_ascii(Pad)]};
+	{pady,          Pad} -> {c, [Editor," conf -pady ",gstk:to_ascii(Pad)]};
+	{selection, {From, To}} ->
+	    {c, [Editor," tag ad sel ",p_index(From)," ", p_index(To)]};
+	{vscrollpos, Row} ->
+	    {MaxRow,_Col} = ret_ed_index([Editor," ind end"]),
+	    {c, [Editor, " yv mo ",gstk:to_ascii(Row/MaxRow)]};
+	{wrap,          How} ->
+	    {c, [Editor, " conf -wrap ", gstk:to_ascii(How)]};
+	{fg,          Color} ->
+	    {c, [Editor, " conf -fg ", gstk:to_color(Color)]};
+	{insertbw,      Wth} ->
+	    {c, [Editor, " conf -insertbo ", gstk:to_ascii(Wth)]};
+	{insertbg,    Color} ->
+	    {c, [Editor, " conf -insertba ", gstk:to_color(Color)]};
+	{insertpos,    Index} ->
+	    {c, [Editor, " m s insert ", p_index(Index)]};
+	{insert, {Index, Text}} ->
+	    {c, [Editor, " ins ", p_index(Index), " ", gstk:to_ascii(Text)]};
+	{del,      {From, To}} ->
+	    {c, [Editor, " del ", p_index(From), " ", p_index(To)]};
+	{overwrite, {Index, Text}} ->
+	    AI = p_index(Index),
+	    Len = gstk:to_ascii(lists:flatlength(Text)),
+	    {c, [Editor, " del ",AI," \"",AI,"+",Len,"c\";",
+		 Editor, " ins ",AI," ", gstk:to_ascii(Text)]};
+	clear       -> {c, [Editor, " delete 1.0 end"]};
+	{load,        File} ->
+	    {ok, F2,_} = regexp:gsub(File, [92,92], "/"),
+	    case gstk:call(["ed_load ", Editor, " ", gstk:to_ascii(F2)]) of
+		{result,    _} -> none;
+		{bad_result,Re} -> 
+		    {error,{no_such_file,editor,load,F2,Re}}
+	    end;
+	{save, File} ->
+	    {ok, F2,_} = regexp:gsub(File, [92,92], "/"),
+	    case gstk:call(["ed_save ",Editor," ",gstk:to_ascii(F2)]) of
+		{result,    _} -> none;
+		{bad_result,Re} -> 
+		    {error,{no_such_file,editor,save,F2,Re}}
+	    end;
+	{enable,      true} -> {c, [Editor, " conf -state normal"]};
+	{enable,     false} -> {c, [Editor, " conf -state disabled"]};
+	
+	{setfocus,     true} -> {c, ["focus ", Editor]};
+	{setfocus,    false} -> {c, ["focus ."]};
+	_ -> invalid_option
+    end.
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% Function   	: read_option/5
+%% Purpose    	: Take care of a read option
+%% Return 	: The value of the option or invalid_option
+%%		  [OptionValue | {bad_result, Reason}]
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+read_option(Option,GstkId,_MainW,DB,Editor) ->
+    case Option of
+	font -> gstk_db:opt(DB,GstkId,font,undefined);
+	padx          -> tcl2erl:ret_atom([Editor," cg -padx"]);
+	pady          -> tcl2erl:ret_atom([Editor," cg -pady"]);
+	enable        -> tcl2erl:ret_enable([Editor," cg -st"]);
+	fg            -> tcl2erl:ret_color([Editor," cg -fg"]);
+	{fg, Pos} ->
+	    L=tcl2erl:ret_list([Editor," tag nam ", p_index(Pos)]),
+	    SO = GstkId#gstkid.widget_data,
+	    case last_tag_val(undefined, $c, L, SO#so.misc) of
+		undefined -> tcl2erl:ret_color([Editor," cg -fg"]);
+		Color -> Color
+	    end;
+	{font_style, Pos} ->
+	    L=tcl2erl:ret_list([Editor," tag nam ", p_index(Pos)]),
+	    SO = GstkId#gstkid.widget_data,
+	    case last_tag_val(undefined, $f, L, SO#so.misc) of
+		undefined -> 'my style? nyi';
+		Style -> Style
+	    end;
+	selection -> ret_ed_indexes([Editor," tag ne sel 1.0"]);
+	char_height   -> tcl2erl:ret_int([Editor, " cg -he"]);
+	char_width   -> tcl2erl:ret_int([Editor, " cg -wi"]);
+	insertbg      -> tcl2erl:ret_color([Editor," cg -insertba"]);
+	insertbw      -> tcl2erl:ret_int([Editor," cg -insertbo"]);
+	insertpos     -> ret_ed_index([Editor, " ind insert"]);
+	setfocus      -> tcl2erl:ret_focus(Editor, "focus");
+	wrap          -> tcl2erl:ret_atom([Editor," cg -wrap"]);
+	size          -> {MaxRow,_Col} = ret_ed_index([Editor," ind end"]),
+			 MaxRow-1;
+	vscrollpos       ->
+	    {MaxRow,_Col} = ret_ed_index([Editor," ind end"]),
+	    [Top,_Bot] = tcl2erl:ret_list([Editor," yvi"]),
+	    round(Top*(MaxRow-1))+1;
+	{get, {From, To}} ->
+	    tcl2erl:ret_str([Editor, " get ", p_index(From), " ", p_index(To)]);
+	_ -> {bad_result, {GstkId#gstkid.objtype, invalid_option, Option}}
+    end.
+
+
+%%------------------------------------------------------------------------------
+%%			       PRIMITIVES
+%%------------------------------------------------------------------------------
+
+p_index({Line, lineend}) -> [$",gstk:to_ascii(Line), ".1 lineend",$"];
+p_index({Line, Char}) -> [gstk:to_ascii(Line), $., gstk:to_ascii(Char)];
+p_index(insert)       -> "insert";
+p_index('end')        -> "end";
+p_index(Idx)          -> gs:error("bad index in editor: ~w~n",[Idx]),0.
+
+ret_ed_index(Cmd) ->
+    case gstk:call(Cmd) of
+	{result, Val} ->
+	    case io_lib:fread("~d.~d", Val) of
+		{ok, [Row,Col], []} -> {Row, Col};
+		Other -> {bad_result, Other}
+	    end;
+	Bad_result -> Bad_result
+    end.
+
+ret_ed_indexes(Cmd) ->
+    case gstk:call(Cmd) of
+	{result, ""} -> undefined;
+	{result, Val} ->
+	    case io_lib:fread("~d.~d ~d.~d", Val) of
+		{ok, [Row1,Col1,Row2,Col2], []} -> {{Row1, Col1}, {Row2,Col2}};
+		Other -> {bad_result, Other}
+	    end;
+	Bad_result -> Bad_result
+    end.
+
+
+%%----------------------------------------------------------------------
+%% Returns: {Tag text(), NewGstkId}
+%%----------------------------------------------------------------------
+%% The misc field of the so record is a list of {ColorNo, Color|Font|...}
+get_color_tag(Editor,Color,Gstkid) ->
+    SO = Gstkid#gstkid.widget_data,
+    Tags = SO#so.misc,
+    case lists:keysearch(Color, 2, Tags) of
+%	{value, {No, _}} -> {["c",gstk:to_ascii(No)], Gstkid};
+%	false -> % don't reuse tags, priority order spoils that
+	_Any ->
+	    {No,_} = lists:max(Tags),
+	    N=No+1,
+	    SO2 = SO#so{misc=[{N,Color}|Tags]},
+	    TagStr=["c",gstk:to_ascii(N)],
+	    gstk:exec([Editor," tag co ",TagStr," -for ", gstk:to_color(Color)]),
+	    {TagStr,Gstkid#gstkid{widget_data=SO2}}
+    end.
+
+get_style_tag(DB,Editor,Style,Gstkid) ->
+    SO = Gstkid#gstkid.widget_data,
+    Tags = SO#so.misc,
+    case lists:keysearch(Style, 2, Tags) of
+%	{value, {No, _}} -> {["f",gstk:to_ascii(No)], Gstkid};
+%	false -> % don't reuse tags, priority order spoils that
+	_Any -> 
+	    {No,_} = lists:max(Tags),
+	    N=No+1,
+	    SO2 = SO#so{misc=[{N,Style}|Tags]},
+	    TagStr=["f",gstk:to_ascii(N)],
+	    gstk:exec([Editor," tag co ",TagStr," -font ",
+		      gstk_font:choose_ascii(DB,Style)]), % should be style only
+	    {TagStr,Gstkid#gstkid{widget_data=SO2}}
+    end.
+
+%%----------------------------------------------------------------------
+%% Purpose: Given a list of tags for a char, return its visible color
+%% (that is that last color tag in the list).
+%%----------------------------------------------------------------------
+last_tag_val(TagVal, _Chr, [], _TagDict) -> TagVal;
+last_tag_val(TagVal, Chr, [Tag|Ts],TagDict) ->
+    case atom_to_list(Tag) of
+	[Chr|ANo] ->
+	    No = list_to_integer(ANo),
+	    last_tag_val(gs:val(No, TagDict),Chr,Ts,TagDict);
+	_NoAcolor ->
+	    last_tag_val(TagVal,Chr, Ts,TagDict)
+    end.
+    
+%%% ----- Done -----