Tcl has no struct or record facility. We can approximate them with keyed lists or the like, but they just aren't as compact or usable as a simple record. Thus was born:
proc record { op rec args } {
upvar type-$rec type
upvar len-$rec len
switch -exact $op {
define {
set type $args
set len [ llength $args ]
}
new {
set varname [ lindex $args 0 ]
set args [ lreplace $args 0 0 ]
upvar $varname instance
set instance [ eval list $rec $args ]
}
get {
upvar $rec instance
set rec [ lindex $instance 0 ]
upvar type-$rec type
set element [ lsearch -exact $type $args ]
if { $element == -1 } {
bail "no such element $args in $rec"
} else {
incr element
return [ lindex $instance $element ]
}
}
set { upvar $rec instance
set instname $rec
set rec [ lindex $instance 0 ]
upvar type-$rec type
set field [ lindex $args 0 ]
if { [ llength $args ] == 1 } {
return [ uplevel record get $instname $field ]
}
set value [ lrange $args 1 end ]
set element [ lsearch -exact $type $field ]
if { $element == -1 } {
bail "no such element $field in $rec"
} else {
incr element
return [set instance [lreplace $instance $element $element $value]]
}
}
}
}What's different here? Well, rather than dragging the field names around with each individual record we can define a prototype list. This prototype names the fields of the record, and is used to look up which field you want when you ask for it, or change it. Dicts, keyed lists, and array all incur this overhead. Records have only one definition, objects declared this way consist only of their record type and the actual data for each field.
For a (trivial) example:
#source record.tcl - as needed record define person name height weight record new person larry "" "" "" record set larry name "Larry Smith" record set larry height 6'4\" puts "Larry: $larry" puts "larry.height=[record get larry height]" puts "larry.height=[record set larry height]"
The notation is not compact, but I left it this way to show how it works. Any of the normal currying methods like Custom curry can shorten it easily.
BAS - See also the record package in tcllib (struct), although I'd like to update that to use dicts internally some day
Extended version of the example above, added som new functions which could mirror some features from ::struct::record posted by kruzalex
proc record { op {rec ""} {args ""}} {
upvar records records
switch -exact $op {
define {
upvar type-$rec type
upvar len-$rec len
set type [eval concat $args]
lappend records $rec
set len [ llength $args ]
}
"delete record" {
upvar record-$rec record
if {[ lsearch -exact $record $rec ] != -1} {
upvar instname-$rec instname
unset record instname
set element [ lsearch -exact $records $rec ]
set records [lrange $records [expr $element+1] end]
} else {
return -code error "Could not delete record - record does not exist"
}
}
"delete instance" {
upvar instname-$rec instname
if {[info exists instname]==0} {
return -code error "Could not delete instance - parent record does not exist"
} else {
if {[ lsearch -exact $instname $args ] != -1} {
set element [string first $args $instname]
set instname [lrange $instname [expr $element+1] end]
} else {
return -code error "Could not delete instance - instance does not exist"
}
}
}
"show members" -
"show types" {
upvar type-$rec type
set type
}
"show records" {
set records
}
"show instances" {
upvar instname-$rec instname
if {[ lsearch -exact $records $rec ] != -1} {
set instname
} else {
return -code error "Could not show instances for requested record - record does not exist"
}
}
"show values" {
upvar $rec instance
return [lrange $instance 1 end]
}
"exists record" {
if {[ lsearch -exact $records $rec ] != -1} {
return 1
} else {
return 0
}
}
configure {
upvar type-$rec type
upvar len-$rec len
if {[llength $args] == 0} {
puts [set type]
} else {
append type " " $args
set len [ llength $args ]
}
}
new {
upvar record-$rec record
upvar instname-$rec instname
set record $rec
if {[llength [lindex $args 0]] > 0} {
if {[info exists instname]==0} {
set instname [lindex $args 0]
} else {
append instname " " [lindex $args 0]
}
}
set varname [ lindex $args 0 ]
set args [ lreplace $args 0 0 ]
upvar $varname instance
set instance [ eval list $rec $args ]
}
get {
upvar $rec instance
upvar record-$rec record
set rec [ lindex $instance 0 ]
upvar type-$rec type
set element [ lsearch -exact $type $args ]
if { $element == -1 } {
bail "no such element $args in $rec"
} else {
incr element
return [ lindex $instance $element ]
}
}
set {upvar $rec instance
upvar record-$rec record
set rec [ lindex $instance 0 ]
set record $rec
upvar type-$rec type
set field [ lindex $args 0 ]
if { [ llength $args ] == 1 } {
return [ uplevel record get $instname $field ]
}
set value [ lrange $args 1 end ]
set element [ lsearch -exact $type $field ]
if { $element == -1 } {
bail "no such element $field in $rec"
} else {
incr element
return [set instance [lreplace $instance $element $element $value]]
}
}
}
}
record define person name height weight
record define class first second third
record configure person
record configure person age
# copy one record to another record
record define level [record "show members" class]
#
puts "types level: [record "show types" level]"
puts "types person: [record "show types" person]"
puts "types class: [record "show types" class]"
puts "records: [record "show records"]"
record new person
record new person larry {} {} {}
record new person garry {} {} {}
record new person perry {} {} {}
puts "record show instances: [record "show instances" person]"
record set larry name "Larry Smith"
record set larry height 6'4\"
puts "larry.height=[record get larry height]"
puts "show values: [record "show values" larry]"
puts "show values: [record "show values" garry]"
puts [record "exists record" person]
record "delete record" person
puts [record "exists record" person]
puts "record show instances: [record "show instances" person]"