this thread

History edit

Code edit

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 edit

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 edit

-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

Performance Code edit

proc perf {} {
    catch {record delete record phones}
    record define phones {home work cell}
    catch {record delete record contact} 
    record define contact {
    first
    middle
    last
    {record phones phlist}
    }
    catch {record delete record mycontact} 
    record define mycontact {
      age
      sex
      {record contact cont}
    }
    catch {record delete record location} 
    record define location {
      street
      city
    state
    {country USA}
    } loc(1) loc(5)
    catch {
    record define circular {
      one
      {record circular cir}
    } cir(1)
    } err
    contact cont(1)
    contact #auto
    set res [mycontact #auto]
    lappend res [record show values $res]
    set res
    cont(1).first Brett
    cont(1).phlist.cell 425-555-1212
    mycontact0.cont.phlist.cell 206-555-1212
    cont(1) config -middle Allen -last Schwarz
    mycontact0 config -cont.phlist.cell 206-555-1212
    cont(1) cget -first -middle -last
    mycontact0 cget -cont.phlist.cell
    cont(1).first
    loc(1) cget -country
    loc(1) config -street somestreet -city somecity -state somestate -country somecountry
    cont(1) config -phlist.home 425-555-1212
    cont(1) cget -phlist.home
    loc(1) config
    loc(1) cget
    loc(1)
    cont(1).phlist.cell
    location loc(2) -street street2 -city city2 -state state2 -country country2
    loc(2).street
    contact cont(2) -first John -middle Q -last Doe -phlist [list home 425-555-1212 work 425-555-1222 cell 425-555-1111]
    eval contact cont(3) [cont(1)]
    cont(2).phlist.home
    catch {record delete record new_contact} 
    record define new_contact [record show members contact]
    record show records
    record show members phones
    record show members location
    record show members contact
    record show values loc(1)
    record show values cont(1)
    record show instance location
    record delete instance loc(2)
    record delete instance cont(2)
    record delete record location
    record exists instance loc(1)
    record exists instance cont(1)
    record exists instance junk
    record exists record contact
    namespace eval myns {
    catch {record delete record myns::phones} 
    record define phones {home work cell}
    }
    catch {record delete record ::myns::contact} 
    record define ::myns::contact {
    first
    middle
    last
    {record phones phlist}
    }
    namespace eval myns {
    catch {record delete record location} 
    record define location {
      street
      city
      state
      {country USA}
    } loc(1) loc(5)
    }
    catch {
    namespace eval myns {
      record define circular {
      one
      {record ::myns::circular cir}
      } cir(1)
    }
    } err
    set err
    namespace eval myns {
    contact cont(1)
    }
    namespace eval myns {
    contact #auto
    }
    myns::cont(1).first Brett
    myns::cont(1).phlist.cell 425-555-1212
    myns::cont(1) config -middle Allen -last Schwarz
    myns::cont(1) cget -first -middle -last
    myns::loc(1) cget -country
    myns::loc(1) config -street somestreet -city somecity -state somestate -country somecountry
    myns::cont(1) config -phlist.home 425-555-1212
    myns::cont(1) cget -phlist.home
    myns::loc(1) config
    myns::loc(1) cget
    myns::loc(1)
    myns::cont(1).phlist.cell
    namespace eval myns {
    location loc(2) -street street2 -city city2 -state state2 -country country2
    }
    myns::loc(2).street
    namespace eval myns {
    contact cont(2) -first John -middle Q -last Doe -phlist [list home 425-555-1212 work 425-555-1222 cell 425-555-1111]
    }
    myns::cont(2).phlist.home
    record show records
    record show members myns::phones
    record show members myns::location
    record show members myns::contact
    record show values myns::loc(1)
    record show values myns::cont(1)
    record show instance myns::location
    record delete instance myns::loc(2)
    record delete instance myns::cont(2)
    record delete record myns::location
    record exists instance myns::loc(1)
    record exists instance myns::cont(1)
    record exists instance myns::junk
    record exists record myns::contact
    set res {}
    lappend res [contact #auto]
    lappend res [contact #auto]

    record delete instance [lindex $res end]

    lappend res [contact #auto]
}


puts [time {perf} 1000]

Performance Result edit

• Home
• Recent changes
• Help
• WhoAmI/Logout
• Create new page
• Random page
• Previous page
• Next page
• 
  
• Add comments
• Edit
• History
• Edit summary
• References