diff options
Diffstat (limited to 'generic')
| -rw-r--r-- | generic/tclOOScript.h | 44 | ||||
| -rw-r--r-- | generic/tclOOScript.tcl | 183 |
2 files changed, 206 insertions, 21 deletions
diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index ffdedb8..1f345fb 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -21,16 +21,17 @@ */ static const char *tclOOSetupScript = +/* !BEGIN!: Do not edit below this line. */ "::proc ::oo::Helpers::callback {method args} {\n" " list [uplevel 1 {namespace which my}] $method {*}$args\n" "}\n" - +"\n" "::proc ::oo::Helpers::mymethod {method args} {\n" " list [uplevel 1 {namespace which my}] $method {*}$args\n" "}\n" - +"\n" "::proc ::oo::Helpers::classvariable {name args} {\n" -" # Get a reference to the class's namespace\n" +" # Get a reference to the class\'s namespace\n" " set ns [info object namespace [uplevel 1 {self class}]]\n" " # Double up the list of variable names\n" " foreach v [list $name {*}$args] {\n" @@ -42,10 +43,10 @@ static const char *tclOOSetupScript = " }\n" " lappend vs $v $v\n" " }\n" -" # Lastly, link the caller's local variables to the class's variables\n" +" # Lastly, link the caller\'s local variables to the class\'s variables\n" " tailcall namespace upvar $ns {*}$vs\n" "}\n" - +"\n" "::proc ::oo::Helpers::link {args} {\n" " set ns [uplevel 1 {namespace current}]\n" " foreach link $args {\n" @@ -68,11 +69,11 @@ static const char *tclOOSetupScript = " rename $cmd {}\n" " }\n" "}\n" - +"\n" "::proc ::oo::DelegateName {class} {\n" " string cat [info object namespace $class] {:: oo ::delegate}\n" "}\n" - +"\n" "proc ::oo::MixinClassDelegates {class} {\n" " if {![info object isa class $class]} {\n" " return\n" @@ -81,7 +82,7 @@ static const char *tclOOSetupScript = " if {![info object isa class $delegate]} {\n" " return\n" " }\n" -" foreach c [info class superclass $class] {" +" foreach c [info class superclass $class] {\n" " set d [::oo::DelegateName $c]\n" " if {![info object isa class $d]} {\n" " continue\n" @@ -90,14 +91,14 @@ static const char *tclOOSetupScript = " }\n" " ::oo::objdefine $class mixin -append $delegate\n" "}\n" - -"::namespace eval ::oo::define {" +"\n" +"::namespace eval ::oo::define {\n" " ::proc classmethod {name {args {}} {body {}}} {\n" " # Create the method on the class if the caller gave arguments and body\n" " ::set argc [::llength [::info level 0]]\n" " ::if {$argc == 3} {\n" -" ::return -code error [::string cat {wrong # args: should be \"}" -" [::lindex [::info level 0] 0] { name ?args body?\"}]\n" +" ::return -code error [::string cat {wrong # args: should be \"} \\\n" +" [::lindex [::info level 0] 0] { name \?args body\?\"}]\n" " }\n" " ::set cls [::uplevel 1 self]\n" " ::if {$argc == 4} {\n" @@ -106,12 +107,12 @@ static const char *tclOOSetupScript = " # Make the connection by forwarding\n" " ::tailcall forward $name myclass $name\n" " }\n" - +"\n" " ::proc initialise {body} {\n" " ::set clsns [::info object namespace [::uplevel 1 self]]\n" " ::tailcall apply [::list {} $body $clsns]\n" " }\n" - +"\n" " # Make the initialise command appear with US spelling too\n" " ::namespace export initialise\n" " ::namespace eval tmp {::namespace import ::oo::define::initialise}\n" @@ -119,11 +120,11 @@ static const char *tclOOSetupScript = " ::namespace delete tmp\n" " ::namespace export -clear\n" "}\n" - +"\n" "::oo::define ::oo::Slot {\n" " method Get {} {return -code error unimplemented}\n" " method Set list {return -code error unimplemented}\n" - +"\n" " method -set args {tailcall my Set $args}\n" " method -append args {\n" " set current [uplevel 1 [list [namespace which my] Get]]\n" @@ -131,7 +132,7 @@ static const char *tclOOSetupScript = " }\n" " method -clear {} {tailcall my Set {}}\n" " forward --default-operation my -append\n" - +"\n" " method unknown {args} {\n" " set def --default-operation\n" " if {[llength $args] == 0} {\n" @@ -141,7 +142,7 @@ static const char *tclOOSetupScript = " }\n" " next {*}$args\n" " }\n" - +"\n" " export -set -append -clear\n" " unexport unknown destroy\n" "}\n" @@ -149,7 +150,7 @@ static const char *tclOOSetupScript = "::oo::objdefine ::oo::define::superclass forward --default-operation my -set\n" "::oo::objdefine ::oo::define::mixin forward --default-operation my -set\n" "::oo::objdefine ::oo::objdefine::mixin forward --default-operation my -set\n" - +"\n" "::oo::define ::oo::class method <cloned> {originObject} {\n" " next $originObject\n" " # Rebuild the class inheritance delegation class\n" @@ -162,7 +163,7 @@ static const char *tclOOSetupScript = " }]\n" " }\n" "}\n" - +"\n" "::oo::class create ::oo::singleton {\n" " superclass ::oo::class\n" " variable object\n" @@ -180,11 +181,12 @@ static const char *tclOOSetupScript = " return $object\n" " }\n" "}\n" - +"\n" "::oo::class create ::oo::abstract {\n" " superclass ::oo::class\n" " unexport create createWithNamespace new\n" "}\n" +/* !END!: Do not edit above this line. */ ; /* diff --git a/generic/tclOOScript.tcl b/generic/tclOOScript.tcl new file mode 100644 index 0000000..e0af23f --- /dev/null +++ b/generic/tclOOScript.tcl @@ -0,0 +1,183 @@ +# tclOOScript.h -- +# +# This file contains support scripts for TclOO. They are defined here so +# that the code can be definitely run even in safe interpreters; TclOO's +# core setup is safe. +# +# Copyright (c) 2012-2018 Donal K. Fellows +# Copyright (c) 2013 Andreas Kupries +# Copyright (c) 2017 Gerald Lester +# +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. + +::proc ::oo::Helpers::callback {method args} { + list [uplevel 1 {namespace which my}] $method {*}$args +} + +::proc ::oo::Helpers::mymethod {method args} { + list [uplevel 1 {namespace which my}] $method {*}$args +} + +::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 + foreach v [list $name {*}$args] { + if {[string match *(*) $v]} { + return -code error [string cat {bad variable name "} $v {": can't create a scalar variable that looks like an array element}] + } + if {[string match *::* $v]} { + return -code error [string cat {bad variable name "} $v {": can't create a local variable with a namespace separator in it}] + } + lappend vs $v $v + } + # Lastly, link the caller's local variables to the class's variables + tailcall namespace upvar $ns {*}$vs +} + +::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 + } + if {![string match ::* $src]} { + set src [string cat $ns :: $src] + } + interp alias {} $src {} ${ns}::my $dst + trace add command ${ns}::my delete [list ::oo::Helpers::Unlink $src] + } + return +} +::proc ::oo::Helpers::Unlink {cmd args} { + if {[namespace which $cmd] ne {}} { + rename $cmd {} + } +} + +::proc ::oo::DelegateName {class} { + string cat [info object namespace $class] {:: oo ::delegate} +} + +proc ::oo::MixinClassDelegates {class} { + if {![info object isa class $class]} { + return + } + set delegate [::oo::DelegateName $class] + if {![info object isa class $delegate]} { + return + } + foreach c [info class superclass $class] { + set d [::oo::DelegateName $c] + if {![info object isa class $d]} { + continue + } + ::oo::define $delegate superclass -append $d + } + ::oo::objdefine $class mixin -append $delegate +} + +::namespace eval ::oo::define { + ::proc 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 [::string cat {wrong # args: should be "} \ + [::lindex [::info level 0] 0] { name ?args body?"}] + } + ::set cls [::uplevel 1 self] + ::if {$argc == 4} { + ::oo::define [::oo::DelegateName $cls] method $name $args $body + } + # Make the connection by forwarding + ::tailcall forward $name myclass $name + } + + ::proc initialise {body} { + ::set clsns [::info object namespace [::uplevel 1 self]] + ::tailcall apply [::list {} $body $clsns] + } + + # Make the initialise command appear with US spelling too + ::namespace export initialise + ::namespace eval tmp {::namespace import ::oo::define::initialise} + ::rename ::oo::define::tmp::initialise initialize + ::namespace delete tmp + ::namespace export -clear +} + +::oo::define ::oo::Slot { + method Get {} {return -code error unimplemented} + method Set list {return -code error unimplemented} + + method -set args {tailcall my Set $args} + method -append args { + set current [uplevel 1 [list [namespace which my] Get]] + tailcall my Set [list {*}$current {*}$args] + } + method -clear {} {tailcall my Set {}} + forward --default-operation my -append + + method unknown {args} { + set def --default-operation + if {[llength $args] == 0} { + tailcall my $def + } elseif {![string match -* [lindex $args 0]]} { + tailcall my $def {*}$args + } + next {*}$args + } + + export -set -append -clear + unexport unknown destroy +} + +::oo::objdefine ::oo::define::superclass forward --default-operation my -set +::oo::objdefine ::oo::define::mixin forward --default-operation my -set +::oo::objdefine ::oo::objdefine::mixin forward --default-operation my -set + +::oo::define ::oo::class method <cloned> {originObject} { + next $originObject + # Rebuild the class inheritance delegation class + set originDelegate [::oo::DelegateName $originObject] + set targetDelegate [::oo::DelegateName [self]] + if {[info object isa class $originDelegate] && ![info object isa class $targetDelegate]} { + ::oo::copy $originDelegate $targetDelegate + ::oo::objdefine [self] mixin -set {*}[lmap c [info object mixin [self]] { + if {$c eq $originDelegate} {set targetDelegate} {set c} + }] + } +} + +::oo::class create ::oo::singleton { + superclass ::oo::class + variable object + unexport create createWithNamespace + method new args { + if {![info exists object] || ![info object isa object $object]} { + set object [next {*}$args] + ::oo::objdefine $object method destroy {} { + return -code error {may not destroy a singleton object} + } + ::oo::objdefine $object method <cloned> {originObject} { + return -code error {may not clone a singleton object} + } + } + return $object + } +} + +::oo::class create ::oo::abstract { + superclass ::oo::class + unexport create createWithNamespace new +} + +# Local Variables: +# mode: tcl +# c-basic-offset: 4 +# fill-column: 78 +# End: |