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