1#============================================================ 2# ::struct::record -- 3# 4# Implements a container data structure similar to a 'C' 5# structure. It hides the ugly details about keeping the 6# data organized by using a combination of arrays, lists 7# and namespaces. 8# 9# Each record definition is kept in a master array 10# (_recorddefn) under the ::struct::record namespace. Each 11# instance of a record is kept within a separate namespace 12# for each record definition. Hence, instances of 13# the same record definition are managed under the 14# same namespace. This avoids possible collisions, and 15# also limits one big global array mechanism. 16# 17# Copyright (c) 2002 by Brett Schwarz 18# 19# See the file "license.terms" for information on usage and redistribution 20# of this file, and for a DISCLAIMER OF ALL WARRANTIES. 21# 22# This code may be distributed under the same terms as Tcl. 23# 24# $Id: record.tcl,v 1.10 2004/09/29 20:56:18 andreas_kupries Exp $ 25# 26#============================================================ 27# 28#### FIX ERROR MESSAGES SO THEY MAKE SENSE (Wrong args) 29 30namespace eval ::struct {} 31 32namespace eval ::struct::record { 33 34 ## 35 ## array of lists that holds the 36 ## definition (variables) for each 37 ## record 38 ## 39 ## _recorddefn(some_record) var1 var2 var3 ... 40 ## 41 variable _recorddefn 42 43 ## 44 ## holds the count for each record 45 ## in cases where the instance is 46 ## automatically generated 47 ## 48 ## _count(some_record) 0 49 ## 50 51 ## This is not a count, but an id generator. Its value has to 52 ## increase monotonicaly. 53 54 variable _count 55 56 ## 57 ## array that holds the defining record's 58 ## name for each instances 59 ## 60 ## _defn(some_instances) name_of_defining_record 61 ## 62 variable _defn 63 array set _defn {} 64 65 ## 66 ## This holds the defaults for a record definition. 67 ## If no default is given for a member of a record, 68 ## then the value is assigned to the empty string 69 ## 70 variable _defaults 71 72 ## 73 ## These are the possible sub commands 74 ## 75 variable commands 76 set commands [list define delete exists show] 77 78 ## 79 ## This keeps track of the level that we are in 80 ## when handling nested records. This is kind of 81 ## a hack, and probably can be handled better 82 ## 83 set _level 0 84 85 namespace export record 86} 87 88#------------------------------------------------------------ 89# ::struct::record::record -- 90# 91# main command used to access the other sub commands 92# 93# Arguments: 94# cmd_ The sub command (i.e. define, show, delete, exists) 95# args arguments to pass to the sub command 96# 97# Results: 98# none returned 99#------------------------------------------------------------ 100# 101proc ::struct::record::record {cmd_ args} { 102 variable commands 103 104 if {[lsearch $commands $cmd_] < 0} { 105 error "Sub command \"$cmd_\" is not recognized. Must be [join $commands ,]" 106 } 107 108 set cmd_ [string totitle "$cmd_"] 109 return [uplevel 1 ::struct::record::${cmd_} $args] 110 111}; # end proc ::struct::record::record 112 113 114#------------------------------------------------------------ 115# ::struct::record::Define -- 116# 117# Used to define a record 118# 119# Arguments: 120# defn_ the name of the record definition 121# vars_ the variables of the record (as a list) 122# args instances to be create during definition 123# 124# Results: 125# Returns the name of the definition during successful 126# creation. 127#------------------------------------------------------------ 128# 129proc ::struct::record::Define {defn_ vars_ args} { 130 131 variable _recorddefn 132 variable _count 133 variable _defaults 134 135 set defn_ [Qualify $defn_] 136 137 if {[info exists _recorddefn($defn_)]} { 138 error "Record definition $defn_ already exists" 139 } 140 141 if {[lsearch [info commands] $defn_] >= 0} { 142 error "Structure definition name can not be a Tcl command name" 143 } 144 145 set _defaults($defn_) [list] 146 set _recorddefn($defn_) [list] 147 148 149 ## 150 ## Loop through the members of the record 151 ## definition 152 ## 153 foreach V $vars_ { 154 155 set len [llength $V] 156 set D "" 157 158 ## 159 ## 2 --> there is a default value 160 ## assigned to the member 161 ## 162 ## 3 --> there is a nested record 163 ## definition given as a member 164 ## 165 if {$len == 2} { 166 167 set D [lindex $V 1] 168 set V [lindex $V 0] 169 170 } elseif {$len == 3} { 171 172 if {![string match "record" "[lindex $V 0]"]} { 173 174 Delete record $defn_ 175 error "$V is a Bad member for record definition 176 definition creation aborted." 177 } 178 179 set new [lindex $V 1] 180 181 set new [Qualify $new] 182 183 ## 184 ## Right now, there can not be circular records 185 ## so, we abort the creation 186 ## 187 if {[string match "$defn_" "$new"]} { 188 Delete record $defn_ 189 error "Can not have circular records. Structure was not created." 190 } 191 192 ## 193 ## Will take care of the nested record later 194 ## We just join by :: because this is how it 195 ## use to be declared, so the parsing code 196 ## is already there. 197 ## 198 set V [join [lrange $V 1 2] "::"] 199 } 200 201 lappend _recorddefn($defn_) $V 202 lappend _defaults($defn_) $D 203 } 204 205 206 uplevel #0 [list interp alias {} $defn_ {} ::struct::record::Create $defn_] 207 208 set _count($defn_) 0 209 210 namespace eval ::struct::record${defn_} { 211 variable values 212 variable instances 213 214 set instances [list] 215 } 216 217 ## 218 ## If there were args given (instances), then 219 ## create them now 220 ## 221 foreach A $args { 222 223 uplevel 1 [list ::struct::record::Create $defn_ $A] 224 } 225 226 return $defn_ 227 228}; # end proc ::struct::record::Define 229 230 231#------------------------------------------------------------ 232# ::struct::record::Create -- 233# 234# Creates an instance of a record definition 235# 236# Arguments: 237# defn_ the name of the record definition 238# inst_ the name of the instances to create 239# args values to set to the record's members 240# 241# Results: 242# Returns the name of the instance for a successful creation 243#------------------------------------------------------------ 244# 245proc ::struct::record::Create {defn_ inst_ args} { 246 247 variable _recorddefn 248 variable _count 249 variable _defn 250 variable _defaults 251 variable _level 252 253 set inst_ [Qualify "$inst_"] 254 255 ## 256 ## test to see if the record 257 ## definition has been defined yet 258 ## 259 if {![info exists _recorddefn($defn_)]} { 260 error "Structure $defn_ does not exist" 261 } 262 263 264 ## 265 ## if there was no argument given, 266 ## then assume that the record 267 ## variable is automatically 268 ## generated 269 ## 270 if {[string match "[Qualify #auto]" "$inst_"]} { 271 set c $_count($defn_) 272 set inst_ [format "%s%s" ${defn_} $_count($defn_)] 273 incr _count($defn_) 274 } 275 276 ## 277 ## Test to see if this instance is already 278 ## created. This avoids any collisions with 279 ## previously created instances 280 ## 281 if {[info exists _defn($inst_)]} { 282 incr _count($defn_) -1 283 error "Instances $inst_ already exists" 284 } 285 286 set _defn($inst_) $defn_ 287 288 ## 289 ## Initialize record variables to 290 ## defaults 291 ## 292 293 uplevel #0 [list interp alias {} ${inst_} {} ::struct::record::Cmd $inst_] 294 295 set cnt 0 296 foreach V $_recorddefn($defn_) D $_defaults($defn_) { 297 298 set [Ns $inst_]values($inst_,$V) $D 299 300 ## 301 ## Test to see if there is a nested record 302 ## 303 if {[regexp -- {([\w]*)::([\w]*)} $V m def inst]} { 304 305 if {$_level == 0} { 306 set _level 2 307 } 308 309 ## 310 ## This is to guard against if the creation 311 ## had failed, that there isn't any 312 ## lingering variables/alias around 313 ## 314 set def [Qualify $def $_level] 315 316 if {![info exists _recorddefn($def)]} { 317 318 Delete inst "$inst_" 319 320 return 321 } 322 323 ## 324 ## evaluate the nested record. If there 325 ## were values for the variables passed 326 ## in, then we assume that the value for 327 ## this nested record is a list 328 ## corresponding the the nested list's 329 ## variables, and so we pass that to 330 ## the nested record's instantiation. 331 ## We then get rid of those args for later 332 ## processing. 333 ## 334 set cnt_plus [expr {$cnt + 1}] 335 set mem [lindex $args $cnt] 336 if {![string match "" "$mem"]} { 337 if {![string match "-$inst" "$mem"]} { 338 Delete inst "$inst_" 339 error "$inst is not a member of $defn_" 340 } 341 } 342 incr _level 343 set narg [lindex $args $cnt_plus] 344 eval [linsert $narg 0 Create $def ${inst_}.${inst}] 345 set args [lreplace $args $cnt $cnt_plus] 346 347 incr _level -1 348 } else { 349 350 uplevel #0 [list interp alias {} ${inst_}.$V {} ::struct::record::Access $defn_ $inst_ $V] 351 incr cnt 2 352 } 353 354 }; # end foreach variable 355 356 lappend [Ns $inst_]instances $inst_ 357 358 foreach {k v} $args { 359 360 Access $defn_ $inst_ [string trimleft "$k" -] $v 361 362 }; # end foreach arg {} 363 364 if {$_level == 2} { 365 set _level 0 366 } 367 368 return $inst_ 369 370}; # end proc ::struct::record::Create 371 372 373#------------------------------------------------------------ 374# ::struct::record::Access -- 375# 376# Provides a common proc to access the variables 377# from the aliases create for each variable in the record 378# 379# Arguments: 380# defn_ the name of the record to access 381# inst_ the name of the instance to create 382# var_ the variable of the record to access 383# args a value to set to var_ (if any) 384# 385# Results: 386# Returns the value of the record member (var_) 387#------------------------------------------------------------ 388# 389proc ::struct::record::Access {defn_ inst_ var_ args} { 390 391 variable _recorddefn 392 variable _defn 393 394 set i [lsearch $_recorddefn($defn_) $var_] 395 396 if {$i < 0} { 397 error "$var_ does not exist in record $defn_" 398 } 399 400 if {![info exists _defn($inst_)]} { 401 402 error "$inst_ does not exist" 403 } 404 405 if {[set idx [lsearch $args "="]] >= 0} { 406 set args [lreplace $args $idx $idx] 407 } 408 409 ## 410 ## If a value was given, then set it 411 ## 412 if {[llength $args] != 0} { 413 414 set val_ [lindex $args 0] 415 416 set [Ns $inst_]values($inst_,$var_) $val_ 417 } 418 419 return [set [Ns $inst_]values($inst_,$var_)] 420 421}; # end proc ::struct::record::Access 422 423 424#------------------------------------------------------------ 425# ::struct::record::Cmd -- 426# 427# Used to process the set/get requests. 428# 429# Arguments: 430# inst_ the record instance name 431# args For 'get' this is the record members to 432# retrieve. For 'set' this is a member/value 433# pair. 434# 435# Results: 436# For 'set' returns the empty string. For 'get' it returns 437# the member values. 438#------------------------------------------------------------ 439# 440proc ::struct::record::Cmd {inst_ args} { 441 442 variable _defn 443 444 set result [list] 445 446 set len [llength $args] 447 if {$len <= 1} {return [Show values "$inst_"]} 448 449 set cmd [lindex $args 0] 450 451 if {[string match "cget" "$cmd"]} { 452 453 set cnt 0 454 foreach k [lrange $args 1 end] { 455 if {[catch {set r [${inst_}.[string trimleft ${k} -]]} err]} { 456 error "Bad option \"$k\"" 457 } 458 459 lappend result $r 460 incr cnt 461 } 462 if {$cnt == 1} {set result [lindex $result 0]} 463 return $result 464 465 } elseif {[string match "config*" "$cmd"]} { 466 467 set L [lrange $args 1 end] 468 foreach {k v} $L { 469 ${inst_}.[string trimleft ${k} -] $v 470 } 471 472 } else { 473 error "Wrong argument. 474 must be \"object cget|configure args\"" 475 } 476 477 return [list] 478 479}; # end proc ::struct::record::Cmd 480 481 482#------------------------------------------------------------ 483# ::struct::record::Ns -- 484# 485# This just constructs a fully qualified namespace for a 486# particular instance. 487# 488# Arguments; 489# inst_ instance to construct the namespace for. 490# 491# Results: 492# Returns the fully qualified namespace for the instance 493#------------------------------------------------------------ 494# 495proc ::struct::record::Ns {inst_} { 496 497 variable _defn 498 499 if {[catch {set ret $_defn($inst_)} err]} { 500 return $inst_ 501 } 502 503 return [format "%s%s%s" "::struct::record" $ret "::"] 504 505}; # end proc ::struct::record::Ns 506 507 508#------------------------------------------------------------ 509# ::struct::record::Show -- 510# 511# Display info about the record that exist 512# 513# Arguments: 514# what_ subcommand 515# record_ record or instance to process 516# 517# Results: 518# if what_ = record, then return list of records 519# definition names. 520# if what_ = members, then return list of members 521# or members of the record. 522# if what_ = instance, then return a list of instances 523# with record definition of record_ 524# if what_ = values, then it will return the values 525# for a particular instance 526#------------------------------------------------------------ 527# 528proc ::struct::record::Show {what_ {record_ ""}} { 529 530 variable _recorddefn 531 variable _defn 532 variable _defaults 533 534 ## 535 ## We just prepend :: to the record_ argument 536 ## 537 if {![string match "::*" "$record_"]} {set record_ "::$record_"} 538 539 if {[string match "record*" "$what_"]} { 540 return [lsort [array names _recorddefn]] 541 } elseif {[string match "mem*" "$what_"]} { 542 543 if {[string match "" "$record_"] || ![info exists _recorddefn($record_)]} { 544 error "Bad arguments while accessing members. Bad record name" 545 } 546 547 set res [list] 548 set cnt 0 549 foreach m $_recorddefn($record_) { 550 set def [lindex $_defaults($record_) $cnt] 551 if {[regexp -- {([\w]+)::([\w]+)} $m m d i]} { 552 lappend res [list record $d $i] 553 } elseif {![string match "" "$def"]} { 554 lappend res [list $m $def] 555 } else { 556 lappend res $m 557 } 558 559 incr cnt 560 } 561 562 return $res 563 564 } elseif {[string match "inst*" "$what_"]} { 565 566 if {![info exists ::struct::record${record_}::instances]} { 567 return [list] 568 } 569 return [lsort [set ::struct::record${record_}::instances]] 570 571 } elseif {[string match "val*" "$what_"]} { 572 573 set ns $_defn($record_) 574 575 if {[string match "" "$record_"] || ([lsearch [set [Ns $record_]instances] $record_] < 0)} { 576 577 error "Wrong arguments to values. Bad instance name" 578 } 579 580 set ret [list] 581 foreach k $_recorddefn($ns) { 582 583 set v [set [Ns $record_]values($record_,$k)] 584 585 if {[regexp -- {([\w]*)::([\w]*)} $k m def inst]} { 586 set v [::struct::record::Show values ${record_}.${inst}] 587 } 588 589 lappend ret -[namespace tail $k] $v 590 } 591 return $ret 592 593 } 594 595 return [list] 596 597}; # end proc ::struct::record::Show 598 599 600#------------------------------------------------------------ 601# ::struct::record::Delete -- 602# 603# Deletes a record instance or a record definition 604# 605# Arguments: 606# sub_ what to delete. Either 'instance' or 'record' 607# item_ the specific record instance or definition 608# delete. 609# 610# Returns: 611# none 612# 613#------------------------------------------------------------ 614# 615proc ::struct::record::Delete {sub_ item_} { 616 617 variable _recorddefn 618 variable _defn 619 variable _count 620 variable _defaults 621 622 ## 623 ## We just semi-blindly prepend :: to the record_ argument 624 ## 625 if {![string match "::*" "$item_"]} {set item_ "::$item_"} 626 627 switch -- $sub_ { 628 629 instance - 630 instances - 631 inst { 632 633 634 if {[Exists instance $item_]} { 635 636 set ns $_defn($item_) 637 foreach A [info commands ${item_}.*] { 638 Delete inst $A 639 } 640 641 catch { 642 foreach {k v} [array get [Ns $item_]values $item_,*] { 643 644 unset [Ns $item_]values($k) 645 } 646 set i [lsearch [set [Ns $item_]instances] $item_] 647 set [Ns $item_]instances [lreplace [set [Ns $item_]instances] $i $i] 648 unset _defn($item_) 649 } 650 651 # Auto-generated id numbers increase monotonically. 652 # Reverting here causes the next auto to fail, claiming 653 # that the instance exists. 654 # incr _count($ns) -1 655 656 } else { 657 #error "$item_ is not a instance" 658 } 659 } 660 record - 661 records { 662 663 664 ## 665 ## Delete the instances for this 666 ## record 667 ## 668 foreach I [Show instance "$item_"] { 669 catch {Delete instance "$I"} 670 } 671 672 catch { 673 unset _recorddefn($item_) 674 unset _defaults($item_) 675 unset _count($item_) 676 namespace delete ::struct::record${item_} 677 } 678 679 680 } 681 default { 682 error "Wrong arguments to delete" 683 } 684 685 }; # end switch 686 687 catch { uplevel #0 [list interp alias {} $item_ {}]} 688 689 return 690 691}; # end proc ::struct::record::Delete 692 693 694#------------------------------------------------------------ 695# ::struct::record::Exists -- 696# 697# Tests whether a record definition or record 698# instance exists. 699# 700# Arguments: 701# sub_ what to test. Either 'instance' or 'record' 702# item_ the specific record instance or definition 703# that needs to be tested. 704# 705# Tests to see if a particular instance exists 706# 707#------------------------------------------------------------ 708# 709proc ::struct::record::Exists {sub_ item_} { 710 711 712 switch -glob -- $sub_ { 713 inst* { 714 715 if {([lsearch ::[Ns $item_]instances $item_] >=0) || [llength [info commands ::${item_}.*]]} { 716 return 1 717 } else { 718 return 0 719 } 720 } 721 record { 722 723 set item_ "::$item_" 724 if {[info exists _recorddefn($item_)] || [llength [info commands ${item_}]]} { 725 return 1 726 } else { 727 return 0 728 } 729 } 730 default { 731 error "Wrong arguments. Must be exists record|instance target" 732 } 733 }; # end switch 734 735}; # end proc ::struct::record::Exists 736 737 738#------------------------------------------------------------ 739# ::struct::record::Qualify -- 740# 741# Contructs the qualified name of the calling scope. This 742# defaults to 2 levels since there is an extra proc call in 743# between. 744# 745# Arguments: 746# item_ the command that needs to be qualified 747# level_ how many levels to go up (default = 2) 748# 749# Results: 750# the item_ passed in fully qualified 751# 752#------------------------------------------------------------ 753# 754proc ::struct::record::Qualify {item_ {level_ 2}} { 755 756 if {![string match "::*" "$item_"]} { 757 set ns [uplevel $level_ [list namespace current]] 758 759 if {![string match "::" "$ns"]} { 760 append ns "::" 761 } 762 763 set item_ "$ns${item_}" 764 } 765 766 return "$item_" 767 768}; # end proc ::struct::record::Qualify 769 770# ### ### ### ######### ######### ######### 771## Ready 772 773namespace eval ::struct { 774 # Get 'record::record' into the general structure namespace. 775 namespace import -force record::record 776 namespace export record 777} 778package provide struct::record 1.2.1 779