Bwidget Source Code
View Ticket
Not logged in
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.
Ticket UUID: a8705e5fd9a8cb7ce4e803c94d0a8b9f60bf6607
Title: Add Widget::which procedure
Type: Patch Version: 1.9.7
Submitter: anonymous Created on: 2014-05-14 09:57:59
Subsystem: (unused) Assigned To: nobody
Priority: 5 Medium Severity: Minor
Status: Deleted Last Modified: 2014-05-19 13:07:40
Resolution: Duplicate Closed By: oehhar
    Closed on: 2014-05-19 13:07:40
Description:
From: Adrián Medraño Calvo <[email protected]>

Add new procedure Widget::which (as in [namespace which]), that returns
the fully qualified name for a widget option or widget variable.

The new procedure provides access to the fully qualifed name for a widget
variable (i.e, those created with Widget::getVariable) allowing, for example,
setting traces on such variables.

The new procedure subsumes the [Widget::varForOption] functionality. The latter
command has been rewriten so as to not duplicate code.

In order to mantain compatibility, the new procedure throws an error when
requesting the fully-qualified variable name for a non-existing option, as did
[Widget::varForOption]. This limitation does not exist for widget variables,
as it would prevent setting traces before their creation.
---
 bwidget-1.9.7/widget.tcl | 70 +++++++++++++++++++++++++++++++++++++++---------
 1 file changed, 58 insertions(+), 12 deletions(-)

diff --git a/bwidget-1.9.7/widget.tcl b/bwidget-1.9.7/widget.tcl
index d4748f3..6a40832 100755
--- a/bwidget-1.9.7/widget.tcl
+++ b/bwidget-1.9.7/widget.tcl
@@ -1487,11 +1487,67 @@ proc Widget::traverseTo { w } {
 }
 
 
+# Widget::which --
+#
+#	Retrieve a fully qualified variable name for the specified option or
+#	widget variable.
+#
+#	If the option is not one for which a variable exists, throw an error
+#	(ie, those options that map directly to widget options).
+#
+#	For widget variables, return the fully qualified name even if the
+#	variable had not been previously set, in order to allow adding variable
+#	traces prior to their creation.
+#
+# Arguments:
+#	path	megawidget to get an option var for.
+#	type	either -option or -variable.
+#	name    name of the option or widget variable.
+#
+# Results:
+#	Fully qualified name of the variable for the option or the widget
+#	variable.
+#
+proc Widget::which {path args} {
+    switch -- [llength $args] {
+	1 {
+	    set type -option;
+	    set name [lindex $args 0];
+	}
+	2 {
+	    set type [lindex $args 0];
+	    set name [lindex $args 1];
+	}
+	default {
+	    return -code error "incorrect number of arguments";
+	}
+    }
+
+    variable _class;
+    set class $_class($path);
+
+    switch -- $type {
+	-option {
+	    upvar 0 ${class}::$path:opt pathopt;
+
+	    if { ![info exists pathopt($option)] } {
+		error "unable to find variable for option \"$option\"";
+	    }
+
+	    return ::Widget::${class}::${path}:opt(${name});
+	}
+	-variable {
+	    return ${class}::${path}:${name};
+	}
+    }
+}
+
 # Widget::varForOption --
 #
 #	Retrieve a fully qualified variable name for the option specified.
 #	If the option is not one for which a variable exists, throw an error 
-#	(ie, those options that map directly to widget options).
+#	(ie, those options that map directly to widget options). Superseded by
+#	Widget::which.
 #
 # Arguments:
 #	path	megawidget to get an option var for.
@@ -1501,17 +1557,7 @@ proc Widget::traverseTo { w } {
 #	varname	name of the variable, fully qualified, suitable for tracing.
 
 proc Widget::varForOption {path option} {
-    variable _class
-    variable _optiontype
-
-    set class $_class($path)
-    upvar 0 ${class}::$path:opt pathopt
-
-    if { ![info exists pathopt($option)] } {
-	error "unable to find variable for option \"$option\""
-    }
-    set varname "::Widget::${class}::$path:opt($option)"
-    return $varname
+    return [::Widget::which $path -option $option];
 }
 
 # Widget::getVariable --
-- 
1.9.2