Merge commit '7c621da28f07e449ad90c387344f07a453927569' as 'tcllib'

5 files changed, 473 insertions, 0 deletions

diff --git a/tcllib/modules/ooutil/ChangeLog b/tcllib/modules/ooutil/ChangeLog
new file mode 100644
index 0000000..c6c576d
--- /dev/null
+++ b/tcllib/modules/ooutil/ChangeLog
@@ -0,0 +1,28 @@
+2013-02-27  Andreas Kupries  <andreask@activestate.com>
+
+	* ooutil.tcl (::oo::Helpers::link): New helper command.
+	* ooutil.man: Makes instance methods available without
+	* pkgIndex.tcl: 'my'. Bumped version to 1.2.
+
+2013-02-01  Andreas Kupries  <andreas_kupries@users.sourceforge.net>
+
+	*
+	* Released and tagged Tcllib 1.15 ========================
+	* 
+
+2013-01-30  Andreas Kupries  <andreask@activestate.com>
+
+	* ooutil.man: Added more utilities to support class variables,
+	* ooutil.tcl: class methods, and singleton classes. Packed version
+	* pkgIndex.tcl: bumped to 1.1 for all these new features.
+
+2011-12-13  Andreas Kupries  <andreas_kupries@users.sourceforge.net>
+
+	*
+	* Released and tagged Tcllib 1.14 ========================
+	* 
+
+2011-05-31  Andreas Kupries  <andreask@activestate.com>
+
+	* New module and package: oo::util. Right now only easy
+	  referencing of instance methods for callbacks.
diff --git a/tcllib/modules/ooutil/ooutil.man b/tcllib/modules/ooutil/ooutil.man
new file mode 100644
index 0000000..72415ff
--- /dev/null
+++ b/tcllib/modules/ooutil/ooutil.man
@@ -0,0 +1,165 @@
+[comment {-*- tcl -*- doctools manpage}]
+[vset OOUTIL_VERSION 1.2.2]
+[manpage_begin oo::util n [vset OOUTIL_VERSION]]
+[see_also snit(n)]
+[keywords callback]
+[keywords {class methods}]
+[keywords {class variables}]
+[keywords {command prefix}]
+[keywords currying]
+[keywords {method reference}]
+[keywords {my method}]
+[keywords singleton]
+[keywords TclOO]
+[copyright {2011-2015 Andreas Kupries, BSD licensed}]
+[moddesc {Utility commands for TclOO}]
+[titledesc {Utility commands for TclOO}]
+[category  Utility]
+[require Tcl 8.5]
+[require TclOO]
+[require oo::util [opt [vset OOUTIL_VERSION]]]
+[description]
+[para]
+
+This package provides a convenience command for the easy specification
+of instance methods as callback commands, like timers, file events, Tk
+bindings, etc.
+
+[section {COMMANDS}]
+
+[list_begin definitions]
+[comment {- - -- --- ----- -------- ------------- ---------------------}]
+[call [cmd mymethod] [arg method] [opt [arg arg]...]]
+
+This command is available within instance methods. It takes a method
+name and, possibly, arguments for the method and returns a command
+prefix which, when executed, will invoke the named method of the
+object we are in, with the provided arguments, and any others supplied
+at the time of actual invokation.
+
+[para] Note: The command is equivalent to and named after the command
+provided by the OO package [package snit] for the same purpose.
+
+[comment {- - -- --- ----- -------- ------------- ---------------------}]
+[call [cmd classmethod] [arg name] [arg arguments] [arg body]]
+
+This command is available within class definitions. It takes a method
+name and, possibly, arguments for the method and creates a method on the
+class, available to a user of the class and of derived classes.
+
+[para] Note: The command is equivalent to the command [cmd typemethod]
+provided by the OO package [package snit] for the same purpose.
+
+[para] Example
+[example {
+oo::class create ActiveRecord {
+    classmethod find args { puts "[self] called with arguments: $args" }
+}
+oo::class create Table {
+    superclass ActiveRecord
+}
+puts [Table find foo bar]
+# ======
+# which will write
+# ======
+# ::Table called with arguments: foo bar
+}]
+
+[comment {- - -- --- ----- -------- ------------- ---------------------}]
+[call [cmd classvariable] [opt [arg arg]...]]
+
+This command is available within instance methods. It takes a series
+of variable names and makes them available in the method's scope. The
+originating scope for the variables is the class (instance) the object
+instance belongs to. In other words, the referenced variables are shared
+between all instances of their class.
+
+[para] Note: The command is roughly equivalent to the command
+[cmd typevariable] provided by the OO package [package snit] for the
+same purpose. The difference is that it cannot be used in the class
+definition itself.
+
+[para] Example:
+[example {
+% oo::class create Foo {
+    method bar {z} {
+        classvariable x y
+        return [incr x $z],[incr y]
+    }
+}
+::Foo
+% Foo create a
+::a
+% Foo create b
+::b
+% a bar 2
+2,1
+% a bar 3
+5,2
+% b bar 7
+12,3
+% b bar -1
+11,4
+% a bar 0
+11,5
+}]
+
+[comment {- - -- --- ----- -------- ------------- ---------------------}]
+[call [cmd link] [arg method]...]
+[call [cmd link] "{[arg alias] [arg method]}..."]
+
+This command is available within instance methods. It takes a list of
+method names and/or pairs of alias- and method-name and makes the
+named methods available to all instance methods without requiring the
+[cmd my] command.
+
+[para] The alias name under which the method becomes available defaults
+to the method name, except where explicitly specified through an
+alias/method pair.
+
+[para] Examples:
+[example {
+    link foo
+    # The method foo is now directly accessible as foo instead of my foo.
+
+    link {bar foo}
+    # The method foo is now directly accessible as bar.
+
+    link a b c
+    # The methods a, b, and c all become directly acessible under their
+    # own names.
+}]
+
+The main use of this command is expected to be in instance constructors,
+for convenience, or to set up some methods for use in a mini DSL.
+
+[comment {- - -- --- ----- -------- ------------- ---------------------}]
+[call [cmd ooutil::singleton] [opt [arg arg]...]]
+
+This command is a meta-class, i.e. a variant of the builtin
+[cmd oo::class] which ensures that it creates only a single
+instance of the classes defined with it.
+
+[para] Syntax and results are like for [cmd oo::class].
+
+[para] Example:
+[example {
+% oo::class create example {
+   self mixin singleton
+   method foo {} {self}
+}
+::example
+% [example new] foo
+::oo::Obj22
+% [example new] foo
+::oo::Obj22
+}]
+
+[list_end]
+
+[section AUTHORS]
+Donal Fellows, Andreas Kupries
+
+[vset CATEGORY oo::util]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/ooutil/ooutil.tcl b/tcllib/modules/ooutil/ooutil.tcl
new file mode 100644
index 0000000..3e7d4e3
--- /dev/null
+++ b/tcllib/modules/ooutil/ooutil.tcl
@@ -0,0 +1,189 @@
+# # ## ### ##### ######## ############# ####################
+## -*- tcl -*-
+## (C) 2011-2015 Andreas Kupries, BSD licensed.
+
+# # ## ### ##### ######## ############# ####################
+## Requisites
+
+package require Tcl 8.5
+package require TclOO
+
+# # ## ### ##### ######## ############# #####################
+## Public API implementation
+
+# # ## ### ##### ######## ############# ####################
+## Easy callback support.
+## http://wiki.tcl.tk/21595. v20, Donal Fellows
+
+proc ::oo::Helpers::mymethod {method args} {
+    list [uplevel 1 {namespace which my}] $method {*}$args
+}
+
+# # ## ### ##### ######## ############# ####################
+## Class variable support. Use within instance methods.
+## No use in class definitions.
+## http://wiki.tcl.tk/21595. v63, Donal Fellows, tweaked name, comments
+
+proc ::oo::Helpers::classvariable {name args} {
+    # Get a reference to the class's namespace
+    set ns [info object namespace [uplevel 1 {self class}]]
+
+    # Double up the list of variable names
+    set vs [list $name $name]
+    foreach v $args {lappend vs $v $v}
+
+    # Lastly, link the caller's local variables to the class's
+    # variables
+    uplevel 1 [list namespace upvar $ns {*}$vs]
+}
+
+#==================================
+# Demonstration
+#==================================
+# % oo::class create Foo {
+#     method bar {z} {
+#         classvar x y
+#         return [incr x $z],[incr y]
+#     }
+# }
+# ::Foo
+# % Foo create a
+# ::a
+# % Foo create b
+# ::b
+# % a bar 2
+# 2,1
+# % a bar 3
+# 5,2
+# % b bar 7
+# 12,3
+# % b bar -1
+# 11,4
+# % a bar 0
+# 11,5
+
+# # ## ### ##### ######## ############# ####################
+## Class method support, with access in derived classes
+## http://wiki.tcl.tk/21595. v63, Donal Fellows
+
+proc ::oo::define::classmethod {name {args ""} {body ""}} {
+    # Create the method on the class if the caller gave arguments and body
+    set argc [llength [info level 0]]
+    if {$argc == 3} {
+        return -code error "wrong # args: should be \"[lindex [info level 0] 0] name ?args body?\""
+    }
+
+    # Get the name of the current class or class delegate 
+    set cls [namespace which [lindex [info level -1] 1]]
+    set d $cls.Delegate
+    if {[info object isa object $d] && [info object isa class $d]} {
+        set cls $d
+    }
+
+    if {$argc == 4} {
+        oo::define $cls method $name $args $body
+    }
+
+    # Make the connection by forwarding
+    uplevel 1 [list forward $name [info object namespace $cls]::my $name]
+}
+
+# Build this *almost* like a class method, but with extra care to avoid nuking
+# the existing method.
+oo::class create oo::class.Delegate {
+    method create {name args} {
+        if {![string match ::* $name]} {
+            set ns [uplevel 1 {namespace current}]
+            if {$ns eq "::"} {set ns ""}
+            set name ${ns}::${name}
+        }
+        if {[string match *.Delegate $name]} {
+            return [next $name {*}$args]
+        }
+        set delegate [oo::class create $name.Delegate]
+        set cls [next $name {*}$args]
+        set superdelegates [list $delegate]
+        foreach c [info class superclass $cls] {
+            set d $c.Delegate
+            if {[info object isa object $d] && [info object isa class $d]} {
+                lappend superdelegates $d
+            }
+        }
+        oo::objdefine $cls mixin {*}$superdelegates
+        return $cls
+    }
+}
+
+oo::define oo::class self mixin oo::class.Delegate
+
+# Demonstrating…
+# ======
+# oo::class create ActiveRecord {
+#     classmethod find args { puts "[self] called with arguments: $args" }
+# }
+# oo::class create Table {
+#     superclass ActiveRecord
+# }
+# Table find foo bar
+# ======
+# which will write this out (I tested it):
+# ======none
+# ::Table called with arguments: foo bar
+# ======
+
+# # ## ### ##### ######## ############# ####################
+## Singleton Metaclass
+## http://wiki.tcl.tk/21595. v63, Donal Fellows
+
+oo::class create ooutil::singleton {
+   superclass oo::class
+   variable object
+   method create {name args} {
+      if {![info exists object]} {
+         set object [next $name {*}$args]
+      }
+      return $object
+   }
+   method new args {
+      if {![info exists object]} {
+         set object [next {*}$args]
+      }
+      return $object
+   }
+}
+
+# ======
+# Demonstration
+# ======
+# % oo::class create example {
+#    self mixin singleton
+#    method foo {} {self}
+# }
+# ::example
+# % [example new] foo
+# ::oo::Obj22
+# % [example new] foo
+# ::oo::Obj22
+
+# # ## ### ##### ######## ############# ####################
+## Linking instance methods into instance namespace for access without 'my'
+## http://wiki.tcl.tk/27999, AK
+
+proc ::oo::Helpers::link {args} {
+    set ns [uplevel 1 {namespace current}]
+    foreach link $args {
+	if {[llength $link] == 2} {
+	    lassign $link src dst
+	} else {
+	    lassign $link src
+	    set dst $src
+	}
+	interp alias {} ${ns}::$src {} ${ns}::my $dst
+    }
+    return
+}
+
+# # ## ### ##### ######## ############# ####################
+## Ready
+
+package provide oo::util 1.2.2
diff --git a/tcllib/modules/ooutil/ooutil.test b/tcllib/modules/ooutil/ooutil.test
new file mode 100644
index 0000000..9ef01c4
--- /dev/null
+++ b/tcllib/modules/ooutil/ooutil.test
@@ -0,0 +1,84 @@
+# ooutil.test - Copyright (c) 2014-2015 Andreas Kupries
+
+# -------------------------------------------------------------------------
+
+source [file join \
+	[file dirname [file dirname [file join [pwd] [info script]]]] \
+	devtools testutilities.tcl]
+
+testsNeedTcl     8.5
+testsNeedTcltest 2
+
+testsNeed TclOO 1
+
+testing {
+    useLocal ooutil.tcl oo::util
+}
+
+# -------------------------------------------------------------------------
+
+test ooutil-ticket-b3577ed586 {test scoping of delegation in oo::class.Delegate } -setup {
+    oo::class create animal {}
+    namespace eval ::ooutiltest {
+	oo::class create pet { superclass animal }
+    }
+} -body {
+    namespace eval ::ooutiltest {
+	oo::class create dog { superclass pet }
+    }
+} -cleanup {
+    namespace delete ooutiltest
+    rename animal {}
+} -result {::ooutiltest::dog}
+
+# -------------------------------------------------------------------------
+
+test ooutil-ticket-fe7a0e0a3a {classmethod must not interfere with constructor signatures} -setup {
+    oo::class create TestClass {
+        superclass oo::class
+        self method create {name ignore body} {
+            next $name $body
+        }
+    }
+} -body {
+    TestClass create okay {} {}
+} -cleanup {
+    rename TestClass {}
+} -result {::okay}
+
+# -------------------------------------------------------------------------
+
+test ooutil-classmethod-1 {test ooutil classmethod} -setup {
+    oo::class create ActiveRecord {
+        classmethod find args { puts "[self] called with arguments: $args" }
+    }
+    oo::class create Table {
+        superclass ActiveRecord
+    }
+} -body {
+    Table find foo bar
+} -cleanup {
+    rename ActiveRecord {}
+} -output "::Table called with arguments: foo bar\n"
+
+test ooutil-classmethod-2 {test ooutil classmethod in namespace} -setup {
+    namespace eval testns {
+	oo::class create ActiveRecord {
+	    classmethod find args { puts "[self] called with arguments: $args" }
+	}
+	oo::class create Table {
+	    superclass ActiveRecord
+	}
+    }
+} -body {
+    testns::Table find foo bar
+} -cleanup {
+    namespace delete testns
+} -output "::testns::Table called with arguments: foo bar\n"
+
+testsuiteCleanup
+
+# Local variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
diff --git a/tcllib/modules/ooutil/pkgIndex.tcl b/tcllib/modules/ooutil/pkgIndex.tcl
new file mode 100644
index 0000000..d9756be
--- /dev/null
+++ b/tcllib/modules/ooutil/pkgIndex.tcl
@@ -0,0 +1,7 @@
+#checker -scope global exclude warnUndefinedVar
+# var in question is 'dir'.
+if {![package vsatisfies [package provide Tcl] 8.5]} {
+    # PRAGMA: returnok
+    return
+}
+package ifneeded oo::util 1.2.2 [list source [file join $dir ooutil.tcl]]
\ No newline at end of file