gstk_generic.erl

来自「OTP是开放电信平台的简称」· ERL 代码 · 共 1,085 行 · 第 1/3 页

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}).