From 84adefa331c4159d432d22840663c38f155cd4c1 Mon Sep 17 00:00:00 2001 From: Erlang/OTP Date: Fri, 20 Nov 2009 14:54:40 +0000 Subject: The R13B03 release. --- lib/gs/src/gstk_radiobutton.erl | 342 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 342 insertions(+) create mode 100644 lib/gs/src/gstk_radiobutton.erl (limited to 'lib/gs/src/gstk_radiobutton.erl') diff --git a/lib/gs/src/gstk_radiobutton.erl b/lib/gs/src/gstk_radiobutton.erl new file mode 100644 index 0000000000..fac150e010 --- /dev/null +++ b/lib/gs/src/gstk_radiobutton.erl @@ -0,0 +1,342 @@ +%% +%% %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 Radiobutton Type +%% ------------------------------------------------------------ + +-module(gstk_radiobutton). + +%%------------------------------------------------------------------------------ +%% RADIOBUTTON OPTIONS +%% +%% Attributes: +%% activebg Color +%% activefg Color +%% align n,w,s,e,nw,se,ne,sw,center +%% anchor n,w,s,e,nw,se,ne,sw,center +%% bg Color +%% bw Int +%% data Data +%% disabledfg Color +%% enable Bool +%% fg Color +%% group Atom +%% groupid Groupid +%% height Int +%% highlightbg Color +%% highlightbw Int +%% highlightfg Color +%% justify left|right|center +%% label {text, String} | {image, BitmapFile} +%% padx Int (Pixels) +%% pady Int (Pixels) +%% relief Relief [flat|raised|sunken|ridge|groove] +%% selectbg Color +%% underline Int +%% value Atom +%% width Int +%% wraplength Int +%% x Int +%% y Int +%% +%% Commands: +%% flash +%% invoke +%% select Bool +%% setfocus Bool +%% +%% Events: +%% buttonpress [Bool | {Bool, Data}] +%% buttonrelease [Bool | {Bool, Data}] +%% click [Bool | {Bool, Data}] +%% configure [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 +%% +%% Not Implemented: +%% cursor ?????? +%% focus ?????? (-takefocus) +%% font ?????? +%% + +-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) -> + TkW = gstk_generic:mk_tkw_child(DB,GstkId), + {G, GID, V, NOpts} = fix_group_and_value(Opts, DB, GstkId#gstkid.owner), + NGstkId=GstkId#gstkid{widget=TkW,widget_data={G, GID, V}}, + PlacePreCmd = [";place ", TkW], + case gstk_generic:make_command(NOpts, NGstkId, TkW, "", PlacePreCmd, DB) of + {error,Reason} -> {error,Reason}; + Cmd when is_list(Cmd) -> + gstk:exec(["radiobutton ", TkW," -bo 2 -indi true ",Cmd]), + NGstkId + 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) -> + TkW = Gstkid#gstkid.widget, + {NOpts, NGstkid} = fix_group_and_value(Opts, DB, Gstkid#gstkid.owner, Gstkid), + SimplePreCmd = [TkW, " conf"], + PlacePreCmd = [";place ", TkW], + gstk_generic:mk_cmd_and_exec(NOpts,NGstkid,TkW,SimplePreCmd,PlacePreCmd,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) -> + gstk_generic:read_option(DB, Gstkid, Opt). + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% 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), + {_, Gid, _} = Gstkid#gstkid.widget_data, + gstk_db:delete_bgrp(DB, Gid), + 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, Etype, Edata, Args) -> + Arg2 = case Etype of + click -> + [Text, _Grp | Rest] = Args, + {G, _Gid, V} = Gstkid#gstkid.widget_data, + [Text, G, V | Rest]; + _Other -> + Args + end, + gstk_generic:event(DB, Gstkid, Etype, Edata, Arg2). + + + +%%------------------------------------------------------------------------------ +%% MANDATORY FUNCTIONS +%%------------------------------------------------------------------------------ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : option/4 +%% Purpose : Take care of options +%% Args : Option - An option tuple +%% Gstkid - The gstkid of the widget +%% TkW - The tk-widget +%% DB - The Database +%% +%% Return : A tuple {OptionType, OptionCmd} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +option(Option, Gstkid, TkW, DB,_) -> + case Option of + {disabledfg, Color} -> {s, [" -disabledforegr ", gstk:to_color(Color)]}; + {group, Group} -> {s, [" -var ", gstk:to_ascii(Group)]}; + {selectbg, Color} -> {s, [" -selectc ", gstk:to_color(Color)]}; + {underline, Int} -> {s, [" -un ", gstk:to_ascii(Int)]}; + {value, V} -> {s, [" -val ", gstk:to_ascii(V)]}; + {wraplength, Int} -> {s, [" -wr ", gstk:to_ascii(Int)]}; + flash -> {c, [TkW, " f;"]}; + invoke -> {c, [TkW, " i;"]}; + {select, true} -> {c, [TkW, " se;"]}; + {select, false} -> {c, [TkW, " des;"]}; + {click, On} -> cbind(DB, Gstkid, click, On); + _ -> invalid_option + end. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Function : read_option/4 +%% 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, TkW,DB,_) -> + case Option of + disabledfg -> tcl2erl:ret_color([TkW," cg -disabledforegr"]); + group -> {G, _, _} = Gstkid#gstkid.widget_data, G; + groupid -> {_, Gid, _} = Gstkid#gstkid.widget_data, Gid; + selectbg -> tcl2erl:ret_color([TkW," cg -selectc"]); + underline -> tcl2erl:ret_int([TkW," cg -un"]); + value -> {_, _, V} = Gstkid#gstkid.widget_data, V; + wraplength -> tcl2erl:ret_int([TkW," cg -wr"]); + + select -> + Cmd = ["list [set x [",TkW," cg -var];global $x;set $x] [", + TkW," cg -val]"], + case tcl2erl:ret_tuple(Cmd) of + {X, X} -> true; + _Other -> false + end; + + click -> gstk_db:is_inserted(DB, Gstkid, click); + _ -> {bad_result, {Gstkid#gstkid.objtype, invalid_option, Option}} + 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 -> rb; + Other1 -> Other1 + end, + RGID = case GID of + erlNIL -> {rbgrp, 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) -> + {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={NG,NGID,RV}}, + gstk_db:insert_widget(DB, NGstkid), + {[{group, NRG} | NOpts], NGstkid}; + {RG, RGID, NRV} -> + NGstkid = Gstkid#gstkid{widget_data={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={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={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={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}. + +%% +%% Config bind +%% +cbind(DB, Gstkid, Etype, On) -> + TkW = Gstkid#gstkid.widget, + Cmd = case On of + {true, Edata} -> + Eref = gstk_db:insert_event(DB, Gstkid, Etype, Edata), + [" -command {erlsend ", Eref, + " \\\"[", TkW, " cg -text]\\\" [", TkW, " cg -var]}"]; + true -> + Eref = gstk_db:insert_event(DB, Gstkid, Etype, ""), + [" -command {erlsend ", Eref, + " \\\"[", TkW, " cg -text]\\\" [", TkW, " cg -var]}"]; + _Other -> + gstk_db:delete_event(DB, Gstkid, Etype), + " -command {}" + end, + {s, Cmd}. + +%% ----- Done ----- + -- cgit v1.2.3