'''[[2013-11-09 - 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. Its fully compliant with struct::record page as it has successfully passed all the tests in Tcllib's record.test suite.

Comments are welcome...

----
**History**

%|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?

''[nagu] 2013-10-09'' - Thanks. Haven't compared the performance yet... Will let you know.
----
**Code**
======
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

======


----
**Demo**

======
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]
======

----
**Ouput**

======
-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
======
<<categories>>TclOO|Data Structure|Tcllib