obj
Minimalistisches Objekt-System für Tcl. Keine Klassen-Vererbung, stattdessen Delegation von Methoden an Komponenten. Tutorial bei wiki.tcl.tk. Doku hier.
#
# obj -- minimalistic object orientation for Tcl
# usage: package require obj
#
package require Tcl 8.5
package provide obj 0.2
#
# namespace obj
# variable counter to calculate unique object name
# sub-namespace inst for object instances
# sub-namespace class for class namespaces
#
namespace eval obj {
variable counter 0
namespace eval inst {}
namespace eval class {}
namespace export *
}
namespace eval obj::find {
namespace ensemble create
namespace export *
}
proc obj::find::object class {
append data\
[namespace qualifiers [namespace current]]\
::class:: $class ::data
array names $data ::obj::inst::*
}
proc obj::find::class {{pat *}} {
set result {}
foreach ns [namespace children\
[namespace qualifiers\
[namespace current]]::class $pat] {
lappend result [namespace tail $ns]
}
set result
}
#
# obj::info $object $what
# intended to use as method:
# $object info $what
# $object info ? tells what is provided.
#
proc obj::info {self {how ""} args} {
if {[exists $self]} then {
if {$how eq ""} then {
set how ?
}
switch -exact -- $how {
class {
namespace tail [namespace qualifiers [namespace origin $self]]
}
exists {
exists {*}$args
}
self - object {
set self
}
namespace {
namespace qualifiers [namespace origin $self]
}
instances {
array names\
[namespace qualifiers\
[namespace origin $self]]::data ::obj::inst::*
}
methods {
set pat [lindex $args 0]
if {$pat eq ""} then {
set pat {[a-zA-Z0-9]*}
}
set result {}
foreach m [set [info $self namespace]::data(methods)] {
if {[string match $pat $m]} then {
lappend result $m
}
}
set result
}
args {
set method {*}$args
set proc [namespace qualifiers [namespace origin $self]]::$method
set argl {}
foreach arg [lrange [::info args $proc] 1 end] {
if {[::info default $proc $arg defVar]} then {
lappend argl [list $arg $defVar]
} else {
lappend argl $arg
}
}
set argl
}
body {
set method {*}$args
set proc [namespace qualifiers [namespace origin $self]]::$method
::info body $proc
}
comment - # {
set result {}
foreach line [::split [$self info body {*}$args] \n] {
set line [string trim $line]
if {$line eq {}} then continue
if {[string index $line 0] ne "#"} then break
lappend result [string trim $line "# "]
}
set result [string trim [join $result \n]]
set line [lindex [split $result \n] 0]
if {[string is list -strict $line]} then {
lassign $line a b c d e
if {$a eq "delegate" &&
$b eq "to" &&
$c in [$self component] &&
$d in {as ""} &&
(($e eq "" && $d eq "") ||
$e in [$self component $c info methods])} then {
if {$e eq ""} then {
set e [lindex [::info level 0] end]
}
append result " -->\n" [$self component $c info comment $e]
}
}
set result
}
source - method {
list [namespace origin method] [info $self class] {*}$args\
[info $self args {*}$args] [info $self body {*}$args]
}
constructor {
list [namespace current]::constructor [info $self class]\
[info $self args __constructor] [info $self body __constructor]
}
destructor {
list [namespace current]::destructor [info $self class]\
[info $self body __destructor]
}
classes {
set p [namespace origin $self]
set ns [namespace qualifiers [namespace qualifiers $p]]
set result {}
foreach c [namespace children $ns] {
lappend result [namespace tail $c]
}
set result
}
configuremethod - validatemethod {
set option {*}$args
list [namespace current]::$how [info $self class] $option\
[info $self args [string range __$how 0 end-6]$option]\
[info $self body [string range __$how 0 end-6]$option]
}
cgetmethod {
set option {*}$args
list [namespace current]::cgetmethod [info $self class] $option\
[info $self body __cget$option]
}
options {
set p [namespace qualifiers [namespace origin $self]]
set arrayName ${p}::data(options)
dict keys [set $arrayName]
}
common {
set ns [namespace qualifiers [namespace origin $self]]
set ${ns}::data(common)
}
data {
set ns [namespace qualifiers [namespace origin $self]]
set ${ns}::data($self)
}
private {
dict keys [dict get [info $self data] private]
}
help - \? {
list added/modified subcommands:\
self class namespace instances methods body args\
source method comment constructor destructor\
options classes cgetmethod validatemethod\
data private common help ?
}
default {
uplevel #0 [list ::info $how {*}$args]
}
}
} else {
# obiously basic proc meant
uplevel ::info $self {*}[concat $how $args]
}
}
proc obj::_generate-object_ args {
set class [namespace tail [lindex [::info level 0] 0]]
new $class {*}$args
}
#
# obj::class $classname
# initializes $classname with basic methods
# as well as keywords my and our for methods inside only.
#
proc obj::class {class args} {
namespace eval class::$class {
# core procedure
namespace export _root-object_
proc _root-object_ {{method ::return} args} {
$method [::lindex [::info level 0] 0] {*}$args
}
# data
array set data {}
set data(options) {}
set data(common) {}
set data(methods) {cget configure info destroy private common isa}
}
# import pre-defined procedures and methods
namespace eval class::$class [::subst {
namespace import\
[::namespace current]::new\
[::namespace current]::info\
[::namespace current]::local\
[::namespace current]::exists
}]
# define core methods
method $class __constructor args # false
method $class __destructor args # false
#
method $class isa class\
[subst {expr {\$class eq "$class" ? true : false}}] false
#
method $class cget key {
::variable data
if {$key ni $data(options)} then {
::return -code error "no valid option: $key"
}
$self __cget$key
::dict get $data($self) option $key
} false
method $class configure {args} {
::variable data
::if {![::llength $args]} then {
::set result {}
::foreach {key val} [::dict get $data($self) option] {
::lappend result\
[::list $key [::dict get $data(options) $key] [$self cget $key]]
}
::set result
} else {
if {[::llength $args] == 1} then {
if {$args ni $data(options)} then {
::return -code error "no valid option: $args"
}
::list {*}$args\
[::dict get $data(options) {*}$args]\
[$self cget {*}$args]
} else {
::foreach {key val} $args {
if {$key ni $data(options)} then {
::return -code error "no valid option: $key"
}
$self __validate$key $val
::dict set data($self) option $key $val
$self __configure$key $val
}
}
}
} false
method $class component {{component {}} args} {
::variable data
if {$component eq ""} then {
set result {}
foreach {key val} [::dict get $data($self) private] {
if {[::info command $val] ne "" &&
[::namespace qualifiers $val] eq "::obj::inst"} then {
lappend result $key
}
}
set result
} else {
[::dict get $data($self) private $component] {*}$args
}
} false
method $class private args {
::variable data
::if {![::llength $args]} then {
::dict keys [::dict get $data($self) private]
} elseif {[::llength $args] == 1} then {
::dict get $data($self) private {*}$args
} else {
::dict set data($self) private {*}$args
::lindex $args end
}
} false
method $class common args {
::variable data
::if {![::llength $args]} then {
::dict keys [::dict get $data(common)]
} elseif {[::llength $args] == 1} then {
::dict get $data(common) {*}$args
} else {
::dict set data(common) {*}$args
::lindex $args end
}
} false
method $class destroy args {
::if {[exists $self]} then {
set result [$self __destructor]
::variable data
::unset data($self)
::rename $self ""
set result
} else {
# presumably a Tk widget was to destroy
::destroy $self {*}$args
}
} false
# debugging purposes
method $class inside args {{*}$args}
# define special procedures our & my
proc class::${class}::our args {
::variable data
::if {![::llength $args]} then {
::dict keys $data(common)
} elseif {[::llength $args] == 1} then {
::dict get $data(common) {*}$args
} else {
::dict set data(common) {*}$args
}
}
proc class::${class}::my args {
::upvar self self
::variable data
::if {![::llength $args]} then {
::dict keys [::dict get $data($self) private]
} elseif {[::llength $args] == 1} then {
::dict get $data($self) private {*}$args
} else {
::dict set data($self) private {*}$args
::dict get $data($self) private [::lindex $args 0]
}
}
proc class::${class}::!my {name args} {
# removes key from dict,
# returns value of previously destroyed key
::upvar self self
::variable data
::catch {::dict get $data($self) private $name {*}$args} result
::dict unset data($self) private $name {*}$args
::set result
}
proc class::${class}::?my {name args} {
# shortcut for ::dict get [my $name {*}$args]
::upvar self self
::variable data
::dict get $data($self) private $name {*}$args
}
array set opt [concat {
-configure {}
-common {}
} $args]
foreach {key val} $opt(-configure) {
configure $class $key $val
}
dict keys $opt(-common)
set class::${class}::data(common) $opt(-common)
list class $class
}
proc obj::common {class {key ?} args} {
if {$key eq "?"} then {
inscope $class "dict keys \$data(common)"
} elseif {$args eq ""} then {
inscope $class "dict get \$data(common) $key"
} else {
lassign $args val
dict set class::${class}::data(common) $key $val
list in class $class, common $key is $val
}
}
proc obj::exists obj {
if {[::info proc $obj] eq ""} then {
return false
}
set ins [namespace current]::inst::*
if {![string match $ins $obj]} then {
return false
}
set cns [namespace current]::class::*
if {![string match $cns [namespace origin $obj]]} then {
return false
}
return true
}
#
# obj::method $class $method {...} {...}
# cares pf forbidden method names
#
proc obj::method {class {method {}} args} {
if {$method eq ""} then {
set result {}
foreach p [::info procs [::namespace current]::class::${class}::*] {
if {[string first __ $p] < 0 &&
$p ni {configure destroy cget} &&
[lindex [::info args $p] 0] eq "self"} then {
lappend result [namespace tail $p]
}
}
set result
} elseif {$args eq {}} then {
set m [namespace current]::class::${class}::$method
if {[::info procs $m] ne $m} then {
set result {}
foreach p [::info procs $m] {
lappend result [::namespace tail $p]
}
set result
} else {
::list [::namespace origin method] $class $method\
[lrange [info args $m] 1 end]\
[info body $m]
}
} else {
lassign $args argl body check
if {![string is false -strict $check]} then {
switch -glob -- $method\
_root-object_ - __constructor - __destructor - destroy -\
new - my - our - private - common - isa -\
configure - cget - __configure-* - __cget-* - __validate-* {
return -code error [list forbidden method name: $method, sorry!]
}
upvar [namespace current]::class::${class}::data data
if {$method ni $data(methods)} then {
lappend data(methods) $method
}
if {[::info command ::$method] ne ""} then {
puts stderr\
"Warning: method $method in class $class hides command ::$method"
}
set procName [namespace current]::class::${class}::$method
if {[::info command $procName] ne "" &&
[lindex [::info args $procName] 0] ne "self"} then {
puts stderr\
"Warning: method $method in class $class overwrites a procedure!"
}
}
proc $class $method [concat self $argl] $body
list method $class $method
}
}
proc obj::proc args {
if {[llength $args] == 3} then {
::proc {*}$args
} elseif {[llength $args] == 4} then {
inscope [lindex $args 0] ::proc {*}[lrange $args 1 end]
} else {
append err [::info level 0]\
\n---\neither:\n\
"proc name argl body"\
\nor:\n\
"proc class name argl body"
return -code error $err
}
}
#
# obj::constructor $classname {...} {...}
# obj::destructor $classname {...}
#
proc obj::constructor {class args body} {
method $class __constructor $args $body false
list constructor $class
}
proc obj::destructor {class body} {
method $class __destructor {} $body false
list destructor $class
}
#
# obj::new $class ?options ?more??
# options are recognized by leading -
# parsing options is stopped by --
# additional args for constructor can follow the options
#
proc obj::new {class args} {
variable counter
set objName [namespace current]::inst::[incr counter]
namespace import -force class::${class}::_root-object_
rename _root-object_ $objName
dict set class::${class}::data($objName) option\
[set class::${class}::data(options)]
dict set class::${class}::data($objName) private {}
set index 0
foreach {key val} $args {
if {[string index $key 0] ne "-" ||
[string is double -strict $key]} then break
if {$key eq "--"} then {
incr index
break
}
incr index 2
dict set class::${class}::data($objName) option $key $val
}
$objName __constructor {*}[lrange $args $index end]
set objName
}
#
# obj::local $class ...
# creates new object inside procedure body
# and manages that it destroys on leaving this procedure.
#
proc obj::local {class args} {
set obj [new $class {*}$args]
set name [string map {:: :} [list local object $obj]]
uplevel [list set $name $obj]
uplevel\
[list trace add variable $name unset\
"$obj destroy;#"]
set obj
}
#
# obj::option $class $key ?$val?
# installs appropriate option for class
#
proc obj::configure {class key {val ""}} {
if {[string index $key 0] ne "-"} then {
set key -$key
}
dict set class::${class}::data(options) $key $val
method $class __cget$key {} # false
method $class __validate$key val # false
method $class __configure$key val # false
lappend [namespace current]::class::${class}::data(methods)\
__configure$key __cget$key __validate$key
list class $class has option $key with default $val
}
#
# obj::cgetmethod $lass $key {...}
# obj::validatemethod $lass $key {...}
# obj::configuremethod $lass $key $val {...}
# intended for additional control.
# These procs are invoked by delegate option (below).
#
proc obj::cgetmethod {class {key ""} args} {
if {$key eq ""} then {
set result {}
foreach m [::info procs [namespace current]::class::${class}::__cget-*] {
set opt [regexp -inline {[-][^.]+$} $m]
set body [::info body $m]
if {[string trim [string trimleft [string trim $body] #]] ne ""} then {
lappend result $opt
}
}
set result
} elseif {$args eq ""} then {
list [namespace origin cgetmethod] $class $key\
[::info body [namespace current]::class::${class}::__cget$key]
} else {
lassign $args body
method $class __cget$key {} $body false
list cgetmethod $class $key
}
}
proc obj::configuremethod {class {key ""} {val ""} {body #}} {
if {$key eq ""} then {
set result {}
foreach m [::info procs [namespace current]::class::${class}::__configure-*] {
set opt [regexp -inline {[-][^.]+$} $m]
set body [::info body $m]
if {[string trim [string trimleft [string trim $body] #]] ne ""} then {
lappend result $opt
}
}
set result
} elseif {$val eq ""} then {
list [namespace origin configuremethod] $class $key\
[lrange [::info args [namespace current]::class::${class}::__configure$key] 1 end]\
[::info body [namespace current]::class::${class}::__configure$key]
} else {
method $class __configure$key $val $body false
list configuremethod $class $key
}
}
proc obj::validatemethod {class {key ""} {val ""} {body #}} {
if {$key eq ""} then {
set result {}
foreach m [::info procs [namespace current]::class::${class}::__validate-*] {
set opt [regexp -inline {[-][^.]+$} $m]
set body [::info body $m]
if {[string trim [string trimleft [string trim $body] #]] ne ""} then {
lappend result $opt
}
}
set result
} elseif {$val eq ""} then {
list [namespace origin validatemethod] $class $key\
[lrange [::info args [namespace current]::class::${class}::__validate$key] 1 end]\
[::info body [namespace current]::class::${class}::__validate$key]
} else {
method $class __validate$key $val $body false
list validatemethod $class $key
}
}
proc obj::read-only {class key} {
validatemethod $class $key val [subst -nocommand {
return -code error\
[list You tried to set \$val on\
read-only option $key of class $class.]
}]
list option $key of class $class is read-only.
}
#
# delegate methods & options to components
#
namespace eval obj {
namespace eval delegate {
namespace export *
namespace ensemble create
}
}
#
# obj::delegate method $method $class $component ?as-method?
#
proc obj::delegate::method {method class component {as ""}} {
if {$as eq ""} then {
set as $method
}
set ns [namespace qualifiers [namespace current]]
${ns}::method $class $method args [subst -nocommand {
# delegate to $component as $as
\$self component $component $as {*}\$args
}]
lappend result\
class $class delegates method $method to component $component
if {$as ne $method} then {
lappend result as $as
}
set result
}
#
# obj::delegate option $option $class $component ?as-option?
#
proc obj::delegate::option {option class component {as ""}} {
if {$as eq ""} then {
set as $option
}
set ns [namespace qualifiers [namespace current]]
${ns}::configuremethod $class $option args [subst -nocommand {
\$self component $component configure $as {*}\$args
}]
${ns}::cgetmethod $class $option [subst -nocommand {
variable data
dict set data(\$self) option $option\
[\$self component $component cget $as]
}]
list class $class delegates option $option to component $component\
{*}[if {$as ne $option} then {list as $as}]
}
#
# obj::inscope $class cmd ...
#
proc obj::inscope {class args} {
namespace inscope [namespace current]::class::$class {*}$args
}
proc obj::help {{cmd --}} {
set procs ""
foreach p [info procs [namespace current]::*] {
if {[string first _ $p] < 0} then {
lappend procs [namespace tail $p]
}
}
if {$cmd ni $procs} then {
set procs
} else {
set argl {}
foreach arg [::info args $cmd] {
if {[::info default $cmd $arg def]} then {
lappend argl [list $arg $def]
} else {
lappend argl $arg
}
}
list obj::$cmd $argl
}
}
19.10.2022
<< | Heimatseite | Verzeichnis | Stichworte | Autor | >>