Version 22 of Implementation of struct::record using TclOO

Updated 2013-11-05 15:05:21 by nagu

[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 differences 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

DateChange
2013-11-05Changed record create to record define. Implemented record exists instanceName as per the original spec.
2013-11-05Support for record show records added.
2013-11-04Refactored the code and added a 'instance clear' method to reset an instance's values to initial values.
2013-11-03Changed cget method to get 'args' as its argument. Updated demo code to use cget and configure methods.
2013-11-01Initial 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 <undefined>
        }
        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 <null>}
} 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 <null>}

-id -1 -name {} -rollno {} -address_id <null>

        {id -1}
        {name ""}
        {rollno ""}
        {address_id <null>}

-id -1 -name {configured name} -rollno {configured rollno} -address_id <null>
-id -1 -name {} -rollno {} -address_id <null>
1
1

0

0