gstk_menuitem.erl

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

	{underline,     Int} -> {s, [" -underl ", gstk:to_ascii(Int)]};
        {activebg,    Color} -> {s, [" -activeba ", gstk:to_color(Color)]};
        {activefg,    Color} -> {s, [" -activefo ", gstk:to_color(Color)]};
        {bg,          Color} -> {s, [" -backg ", gstk:to_color(Color)]};
        {enable,       true} -> {s, " -st normal"};
        {enable,      false} -> {s, " -st disabled"};
        {fg,          Color} -> {s, [" -foreg ", gstk:to_color(Color)]};
	_Other -> 
	    case lists:member(Kind,[radio,check]) of
		true -> 
		    case Option of
			{group,Group} -> {s, [" -var ", gstk:to_ascii(Group)]};
			{selectbg,Col} -> {s,[" -selectc ",gstk:to_color(Col)]};
			_ -> invalid_option
		    end;
		_ -> invalid_option
	    end
    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,_TkW,DB,_) ->
    ItemId = GstkId#gstkid.id,
    MenuId = GstkId#gstkid.parent,
    MenuGstkid = gstk_db:lookup_gstkid(DB, MenuId),
    MenuW = MenuGstkid#gstkid.widget,
    Idx = gstk_menu:lookup_menuitem_pos(DB, MenuGstkid, ItemId),
    PreCmd = [MenuW, " entrycg ", gstk:to_ascii(Idx)],
    case Option of
	accelerator   -> tcl2erl:ret_str([PreCmd, " -acc"]);
	activebg      -> tcl2erl:ret_color([PreCmd, " -activeba"]);
	activefg      -> tcl2erl:ret_color([PreCmd, " -activefo"]);
	bg            -> tcl2erl:ret_color([PreCmd, " -backg"]);
	fg            -> tcl2erl:ret_color([PreCmd, " -foreg"]);
	group         -> read_group(GstkId, Option);
	groupid       -> read_groupid(GstkId, Option);
	index         -> Idx;
	itemtype      -> case GstkId#gstkid.widget_data of
			     {Type, _, _, _} -> Type;
			     {Type, _, _} -> Type;
			     Type -> Type
			 end;
	enable        -> tcl2erl:ret_enable([PreCmd, " -st"]);
	font -> gstk_db:opt(DB,GstkId,font,undefined);
	label         -> tcl2erl:ret_label(["list [", PreCmd, " -lab] [",
					    PreCmd, " -bit]"]);
	selectbg      -> tcl2erl:ret_color([PreCmd, " -selectco"]);
	underline     -> tcl2erl:ret_int([PreCmd, " -underl"]);
	value         -> tcl2erl:ret_atom([PreCmd, " -val"]);
	select        -> read_select(MenuW, Idx, GstkId);
	click         -> gstk_db:is_inserted(DB, GstkId, click);
	_ -> {bad_result, {GstkId#gstkid.objtype, invalid_option, Option}}
    end.

read_group(Gstkid, Option) ->
    case Gstkid#gstkid.widget_data of
	{_, G, _, _} -> G;
	{_, G, _}    -> G;
	_Other -> {bad_result,{Gstkid#gstkid.objtype, invalid_option, Option}}
    end.

read_groupid(Gstkid, Option) ->
    case Gstkid#gstkid.widget_data of
	{_, _, Gid, _} -> Gid;
	{_, _, Gid}    -> Gid;
	_Other -> {bad_result,{Gstkid#gstkid.objtype, invalid_option, Option}}
    end.




read_select(TkMenu, Idx, Gstkid) ->
    case Gstkid#gstkid.widget_data of
	{radio, _, _, _} ->
	    Cmd = ["list [set x [", TkMenu, " entrycg ", gstk:to_ascii(Idx),
		   " -var];global $x;set $x] [", TkMenu,
		   " entrycg ", gstk:to_ascii(Idx)," -val]"],
	    case tcl2erl:ret_tuple(Cmd) of
		{X, X} -> true;
		_Other  -> false
	    end;
	{check, _, _} ->
	    Cmd = ["set x [", TkMenu, " entrycg ", gstk:to_ascii(Idx),
		   " -var];global $x;set $x"],
	    tcl2erl:ret_bool(Cmd);
	_Other ->
	    {error,{invalid_option,menuitem,select}}
    end.



%%-----------------------------------------------------------------------------
%%			       PRIMITIVES
%%-----------------------------------------------------------------------------

%% create version
fix_group_and_value(Opts, DB, Owner) ->
    {G, GID, V, NOpts} = fgav(Opts, erlNIL, erlNIL, erlNIL, []),
    RV = case V of
	     erlNIL ->
		 list_to_atom(lists:concat([v,gstk_db:counter(DB,value)]));
	     Other0 -> Other0
	 end,
    NG = case G of
	       erlNIL -> mrb;
	       Other1 -> Other1
	   end,
    RGID = case GID of
	       erlNIL -> {mrbgrp, NG, Owner};
	       Other2 -> Other2
	   end,
    RG = gstk_db:insert_bgrp(DB, RGID),
    {NG, RGID, RV, [{group, RG}, {value, RV} | NOpts]}.
    
%% config version
fix_group_and_value(Opts, DB, Owner, Gstkid) ->
    {Type, RG, RGID, RV} = Gstkid#gstkid.widget_data,
    {G, GID, V, NOpts} = fgav(Opts, RG, RGID, RV, []),
    case {G, GID, V} of
	{RG, RGID, RV} ->
	    {NOpts, Gstkid};
	{NG, RGID, RV} ->
	    NGID = {rbgrp, NG, Owner},
	    gstk_db:delete_bgrp(DB, RGID),
	    NRG = gstk_db:insert_bgrp(DB, NGID),
	    NGstkid = Gstkid#gstkid{widget_data={Type,NG,NGID,RV}},
	    gstk_db:insert_widget(DB, NGstkid),
	    {[{group, NRG} | NOpts], NGstkid};
	{RG, RGID, NRV} ->
	    NGstkid = Gstkid#gstkid{widget_data={Type,RG,RGID,NRV}},
	    gstk_db:insert_widget(DB, NGstkid),
	    {[{value,NRV} | NOpts], NGstkid};
	{_, NGID, RV} when NGID =/= RGID ->
	    gstk_db:delete_bgrp(DB, RGID),
	    NRG = gstk_db:insert_bgrp(DB, NGID),
	    NGstkid = Gstkid#gstkid{widget_data={Type,RG,NGID,RV}},
	    gstk_db:insert_widget(DB, NGstkid),
	    {[{group, NRG} | NOpts], NGstkid};
	{_, NGID, NRV} when NGID =/= RGID ->
	    gstk_db:delete_bgrp(DB, RGID),
	    NRG = gstk_db:insert_bgrp(DB, NGID),
	    NGstkid = Gstkid#gstkid{widget_data={Type,RG,NGID,NRV}},
	    gstk_db:insert_widget(DB, NGstkid),
	    {[{group, NRG}, {value,NRV} | NOpts], NGstkid};
	{NG, RGID, NRV} ->
	    NGID = {rbgrp, NG, Owner},
	    gstk_db:delete_bgrp(DB, RGID),
	    NRG = gstk_db:insert_bgrp(DB, NGID),
	    NGstkid = Gstkid#gstkid{widget_data={Type,NG,NGID,NRV}},
	    gstk_db:insert_widget(DB, NGstkid),
	    {[{group, NRG}, {value,NRV} | NOpts], NGstkid}
    end.



fgav([{group, G} | Opts], _, GID, V, Nopts) ->
    fgav(Opts, G, GID, V, Nopts);

fgav([{groupid, GID} | Opts], G, _, V, Nopts) ->
    fgav(Opts, G, GID, V, Nopts);

fgav([{value, V} | Opts], G, GID, _, Nopts) ->
    fgav(Opts, G, GID, V, Nopts);

fgav([Opt | Opts], G, GID, V, Nopts) ->
    fgav(Opts, G, GID, V, [Opt | Nopts]);

fgav([], Group, GID, Value, Opts) ->
    {Group, GID, Value, Opts}.


%% check button version
%% create version
fix_group(Opts, DB, Owner) ->
    {G, GID, NOpts} = fg(Opts, erlNIL, erlNIL, []),
    NG = case G of
	       erlNIL ->
		 Vref = gstk_db:counter(DB, variable),
		 list_to_atom(lists:flatten(["mcb", gstk:to_ascii(Vref)]));
	       Other1 -> Other1
	   end,
    RGID = case GID of
	       erlNIL -> {mcbgrp, NG, Owner};
	       Other2 -> Other2
	   end,
    RG = gstk_db:insert_bgrp(DB, RGID),
    {NG, RGID, [{group, RG} | NOpts]}.
    
%% config version
fix_group(Opts, DB, Owner, Gstkid) ->
    {Type, RG, RGID} = Gstkid#gstkid.widget_data,
    {G, GID, NOpts} = fg(Opts, RG, RGID, []),
    case {G, GID} of
	{RG, RGID} ->
	    {NOpts, Gstkid};
	{NG, RGID} ->
	    NGID = {cbgrp, NG, Owner},
	    gstk_db:delete_bgrp(DB, RGID),
	    NRG = gstk_db:insert_bgrp(DB, NGID),
	    NGstkid = Gstkid#gstkid{widget_data={Type,NG,NGID}},
	    gstk_db:insert_widget(DB, NGstkid),
	    {[{group, NRG} | NOpts], NGstkid};
	{_, NGID} when NGID =/= RGID ->
	    gstk_db:delete_bgrp(DB, RGID),
	    NRG = gstk_db:insert_bgrp(DB, NGID),
	    NGstkid = Gstkid#gstkid{widget_data={Type,RG,NGID}},
	    gstk_db:insert_widget(DB, NGstkid),
	    {[{group, NRG} | NOpts], NGstkid}
    end.



fg([{group, G} | Opts], _, GID, Nopts) ->
    fg(Opts, G, GID, Nopts);

fg([{groupid, GID} | Opts], G, _, Nopts) ->
    fg(Opts, G, GID, Nopts);

fg([Opt | Opts], G, GID, Nopts) ->
    fg(Opts, G, GID, [Opt | Nopts]);

fg([], Group, GID, Opts) ->
    {Group, GID, Opts}.



parse_opts(Opts, TkMenu) ->
    parse_opts(Opts, TkMenu, none, none, []).


parse_opts([Option | Rest], TkMenu, Idx, Type, Options) ->
    case Option of
	{index,    I} -> parse_opts(Rest, TkMenu, I, Type, Options);
	{itemtype, T} -> parse_opts(Rest, TkMenu, Idx, T, Options);
	_Other         -> parse_opts(Rest, TkMenu, Idx, Type,[Option | Options])
    end;
parse_opts([], TkMenu, Index, Type, Options) ->
    RealIdx =
	case Index of
	    Idx when is_integer(Idx) -> Idx;
	    last  -> find_last_index(TkMenu);
	    Other -> gs:error("Invalid index ~p~n",[Other])
	end,
    {RealIdx, Type, Options}.

find_last_index(TkMenu) ->
    case tcl2erl:ret_int([TkMenu, " index last"]) of
	Last when is_integer(Last) -> Last+1;
	none  -> 0;
	Other -> gs:error("Couldn't find index ~p~n",[Other])
    end.

cbind({true, Edata}, Gstkid, TkMenu, Index, Type, DB) ->
    Eref = gstk_db:insert_event(DB, Gstkid, click, Edata),
    IdxStr = gstk:to_ascii(Index),
    case Type of
	normal ->
	    Cmd = [" -command {erlsend ", Eref,
		   " \\\"[",TkMenu," entrycg ",IdxStr," -label]\\\" ",
		   IdxStr,"}"],
	    {s, Cmd};
	check ->
	    Cmd = [" -command {erlsend ", Eref,
		   " \[expr \$[", TkMenu, " entrycg ",IdxStr," -var]\] \\\"[",
		   TkMenu, " entrycg ",IdxStr," -label]\\\" ",IdxStr,"}"],
	    {s, Cmd};
	radio ->
	    Cmd = [" -command {erlsend ", Eref,
		   " [", TkMenu, " entrycg ",IdxStr," -var] \\\"[",
		   TkMenu, " entrycg ",IdxStr," -label]\\\" ",IdxStr,"}"],
	    {s, Cmd};
	_Other ->
	    none
    end;

cbind({false, _}, Gstkid, _TkMenu, _Index, _Type, DB) ->
    gstk_db:delete_event(DB, Gstkid, click),
    none;

cbind(On, Gstkid, TkMenu, Index, Type, DB) when is_atom(On) ->
    cbind({On, []}, Gstkid, TkMenu, Index, Type, DB).


%%% ----- Done -----