'''[[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 https://groups.google.com/forum/#!topic/comp.lang.tcl/sBiVwW7mpKw%|%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... ---- **History** %|Date|Change|% &|2013-11-05|Changed [record create] to [record define]. Implemented [record exists 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|& ---- **Code** ====== package require Tcl 8.6 package require TclOO oo::class create recordInst { constructor {mnames ivals args} { oo::objdefine [self] [list variable {*}$mnames] foreach n $mnames { my variable $n set $n [dict get $ivals $n] } foreach {opt v} $args { set n [string range $opt 1 end] set $n $v } oo::objdefine [self] [list variable _ivals] my variable _ivals set _ivals $ivals } method cget {args} { switch -- [llength $args] { 1 { set n [string range $args 1 end] my variable $n return $n } 0 { return [my show] } default { foreach o $args { set n [string range $o 1 end] my variable $n lappend result [set $n] } } } } method configure {args} { if {$args != ""} { foreach {opt val} $args { set n [string range $opt 1 end] my variable $n set $n $val } } else { return [my show] } } method clear {} { my variable _ivals dict for {n val} $_ivals { my variable $n set $n $val } } method show {} { my variable _ivals set result {} foreach n [dict keys $_ivals] { my variable $n lappend result -$n [set $n] } return $result } } oo::class create recordType { constructor {recorddefn args} { oo::objdefine [self] variable _recorddefn _mnames _ivals my variable _recorddefn my variable _mnames my variable _ivals set _recorddefn $recorddefn set mnames [list] set ivals [dict create] foreach member $recorddefn { lassign $member n v lappend mnames $n switch -- [llength $member] { 1 { dict set ivals $n } 2 { dict set ivals $n $v } default { return -code error "Unsupported nested definition $f found in [self]." } } } set _mnames $mnames set _ivals $ivals set create_method { method create {name args} { next $name ${mnames} ${ivals} {*}$args } } set create_method [string map [list \${mnames} [list $mnames] \${ivals} [list $ivals]] $create_method] oo::objdefine [self] $create_method oo::objdefine [self] { method show {} { my variable _recorddefn return $_recorddefn } } 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 -- $what { record - records { return [uplevel 1 [list info class instances [self]]] } instances { set ns [uplevel 1 [list namespace which $of]] return [uplevel 1 [list info class instances $ns]] } members { set ns [uplevel 1 [list namespace which $of]] return [uplevel 1 [list $of show]] } values { set ns [uplevel 1 [list namespace which $of]] return [uplevel 1 [list $of show]] } } } method exists {what obj {type ""}} { set nsobj [uplevel 1 [list namespace which $obj]] if {$nsobj == ""} { return 0 } switch -- $what { instance { 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 ====== ---- **Demo** ====== package require Record 0.1 record define Employee { {id -1} {name ""} {rollno ""} {address_id } } emp1 emp2 puts [record show records] puts [record show instances Employee] puts [record show members Employee] puts [record show values emp1] 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 Employee] puts [record delete instance emp1] puts [record exists instance emp1 Employee] puts [record delete record Employee] puts [record exists record Employee] ====== ---- **Ouput** ====== ::Employee ::emp1 ::emp2 {id -1} {name ""} {rollno ""} {address_id } -id -1 -name {} -rollno {} -address_id {id -1} {name ""} {rollno ""} {address_id } -id -1 -name {configured name} -rollno {configured rollno} -address_id -id -1 -name {} -rollno {} -address_id 1 1 0 0 ====== <>TclOO|Data Structure|Tcllib