diff options
author | William Joye <wjoye@cfa.harvard.edu> | 2016-10-27 19:39:39 (GMT) |
---|---|---|
committer | William Joye <wjoye@cfa.harvard.edu> | 2016-10-27 19:39:39 (GMT) |
commit | ea28451286d3ea4a772fa174483f9a7a66bb1ab3 (patch) | |
tree | 6ee9d8a7848333a7ceeee3b13d492e40225f8b86 /tcllib/modules/ooutil | |
parent | b5ca09bae0d6a1edce939eea03594dd56383f2c8 (diff) | |
parent | 7c621da28f07e449ad90c387344f07a453927569 (diff) | |
download | blt-ea28451286d3ea4a772fa174483f9a7a66bb1ab3.zip blt-ea28451286d3ea4a772fa174483f9a7a66bb1ab3.tar.gz blt-ea28451286d3ea4a772fa174483f9a7a66bb1ab3.tar.bz2 |
Merge commit '7c621da28f07e449ad90c387344f07a453927569' as 'tcllib'
Diffstat (limited to 'tcllib/modules/ooutil')
-rw-r--r-- | tcllib/modules/ooutil/ChangeLog | 28 | ||||
-rw-r--r-- | tcllib/modules/ooutil/ooutil.man | 165 | ||||
-rw-r--r-- | tcllib/modules/ooutil/ooutil.tcl | 189 | ||||
-rw-r--r-- | tcllib/modules/ooutil/ooutil.test | 84 | ||||
-rw-r--r-- | tcllib/modules/ooutil/pkgIndex.tcl | 7 |
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 |