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: 023a631b20827c15ae93cc69c20153bd76425ec6
Title: Lower-cased namespaces not supported
Type: Patch Version: 1.9.8
Submitter: anonymous Created on: 2014-12-05 15:17:16
Subsystem: (unused) Assigned To: oehhar
Priority: 5 Medium Severity: Important
Status: Closed Last Modified: 2015-03-18 13:18:52
Resolution: Accepted Closed By: oehhar
    Closed on: 2015-03-18 13:18:52
Description:
BWidget codebase assumes that megawidget's code exists in a namespace named exactly like the class. This forbids having megawidget code in lower-cased namespaces, as widget classes must be upper-case in order to avoid confusing the option database.

The following patch adds a new option -namespace to Widget::define, allowing specifying the namespace where widget code lives, when it is different from the class name. The widget dispatcher and the use procedure are now created in that namespace as well. Compatibility is maintained with BWidget's lazy-loading (widget are not defined when invoking their use procedure).

~~~
diff --git i/src/bwidget-1.9.8/BWman/Widget.html w/src/bwidget-1.9.8/BWman/Widget.html
index c0560e8..27b274c 100644
--- i/src/bwidget-1.9.8/BWman/Widget.html
+++ w/src/bwidget-1.9.8/BWman/Widget.html
@@ -337,6 +337,9 @@ string defining the set.
     <li><i>class</i> is the name of the new widget class.</li>
     <li><i>filename</i> is the name of the file (without extension) in the
     BWidget distribution that defines this class.</li>
+    <li><i>?-classonly?</i> If present, the class is not setup.</li>
+    <li><i>?-namespace ns?</i> The namespace where the widget's procedures live
+    in; defaults to the class name.</li>
 </ul>
 
     <p>
@@ -346,14 +349,14 @@ string defining the set.
     </p>
 
     <p>
-    This command does several things to setup the new class.  First, it
-    creates an alias in the global namespace for the name of the class
-    that points to the class's ::create subcommand.  Second, it defines
-    a ::use subcommand for the class which other classes can use to load
-    this class on the fly.  Lastly, it creates a default binding to the
-    &lt;Destroy&gt; event for the class that calls Widget::destroy on
-    the path.  This is the default setup for almost all widgets in the
-    BWidget package.
+    If <i>-classonly</i> option is not given this command does several things to
+    setup the new class.  First, it creates an alias in the global namespace for
+    the name of the class that points to the class's ::create subcommand.
+    Second, it defines a ::use subcommand for the class which other classes can
+    use to load this class on the fly.  Lastly, it creates a default binding to
+    the &lt;Destroy&gt; event for the class that calls Widget::destroy on the
+    path.  This is the default setup for almost all widgets in the BWidget
+    package.
     </p>
 
 </DD></DL>
diff --git i/src/bwidget-1.9.8/widget.tcl w/src/bwidget-1.9.8/widget.tcl
index 4409018..7edb114 100644
--- i/src/bwidget-1.9.8/widget.tcl
+++ w/src/bwidget-1.9.8/widget.tcl
@@ -402,29 +402,81 @@ proc Widget::declare { class optlist } {
 }
 
 
