[2013-11-05 - nagu]: In the process of learning TclOO (mainly about metaclasses), I attempted to implement struct::record using TclOO. Initial versions were posted on c.l.t group and comments received from experts there. Pls. see this thread . The implementation source code can be found below. While it complies to almost all of the specification of struct::record, one major difference noted, as of now, is the lack of support for nested definitions (which I plan to add in due course of time).
Comments are welcome...
Date | Change |
---|---|
2013-11-09 | 100% successful run of all tests in Tcllib record.test suite |
2013-11-09 | Added support for nested definitions, C++ style member access aliases using "." |
2013-11-06 | Added support for recordName instanceName ?args? syntax. Eg., Employee emp1 -name "n1" |
2013-11-05 | Changed record create to record define. Implemented record exists instance instanceName as per the original spec. |
2013-11-05 | Support for record show records added. |
2013-11-04 | Refactored the code and added a 'instance clear' method to reset an instance's values to initial values. |
2013-11-03 | Changed cget method to get 'args' as its argument. Updated demo code to use cget and configure methods. |
2013-11-01 | Initial version |
escargo 2013-10-09 - With the passage of all the tests (congratulations!), then comes the question about how this implementation performs relative to the Tcllib implementation. Any idea?
package require Tcl 8.6 package require TclOO oo::class create recordInst { constructor {mnames ivals srecs args} { oo::objdefine [self] [list variable {*}$mnames _ivals _srecs] my variable _ivals my variable _srecs set _ivals $ivals set _srecs $srecs foreach n $mnames { my variable $n if {[dict exists $srecs $n]} { set srec [uplevel 1 [list [dict get $srecs $n] create [namespace which [self]]::$n]] set $n $srec dict set _srecs $n $srec } else { set $n [dict get $ivals $n] set a [my _alias $n] uplevel #0 [list interp alias {} $a {} [self] access $n] } } foreach {opt v} $args { uplevel 1 [list [self] configure $opt $v] } } method access {n args} { my variable _srecs my variable $n if {$n == ""} { return [my cget] } switch -- [llength $args] { 0 { return [set $n] } 1 { return [set $n [lindex $args 0]] } 2 { lassign $args op val if {$op != "="} { return -code error "Unrecognized operator $op when trying to configure $opt" } return [set $n $val] } default { return -code error "Invalid access format when trying to configure $opt" } } } method cget {args} { my variable _srecs set result "" switch -- [llength $args] { 0 { set result [my show] } default { set count 1 foreach o $args { set n [string trimleft $o -] my variable $n if {[dict exists $_srecs $n]} { lappend result [uplevel 1 [list [namespace which [self]]::$n cget]] } else { lassign [my _cmd $n] cmd n lappend result [uplevel 1 [list $cmd access $n]] } incr count } if {$count == 1} { set result [lindex $result 0] } } } return $result } method configure {args} { if {$args == ""} { return [my show] } my variable _srecs foreach {opt val} $args { set n [string trimleft $opt -] my variable $n if {[dict exists $_srecs $n]} { uplevel 1 [list [namespace which [self]]::$n configure {*}$val] } else { lassign [my _cmd $n] cmd n uplevel 1 [list $cmd access $n $val] } } } method clear {} { my variable _ivals dict for {n val} $_ivals { my variable $n set $n $val } } method show {} { my variable _ivals my variable _srecs set result {} foreach n [dict keys $_ivals] { my variable $n if {[dict exists $_srecs $n]} { lappend result -$n [uplevel 1 [list [dict get $_srecs $n] show]] } else { lappend result -$n [set $n] } } return $result } method unknown {args} { if {$args == ""} { return [uplevel 1 [list [self] show]] } set name [lindex $args 0] set args [lrange $args 1 end] switch -glob -- $name { "config*" { uplevel 1 [list [self] configure {*}$args] } default { uplevel 1 [list [self] create $name {*}$args] } } } method _alias {n {l 2}} { set nscurrent [uplevel $l [list namespace current]] set nsself [namespace which [self]] set nsself [string range $nsself [string length $nscurrent] end] set result $nscurrent if {$result == "::"} { append result [format "%s.%s" [join [list {*}[string map {:: " "} $nsself]] "."] $n] } else { append result [format "::%s.%s" [join [list {*}[string map {:: " "} $nsself]] "."] $n] } return $result } method _cmd {n} { set nsself [namespace which [self]] set pos [string last . $n] if {$pos < 0} { return [list $nsself $n] } set parents "[string map {. "::"} [string range $n 0 [expr $pos-1]]]" set leaf [string range $n [expr $pos + 1] end] return [list [format "%s::%s" $nsself $parents] $leaf] } } oo::class create recordType { constructor {recorddefn args} { oo::objdefine [self] export createWithNamespace oo::objdefine [self] variable _recorddefn _mnames _ivals my variable _recorddefn my variable _mnames my variable _ivals my variable _instid set _instid 0 set _recorddefn [list {*}$recorddefn] set mnames [list] set ivals [dict create] set srecs [dict create] foreach member $recorddefn { switch -- [llength $member] { 1 { dict set ivals $member {} lappend mnames $member } 2 { lassign $member n v dict set ivals $n $v lappend mnames $n } 3 { lassign $member r t n if {$r != "record"} { return -code error "Unexpected keyword '$r' in row definition '$member' of [self]" } set nst [uplevel 1 [list namespace which $t]] if {$nst == [self]} { return -code error "Can not have circular records. Structure was not created." } lappend mnames $n dict set ivals $n {} dict set srecs $n $t } default { return -code error "Unsupported nested definition $member found in [self]." } } } set _mnames $mnames set _ivals $ivals set _srecs $srecs set create_method { method create {instname args} { my variable _instid if {$instname == "#auto"} { set instname "[string tolower [self]]$_instid" incr _instid } next $instname ${mnames} ${ivals} ${srecs} {*}$args } } set create_method [string map [list \${mnames} [list $mnames] \${ivals} [list $ivals] \${srecs} [list $srecs]] $create_method] oo::objdefine [self] $create_method oo::objdefine [self] { method show {} { my variable _recorddefn return $_recorddefn } method unknown {args} { if {$args == ""} { return [uplevel 1 [list [self] show]] } set name [lindex $args 0] set args [lrange $args 1 end] switch -glob -- $name { "config*" { uplevel 1 [list [self] configure {*}$args] } default { uplevel 1 [list [self] create $name {*}$args] } } } } oo::define [self] { mixin recordInst } foreach inst $args { uplevel 1 [list [self] create $inst] } } } oo::class create record { superclass oo::class mixin recordType self { forward define my create method show {what {of ""}} { switch -glob -- $what { "record*" { return [lsort [uplevel 1 [list info class instances [self]]]] } "inst*" { set ns [uplevel 1 [list namespace which $of]] return [lsort [uplevel 1 [list info class instances $ns]]] } "mem*" { set ns [uplevel 1 [list namespace which $of]] return [uplevel 1 [list $of show]] } "val*" { set ns [uplevel 1 [list namespace which $of]] return [uplevel 1 [list $of show]] } } } method exists {what obj} { set nsobj [uplevel 1 [list namespace which $obj]] if {$nsobj == ""} { return 0 } switch -glob -- $what { "inst*" { set recordtypes [uplevel 1 [list info class instances [self]]] foreach rt $recordtypes { set nstype [uplevel 1 [list namespace which $rt]] set found [uplevel 1 [list info object isa typeof $nsobj $nstype]] if {$found} { return $found } } return 0 } "record*" { return [uplevel 1 [list info object isa typeof $nsobj [self]]] } } } method delete {what obj {type ""}} { set nsobj [uplevel 1 [list namespace which $obj]] return [uplevel 1 [list $nsobj destroy]] } } } package provide Record 0.1
record define Phone { {mobile ""} {landline ""} } record define Contact { {email_id ""} {website ""} {record Phone phone} } record define Employee { {id -1} {name ""} {rollno ""} {address_id <null>} {record Contact contact} } emp1 emp1.contact.phone.mobile "testmobile" puts [record show values emp1] Employee emp2 -name "constructed name" puts [emp2 cget] puts [emp2.name] puts [emp2.contact.phone.landline] puts [record show records] puts [record show instances Employee] puts [record show instances Contact] puts [record show instances Phone] puts [record show members Employee] puts [Employee show] emp2 configure -name "configured name" -rollno "configured rollno" puts [emp2 cget] emp2 clear puts [emp2 cget] puts [record exists record Employee] puts [record exists instance emp1] puts [record delete instance emp1] puts [record exists instance emp1] puts [record delete record Employee] puts [record exists record Employee]
-id -1 -name {} -rollno {} -address_id <null> -contact {-email_id {} -website {} -phone {-mobile testmobile -landline {}}} -id -1 -name {constructed name} -rollno {} -address_id <null> -contact {-email_id {} -website {} -phone {-mobile {} -landline {}}} constructed name ::Contact ::Employee ::Phone ::emp1 ::emp2 ::emp1::contact ::emp2::contact ::emp1::contact::phone ::emp2::contact::phone {id -1} {name ""} {rollno ""} {address_id <null>} {record Contact contact} {id -1} {name ""} {rollno ""} {address_id <null>} {record Contact contact} -id -1 -name {configured name} -rollno {configured rollno} -address_id <null> -contact {-email_id {} -website {} -phone {-mobile {} -landline {}}} -id -1 -name {} -rollno {} -address_id <null> -contact {-email_id {} -website {} -phone {-mobile {} -landline {}}} 1 1 0 0