+# ----------------------------------------------------------------------------
+#  Command Widget::define
+#  	Declares a new class and loads its dependencies.
+#
+# Arguments:
+#	class		megawidget class
+#	filename	file where the class resides
+#	options    	The following options are supported:
+#			-classonly	Prevents megawidget setup: creation of
+#					megawidget alias, binding of the
+#					<Destroy> event and stubbing of the
+#					'use' procedure.
+#			-namespace ns	Indicate the namespace where the
+#					megawidget's procedures reside. Defaults
+#					to ::${class}.
+#	dependencies   	classes the class being defined depends on.
+#
+# ----------------------------------------------------------------------------
 proc Widget::define { class filename args } {
     variable ::BWidget::use
+    set classonly 0;
+    set ns ::${class};
+    for {set i 0; set n [llength $args]} {$i < $n} {incr i} {
+	set option [lindex $args $i];
+	switch -- $option {
+	    -classonly {
+		set classonly 1;
+	    }
+	    -namespace {
+		incr i;
+		set ns [lindex $args $i];
+	    }
+	    default {
+		# stop processing options
+		break;
+	    }
+	}
+    }
+    set args [lrange $args $i end]
+
     set use($class)      $args
     set use($class,file) $filename
+    set use($class,namespace) $ns;
     lappend use(classes) $class
 
-    if {[set x [lsearch -exact $args "-classonly"]] > -1} {
-	set args [lreplace $args $x $x]
-    } else {
-	interp alias {} ::${class} {} ${class}::create
-	proc ::${class}::use {} {}
-
+    if {!$classonly} {
+	interp alias {} ${ns} {} ${ns}::create
+	proc ${ns}::use {} {}
 	bind $class <Destroy> [list Widget::destroy %W]
     }
 
-    foreach class $args { ${class}::use }
+    foreach dep $args {
+	if {![info exists use(${dep},namespace)]} {
+	    # Lazy-loaded modules have are not yet loaded (actually that seems to be
+	    # the whole point of this 'use' mechanism.) so they have not configured
+	    # a namespace. Use namespace=class convention. Note that the class MUST
+	    # not be prefixed by ::.
+	    ${dep}::use;
+	} else {
+	    $use(${dep},namespace)::use;
+	}
+    }
 }
 
 
 proc Widget::create { class path {rename 1} } {
     if {$rename} { rename $path ::$path:cmd }
+
+    variable ::BWidget::use;
+    set ns [expr {[info exists use(${class},namespace)]
+		  ? $use(${class},namespace)
+		  : $class}];
+
     proc ::$path { cmd args } \
-    	[subst {return \[eval \[linsert \$args 0 ${class}::\$cmd [list $path]\]\]}]
+	[subst {return \[eval \[linsert \$args 0 ${ns}::\$cmd [list $path]\]\]}]
     return $path
 }
~~~

MfG

Adrián Medraño Calvo
User Comments: oehhar added on 2015-03-18 13:18:52:

Thank you for the patch. Included in checkin [3b6bda131c].

Ticket closed.

Thanks, Harald


anonymous (claiming to be Adrián Medraño Calvo) added on 2015-03-12 08:35:57:
Fix variable cleanup and make sure the configured namespaces exist.

~~~
diff --git a/src/bwidget-1.9.8/widget.tcl b/src/bwidget-1.9.8/widget.tcl
index 7579365..c91bea7 100644
--- a/src/bwidget-1.9.8/widget.tcl
+++ b/src/bwidget-1.9.8/widget.tcl
@@ -447,6 +447,11 @@ proc Widget::define { class filename args } {
     set use($class,namespace) $ns;
     lappend use(classes) $class
 
+    # Make sure the class description namespace exists.
+    namespace eval $class {}
+    # Make sure the megawidget namespace exists.
+    namespace eval $ns {};
+
     if {!$classonly} {
 	interp alias {} ${ns} {} ${ns}::create
 	proc ${ns}::use {} {}
@@ -806,9 +811,15 @@ proc Widget::destroy { path } {
 
     if {![string equal [info commands $path] ""]} { rename $path "" }
 
-    ## Unset any variables used in this widget.
-    set ns ::BWidget::use(${class},namespace);
-    foreach var [info vars ${ns}::${path}:*] { unset $var }
+    # Unset any variables used in this widget.
+    # Guard, as some internal classes (Bitmap, LabelEntry, ListBox::Item,
+    # NoteBook::Page, PanedWindow::Pane, ScrollableFrame, ScrollableFrame,
+    # ScrollableFrame, Tree::Node, Wizard::Branch, Wizard::Step, Wizard::Widget)
+    # are declared but not defined.
+    if {[info exists ::BWidget::use(${class},namespace)]} {
+	set ns $::BWidget::use(${class},namespace);
+	foreach var [info vars ${ns}::${path}:*] { unset $var }
+    }
 
     unset _class($path)
 }
~~~

anonymous (claiming to be Adrián Medraño Calvo) added on 2014-12-06 11:22:57:
The previous patch failed to use the specified namespace for instance variables.

~~~
diff --git a/src/bwidget-1.9.8/widget.tcl b/src/bwidget-1.9.8/widget.tcl
index 7edb114..7579365 100644
--- a/src/bwidget-1.9.8/widget.tcl
+++ b/src/bwidget-1.9.8/widget.tcl
@@ -807,7 +807,8 @@ proc Widget::destroy { path } {
     if {![string equal [info commands $path] ""]} { rename $path "" }
 
     ## Unset any variables used in this widget.
-    foreach var [info vars ::${class}::$path:*] { unset $var }
+    set ns ::BWidget::use(${class},namespace);
+    foreach var [info vars ${ns}::${path}:*] { unset $var }
 
     unset _class($path)
 }
@@ -1572,7 +1573,8 @@ proc Widget::which {path args} {
 	    return ::Widget::${class}::${path}:opt(${name});
 	}
 	-variable {
-	    return ${class}::${path}:${name};
+	    set ns $::BWidget::use(${class},namespace);
+	    return ${ns}::${path}:${name};
 	}
     }
 }
@@ -1610,8 +1612,9 @@ proc Widget::varForOption {path option} {
 proc Widget::getVariable { path varName {newVarName ""} } {
     variable _class
     set class $_class($path)
+    set ns $::BWidget::use(${class},namespace);
     if {![string length $newVarName]} { set newVarName $varName }
-    uplevel 1 [list ::upvar \#0 ${class}::$path:$varName $newVarName]
+    uplevel 1 [list ::upvar \#0 ${ns}::${path}:${varName} $newVarName]
 }
 
 # Widget::options --
~~~

anonymous (claiming to be Adrián Medraño Calvo) added on 2014-12-05 16:02:56:
There are missing bits in the above patch, will get back to it soon.