source: trunk/lang/tcl/scripts/library.tcl @ 2175

Last change on this file since 2175 was 2175, checked in by gah, 13 years ago

updates to makefiles
File size: 34.3 KB
Line 
1# ----------------------------------------------------------------------
2#  COMPONENT: library - provides access to the XML library
3#
4#  These routines make it easy to load the XML description for a
5#  series of tool parameters and browse through the results.
6# ======================================================================
7#  AUTHOR:  Michael McLennan, Purdue University
8#  Copyright (c) 2004-2005  Purdue Research Foundation
9#
10#  See the file "license.terms" for information on usage and
11#  redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
12# ======================================================================
13package require tdom
14package require Itcl
15
16namespace eval Rappture {
17    variable stdlib ""
18}
19
20# load the object system along with the XML library code
21Rappture::objects::init
22
23# ----------------------------------------------------------------------
24# USAGE: library <file>
25# USAGE: library standard
26# USAGE: library isvalid <object>
27#
28# Used to open a <file> containing an XML description of tool
29# parameters.  Loads the file and returns the name of the LibraryObj
30# file that represents it.
31#
32# If you use the word "standard" in place of the file name, this
33# function returns the standard Rappture library object, which
34# contains material definitions.
35#
36# The isvalid operation checks an <object> to see if it is a valid
37# library object.  Returns 1 if so, and 0 otherwise.
38# ----------------------------------------------------------------------
39proc Rappture::library {args} {
40    # handle the isvalid operation...
41    if {[llength $args] > 1 && [lindex $args 0] == "isvalid"} {
42        if {[llength $args] != 2} {
43            error "wrong # args: should be \"library isvalid object\""
44        }
45        set obj [lindex $args 1]
46        #
47        # BE CAREFUL with the object test:
48        # The command should look like a LibraryObj formed by #auto.
49        # We want to avoid things like "split" or "set", which are
50        # valid Tcl commands but won't respond well to isa.
51        #
52        if {[regexp {libraryObj[0-9]+$} $obj]
53              && [catch {$obj isa ::Rappture::LibraryObj} valid] == 0
54              && $valid} {
55            return 1
56        }
57        return 0
58    }
59
60    if {[llength $args] != 1} {
61        error "wrong # args: should be \"library file\" or \"library isvalid object\""
62    }
63    set fname [lindex $args 0]
64
65    if {$fname == "standard"} {
66        variable stdlib
67        if {$stdlib != ""} {
68            return $stdlib
69        }
70        set fname [file join $Rappture::installdir lib library.xml]
71
72        set fid [::open $fname r]
73        set info [read $fid]
74        close $fid
75
76        set stdlib [Rappture::LibraryObj ::#auto $info]
77        return $stdlib
78    }
79
80    if {[regexp {^<\?[Xx][Mm][Ll]} $fname]} {
81        set info $fname
82    } else {
83        # otherwise, try to open the file and create its LibraryObj
84        set fid [::open $fname r]
85        set info [read $fid]
86        close $fid
87    }
88
89    set obj [Rappture::LibraryObj ::#auto $info]
90    return $obj
91}
92
93# ----------------------------------------------------------------------
94# USAGE: entities ?-as <fval>? <object> <path>
95#
96# Used to sift through an XML <object> for "entities" within the
97# Rappture description.  Entities are things like strings, numbers,
98# etc., which show up in the GUI as controls.
99#
100# Returns a list of all entities found beneath <path>.
101#
102# By default, this method returns the component name "type(id)".
103# This is changed by setting the -as argument to "id" (for name
104# of the tail element), to "type" (for the type of the tail element),
105# to "object" (for an object representing the DOM node referenced by
106# the path.
107# ----------------------------------------------------------------------
108proc Rappture::entities {args} {
109    array set params {
110        -as component
111    }
112    while {[llength $args] > 1} {
113        set first [lindex $args 0]
114        if {[string index $first 0] == "-"} {
115            set choices [array names params]
116            if {[lsearch $choices $first] < 0} {
117                error "bad option \"$first\": should be [join [lsort $choices] {, }]"
118            }
119            set params($first) [lindex $args 1]
120            set args [lrange $args 2 end]
121        } else {
122            break
123        }
124    }
125    if {[llength $args] > 2} {
126        error "wrong # args: should be \"entities ?-as fval? obj ?path?\""
127    }
128    set xmlobj [lindex $args 0]
129    set path [lindex $args 1]
130
131    set rlist ""
132    lappend queue $path
133    while {[llength $queue] > 0} {
134        set path [lindex $queue 0]
135        set queue [lrange $queue 1 end]
136
137        foreach cpath [$xmlobj children -as path $path] {
138            set type [$xmlobj element -as type $cpath]
139            switch -- $type {
140                group - phase {
141                    lappend queue $cpath
142                }
143                structure {
144                    # add this to the return list with the right flavor
145                    if {$params(-as) == "component"} {
146                        lappend rlist $cpath
147                    } else {
148                        lappend rlist [$xmlobj element -as $params(-as) $cpath]
149                    }
150
151                    if {[$xmlobj element $cpath.current.parameters] != ""} {
152                        lappend queue $cpath.current.parameters
153                    }
154                }
155                drawing {
156                    # add this to the return list with the right flavor
157                    if {$params(-as) == "component"} {
158                        lappend rlist $cpath
159                    } else {
160                        lappend rlist [$xmlobj element -as $params(-as) $cpath]
161                    }
162
163                    foreach child [$xmlobj children $cpath.current] {
164                        if {[string match about* $child]} {
165                            continue
166                        }
167                        if {[$xmlobj element $cpath.current.$child.parameters] != ""} {
168                            lappend queue $cpath.current.$child.parameters
169                        }
170                    }
171                }
172                default {
173                    if {[catch {Rappture::objects::get $type}] == 0} {
174                        # add this to the return list with the right flavor
175                        if {$params(-as) == "component"} {
176                            lappend rlist $cpath
177                        } else {
178                            lappend rlist [$xmlobj element -as $params(-as) $cpath]
179                        }
180                    }
181
182                    # if this element has embedded groups, add them to the queue
183                    foreach ccpath [$xmlobj children -as path $cpath] {
184                        set cctype [$xmlobj element -as type $ccpath]
185                        if {$cctype == "group" || $cctype == "phase"} {
186                            lappend queue $ccpath
187                        }
188                    }
189                }
190            }
191        }
192    }
193    return $rlist
194}
195
196# ----------------------------------------------------------------------
197itcl::class Rappture::LibraryObj {
198    constructor {info} { # defined below }
199    destructor { # defined below }
200
201    public method element {args}
202    public method parent {args}
203    public method children {args}
204    public method get {args}
205    public method put {args}
206    public method copy {path from args}
207    public method remove {{path ""}}
208    public method xml {{path ""}}
209
210    public method diff {libobj}
211    public proc value {libobj path}
212
213    public proc path2list {path}
214    protected method find {path}
215    protected method node2name {node}
216    protected method node2comp {node}
217    protected method node2path {node}
218    protected method childnodes {node type}
219
220    private variable _root 0       ;# non-zero => this obj owns document
221    private variable _document ""  ;# XML DOM tree
222    private variable _node ""      ;# node within
223}
224
225# ----------------------------------------------------------------------
226# CONSTRUCTOR
227# ----------------------------------------------------------------------
228itcl::body Rappture::LibraryObj::constructor {info} {
229    if {[regexp {<?[Xx][Mm][Ll]} $info]} {
230        set _root 1
231        set _document [dom parse $info]
232        set _node [$_document documentElement]
233    } elseif {[regexp {^domNode} $info]} {
234        set _root 0
235        set _document [$info ownerDocument]
236        set _node $info
237    } else {
238        error "bad info: should be XML text or DOM node"
239    }
240}
241
242# ----------------------------------------------------------------------
243# DESTRUCTOR
244# ----------------------------------------------------------------------
245itcl::body Rappture::LibraryObj::destructor {} {
246    if {$_root && $_document != ""} {
247        $_document delete
248    }
249}
250
251# ----------------------------------------------------------------------
252# USAGE: element ?-as <fval>? ?<path>?
253#
254# Clients use this to query a particular element within the entire
255# data structure.  The path is a string of the form
256# "structure.box(source).corner".  This example represents the tag
257# <corner> within a tag <box id="source"> within a tag <structure>,
258# which must be found at the top level within this document.
259#
260# By default, this method returns the component name "type(id)".
261# This is changed by setting the -as argument to "id" (for name
262# of the tail element), to "type" (for the type of the tail element),
263# to "object" (for an object representing the DOM node referenced by
264# the path).
265# ----------------------------------------------------------------------
266itcl::body Rappture::LibraryObj::element {args} {
267    array set params {
268        -as component
269    }
270    while {[llength $args] > 1} {
271        set first [lindex $args 0]
272        if {[string index $first 0] == "-"} {
273            set choices [array names params]
274            if {[lsearch $choices $first] < 0} {
275                error "bad option \"$first\": should be [join [lsort $choices] {, }]"
276            }
277            set params($first) [lindex $args 1]
278            set args [lrange $args 2 end]
279        } else {
280            break
281        }
282    }
283    if {[llength $args] > 1} {
284        error "wrong # args: should be \"element ?-as fval? ?path?\""
285    }
286    set path [lindex $args 0]
287
288    set node [find $path]
289    if {$node == ""} {
290        return ""
291    }
292
293    switch -- $params(-as) {
294      object {
295          return [::Rappture::LibraryObj ::#auto $node]
296      }
297      component {
298          return [node2comp $node]
299      }
300      id {
301          return [node2name $node]
302      }
303      path {
304          return [node2path $node]
305      }
306      type {
307          return [$node nodeName]
308      }
309      default {
310          error "bad flavor \"$params(-as)\": should be component, id, object, path, type"
311      }
312    }
313}
314
315# ----------------------------------------------------------------------
316# USAGE: parent ?-as <fval>? ?<path>?
317#
318# Clients use this to query the parent of a particular element.
319# This is just like the "element" method, but it returns the parent
320# of the element instead of the element itself.
321#
322# By default, this method returns a list of component names "type(id)".
323# This is changed by setting the -as argument to "id" (for tail
324# names of all children), to "type" (for the types of all children),
325# to "object" (for a list of objects representing the DOM nodes for
326# all children).
327# ----------------------------------------------------------------------
328itcl::body Rappture::LibraryObj::parent {args} {
329    array set params {
330        -as component
331    }
332    while {[llength $args] > 1} {
333        set first [lindex $args 0]
334        if {[string index $first 0] == "-"} {
335            set choices [array names params]
336            if {[lsearch $choices $first] < 0} {
337                error "bad option \"$first\": should be [join [lsort $choices] {, }]"
338            }
339            set params($first) [lindex $args 1]
340            set args [lrange $args 2 end]
341        } else {
342            break
343        }
344    }
345    if {[llength $args] > 1} {
346        error "wrong # args: should be \"parent ?-as fval? ?path?\""
347    }
348    set path [lindex $args 0]
349
350    set node [find $path]
351    if {$node == ""} {
352        return ""
353    }
354    set node [$node parentNode]
355    if {$node == ""} {
356        return ""
357    }
358
359    switch -- $params(-as) {
360      object {
361          return [::Rappture::LibraryObj ::#auto $node]
362      }
363      component {
364          return [node2comp $node]
365      }
366      id {
367          return [node2name $node]
368      }
369      path {
370          return [node2path $node]
371      }
372      type {
373          return [$node nodeName]
374      }
375      default {
376          error "bad flavor \"$params(-as)\": should be component, id, object, path, type"
377      }
378    }
379}
380
381# ----------------------------------------------------------------------
382# USAGE: children ?-as <fval>? ?-type <name>? ?<path>?
383#
384# Clients use this to query the children of a particular element
385# within the entire data structure.  This is just like the "element"
386# method, but it returns the children of the element instead of the
387# element itself.  If the optional -type argument is specified, then
388# the return list is restricted to children of the specified type.
389#
390# By default, this method returns a list of component names "type(id)".
391# This is changed by setting the -as argument to "id" (for tail
392# names of all children), to "type" (for the types of all children),
393# to "object" (for a list of objects representing the DOM nodes for
394# all children).
395# ----------------------------------------------------------------------
396itcl::body Rappture::LibraryObj::children {args} {
397    array set params {
398        -as component
399        -type ""
400    }
401    while {[llength $args] > 1} {
402        set first [lindex $args 0]
403        if {[string index $first 0] == "-"} {
404            set choices [array names params]
405            if {[lsearch $choices $first] < 0} {
406                error "bad option \"$first\": should be [join [lsort $choices] {, }]"
407            }
408            set params($first) [lindex $args 1]
409            set args [lrange $args 2 end]
410        } else {
411            break
412        }
413    }
414    if {[llength $args] > 1} {
415        error "wrong # args: should be \"children ?-as fval? ?-type name? ?path?\""
416    }
417    set path [lindex $args 0]
418    set node [find $path]
419    if {$node == ""} {
420        return ""
421    }
422
423    set nlist ""
424    foreach n [$node childNodes] {
425        set type [$n nodeName]
426        if {[regexp {^#} $type]} {
427            continue
428        }
429        if {$params(-type) != "" && $params(-type) != $type} {
430            continue
431        }
432        lappend nlist $n
433    }
434
435    set rlist ""
436    switch -- $params(-as) {
437      object {
438          foreach n $nlist {
439              lappend rlist [::Rappture::LibraryObj ::#auto $n]
440          }
441      }
442      component {
443          foreach n $nlist {
444              lappend rlist [node2comp $n]
445          }
446      }
447      id {
448          foreach n $nlist {
449              lappend rlist [node2name $n]
450          }
451      }
452      path {
453          foreach n $nlist {
454              lappend rlist [node2path $n]
455          }
456      }
457      type {
458          foreach n $nlist {
459              lappend rlist [$n nodeName]
460          }
461      }
462      default {
463          error "bad flavor \"$params(-as)\": should be component, id, object, path, type"
464      }
465    }
466    return $rlist
467}
468
469# ----------------------------------------------------------------------
470# USAGE: get ?-decode yes? ?<path>?
471#
472# Clients use this to query the value of a node. Clients can specify
473# if they want the data to be automatically decoded or no using the
474# -decode flag. This is useful for situations where you want to keep
475# the data encoded to pass to another system, like dx data in fields
476# sending data to nanovis. If the path is not
477# specified, it returns the value associated with the root node.
478# Otherwise, it returns the value for the element specified by the
479# path.
480# ----------------------------------------------------------------------
481itcl::body Rappture::LibraryObj::get {args} {
482    array set params {
483        -decode yes
484    }
485    while {[llength $args] > 0} {
486        set first [lindex $args 0]
487        if {[string index $first 0] == "-"} {
488            set choices [array names params]
489            if {[lsearch $choices $first] < 0} {
490                error "bad option \"$first\": should be [join [lsort $choices] {, }]"
491            }
492            set params($first) [lindex $args 1]
493            set args [lrange $args 2 end]
494        } else {
495            break
496        }
497    }
498    if {[llength $args] > 1} {
499        error "wrong # args: should be \"get ?-decode yes? ?path?\""
500    }
501    if {[llength $args] == 1} {
502        set path [lindex $args 0]
503    } else {
504        set path ""
505    }
506
507    set node [find $path]
508    if {$node == ""} {
509        return ""
510    }
511    # Expat (via tDOM) will always produce utf-8 output, regardless of the
512    # encoding of the tool.xml.  We need to convert utf-8 to unicode for
513    # Tcl/Tk.  This shouldn't affect ASCII tool.xml files.
514    set string [encoding convertfrom utf-8 [$node text]]
515    if {$params(-decode) == "yes"} {
516        set string [Rappture::encoding::decode -- $string]
517    }
518    return [string trim $string]
519}
520
521# ----------------------------------------------------------------------
522# USAGE: put ?-append yes? ?-id num? ?-type string|file? ?-compress no? ?<path>? <string>
523#
524# Clients use this to set the value of a node.  If the path is not
525# specified, it sets the value for the root node.  Otherwise, it sets
526# the value for the element specified by the path.  If the value is a
527# string, then it is treated as the text within the tag at the tail
528# of the path.  If it is a DOM node or a library, then it is inserted
529# into the tree at the specified path.
530#
531# If the optional id is specified, then it sets the identifier for
532# the tag at the tail of the path.  If the optional append flag is
533# specified, then the value is appended to the current value.
534# Otherwise, the value replaces the current value.
535# ----------------------------------------------------------------------
536itcl::body Rappture::LibraryObj::put {args} {
537    array set params {
538        -id ""
539        -append no
540        -type string
541        -compress no
542    }
543    while {[llength $args] > 1} {
544        set first [lindex $args 0]
545        if {[string index $first 0] == "-"} {
546            set choices [array names params]
547            if {[lsearch $choices $first] < 0} {
548                error "bad option \"$first\": should be [join [lsort $choices] {, }]"
549            }
550            set params($first) [lindex $args 1]
551            set args [lrange $args 2 end]
552        } else {
553            break
554        }
555    }
556    if {[llength $args] < 1 || [llength $args] > 2} {
557        error "wrong # args: should be \"put ?-append bval? ?-id num? ?-type string|file? ?-compress bval? ?path? string\""
558    }
559    if {[llength $args] == 2} {
560        set path [lindex $args 0]
561        set str [lindex $args 1]
562    } else {
563        set path ""
564        set str [lindex $args 0]
565    }
566
567    if {$params(-type) == "file"} {
568        set fileName $str
569        set fid [open $fileName r]
570        fconfigure $fid -translation binary -encoding binary
571        set str [read $fid]
572        close $fid
573    }
574
575    if {$params(-compress) || [Rappture::encoding::is binary $str]} {
576        set str [Rappture::encoding::encode -- $str]
577    }
578
579    set node [find -create $path]
580
581    #
582    # Clean up any nodes that don't belong.  If we're appending
583    # the value, then clean up only child <tag> nodes.  Otherwise,
584    # clean up all nodes.
585    #
586    set nlist ""
587    if {$params(-append)} {
588        foreach n [$node childNodes] {
589            if {[$n nodeType] != "TEXT_NODE"} {
590                lappend nlist $n
591            }
592        }
593    } else {
594        set nlist [$node childNodes]
595    }
596    foreach n $nlist {
597        $n delete
598    }
599
600    if {[Rappture::library isvalid $str]} {
601        foreach n [[$str info variable _node -value] childNodes] {
602            $node appendXML [$n asXML]
603        }
604    } else {
605        set n [$_document createText $str]
606        $node appendChild $n
607        if {"" != $params(-id)} {
608            $node setAttribute id $params(-id)
609        }
610    }
611    return ""
612}
613
614# ----------------------------------------------------------------------
615# USAGE: copy <path> from ?<xmlobj>? <path>
616#
617# Clients use this to copy the value from one xmlobj/path to another.
618# If the <xmlobj> is not specified, it is assumed to be the same as
619# the current object.
620# ----------------------------------------------------------------------
621itcl::body Rappture::LibraryObj::copy {path from args} {
622    if {[llength $args] == 1} {
623        set xmlobj $this
624        set fpath [lindex $args 0]
625    } elseif {[llength $args] == 2} {
626        set xmlobj [lindex $args 0]
627        set fpath [lindex $args 1]
628    } else {
629        error "wrong # args: should be \"copy path from ?xmlobj? path\""
630    }
631    if {$from != "from"} {
632        error "bad syntax: should be \"copy path from ?xmlobj? path\""
633    }
634
635    if {[llength [$xmlobj children $fpath]] == 0} {
636        set val [$xmlobj get $fpath]
637        put $path $val
638    } else {
639        set obj [$xmlobj element -as object $fpath]
640        put $path $obj
641        itcl::delete object $obj
642    }
643}
644
645# ----------------------------------------------------------------------
646# USAGE: remove ?<path>?
647#
648# Clients use this to remove the specified node.  Removes the node
649# from the tree.
650# ----------------------------------------------------------------------
651itcl::body Rappture::LibraryObj::remove {{path ""}} {
652    set node [find $path]
653    if {$node != ""} {
654        $node delete
655    }
656}
657
658# ----------------------------------------------------------------------
659# USAGE: xml ?<path>?
660#
661# Returns a string representing the XML information for the information
662# in this library.
663# ----------------------------------------------------------------------
664itcl::body Rappture::LibraryObj::xml {{path ""}} {
665    if {"" != $path} {
666        set n [find $path]
667    } else {
668        set n $_node
669    }
670    return [$n asXML]
671}
672
673# ----------------------------------------------------------------------
674# USAGE: diff <libobj>
675#
676# Compares the entities in this object to those in another and
677# returns a list of differences.  The result is a list of the form:
678# {op1 path1 oldval1 newval1 ...} where each "op" is +/-/c for
679# added/subtracted/changed, "path" is the path within the library
680# that is different, and "oldval"/"newval" give the values for the
681# object at the path.
682# ----------------------------------------------------------------------
683itcl::body Rappture::LibraryObj::diff {libobj} {
684    set rlist ""
685
686    # query the values for all entities in both objects
687    set thisv [Rappture::entities $this input]
688    set otherv [Rappture::entities $libobj input]
689
690    # scan through values for this object, and compare against other one
691    foreach path $thisv {
692        set i [lsearch -exact $otherv $path]
693        if {$i < 0} {
694            foreach {raw norm} [value $this $path] break
695            lappend rlist - $path $raw ""
696        } else {
697            foreach {traw tnorm} [value $this $path] break
698            foreach {oraw onorm} [value $libobj $path] break
699            if {![string equal $tnorm $onorm]} {
700                lappend rlist c $path $traw $oraw
701            }
702            set otherv [lreplace $otherv $i $i]
703        }
704    }
705
706    # add any values left over in the other object
707    foreach path $otherv {
708        foreach {oraw onorm} [value $libobj $path] break
709        lappend rlist + $path "" $oraw
710    }
711    return $rlist
712}
713
714# ----------------------------------------------------------------------
715# USAGE: value <object> <path>
716#
717# Used to query the "value" associated with the <path> in an XML
718# <object>.  This is a little more complicated than the object's
719# "get" method.  It handles things like structures and values
720# with normalized units.
721#
722# Returns a list of two items:  {raw norm} where "raw" is the raw
723# value from the "get" method and "norm" is the normalized value
724# produced by this routine.  Example:  {300K 300}
725#
726# Right now, it is a handy little utility used by the "diff" method.
727# Eventually, it should be moved to a better object-oriented
728# implementation, where each Rappture type could overload the
729# various bits of processing below.  So we leave it as a "proc"
730# now instead of a method, since it should be deprecated soon.
731# ----------------------------------------------------------------------
732itcl::body Rappture::LibraryObj::value {libobj path} {
733    switch -- [$libobj element -as type $path] {
734        structure {
735            set raw $path
736            # try to find a label to represent the structure
737            set val [$libobj get $path.about.label]
738            if {"" == $val} {
739                set val [$libobj get $path.current.about.label]
740            }
741            if {"" == $val} {
742                if {[$libobj element $path.current] != ""} {
743                    set comps [$libobj children $path.current.components]
744                    set val "<structure> with [llength $comps] components"
745                } else {
746                    set val "<structure>"
747                }
748            }
749            return [list $raw $val]
750        }
751        number {
752            # get the usual value...
753            set raw ""
754            set val ""
755            if {"" != [$libobj element $path.current]} {
756                set raw [$libobj get $path.current]
757            } elseif {"" != [$libobj element $path.default]} {
758                set raw [$libobj get $path.default]
759            }
760            if {"" != $raw} {
761                set val $raw
762                # then normalize to default units
763                set units [$libobj get $path.units]
764                if {"" != $units} {
765                    set val [Rappture::Units::convert $val \
766                        -context $units -to $units -units off]
767                }
768            }
769            return [list $raw $val]
770        }
771    }
772
773    # for all other types, get the value (current, or maybe default)
774    set raw ""
775    if {"" != [$libobj element $path.current]} {
776        set raw [$libobj get $path.current]
777    } elseif {"" != [$libobj element $path.default]} {
778        set raw [$libobj get $path.default]
779    }
780    return [list $raw $raw]
781}
782
783# ----------------------------------------------------------------------
784# USAGE: find ?-create? <path>
785#
786# Used internally to find a particular element within the root node
787# according to the path, which is a string of the form
788# "typeNN(id).typeNN(id). ...", where each "type" is a tag <type>;
789# if the optional NN is specified, it indicates an index for the
790# <type> tag within its parent; if the optional (id) part is included,
791# it indicates a tag of the form <type id="id">.
792#
793# By default, it looks for an element along the path and returns None
794# if not found.  If the create flag is set, it creates various elements
795# along the path as it goes.  This is useful for "put" operations.
796#
797# If you include "#" instead of a specific number, a node will be
798# created automatically with a new number.  For example, the path
799# "foo.bar#" called the first time will create "foo.bar", the second
800# time "foo.bar1", the third time "foo.bar2" and so forth.
801#
802# Returns an object representing the element indicated by the path,
803# or "" if the path is not found.
804# ----------------------------------------------------------------------
805itcl::body Rappture::LibraryObj::find {args} {
806    set create 0
807    while {[llength $args] > 1} {
808        set first [lindex $args 0]
809        set args [lrange $args 1 end]
810        if {$first == "-create"} {
811            set create 1
812        } else {
813            error "bad option \"$first\": should be -create"
814        }
815    }
816    if {[llength $args] != 1} {
817        error "wrong # args: should be \"find ?-create? path\""
818    }
819    set path [lindex $args 0]
820
821    if {$path == ""} {
822        return $_node
823    }
824    set path [path2list $path]
825
826    #
827    # Follow the given path and look for all of the parts.
828    #
829    set lastnode $_node
830    set node $lastnode
831    foreach part $path {
832        if {![regexp {^(([a-zA-Z0-9_]*[a-zA-Z_]+#?)([0-9]*))?(\((.*)\))?$} $part \
833               match dummy type index dummy name]} {
834            error "bad path component \"$part\""
835        }
836        #
837        # If the name is like "type2", then look for elements with
838        # the type name and return the one with the given index.
839        # If the name is like "type", then assume the index is 0.
840        #
841        if {$name == ""} {
842            if {$index == ""} {
843                set index 0
844            }
845            set nlist [childnodes $node $type]
846            set node [lindex $nlist $index]
847        } else {
848            #
849            # If the name is like "type(id)", then look for elements
850            # that match the type and see if one has the requested name.
851            # if the name is like "(id)", then look for any elements
852            # with the requested name.
853            #
854            if {$type != ""} {
855                set nlist [childnodes $node $type]
856            } else {
857                set nlist [$node childNodes]
858            }
859            set found 0
860            foreach n $nlist {
861                if {[catch {$n getAttribute id} tag]} { set tag "" }
862                if {$tag == $name} {
863                    set found 1
864                    break
865                }
866            }
867            set node [expr {($found) ? $n : ""}]
868        }
869
870        if {$node == ""} {
871            if {!$create} {
872                return ""
873            }
874
875            #
876            # If the "create" flag is set, then create a node
877            # with the specified "type(id)" and continue on.
878            # If the type is "type#", then create a node with
879            # an automatic number.
880            #
881            if {![regexp {^([^\(]+)\(([^\)]+)\)$} $part match type name]} {
882                set type $part
883                set name ""
884            }
885
886            if {[string match *# $type]} {
887                set type [string trimright $type #]
888                set node [$_document createElement $type]
889
890                # find the last node of same type and append there
891                set pos ""
892                foreach n [$lastnode childNodes] {
893                    if {[$n nodeName] == $type} {
894                        set pos $n
895                    }
896                }
897                if {$pos != ""} {
898                    set pos [$pos nextSibling]
899                }
900                if {$pos != ""} {
901                    $lastnode insertBefore $node $pos
902                } else {
903                    $lastnode appendChild $node
904                }
905            } else {
906                set node [$_document createElement $type]
907                $lastnode appendChild $node
908            }
909            if {"" != $name} {
910                $node setAttribute id $name
911            }
912        }
913        set lastnode $node
914    }
915    return $node
916}
917
918# ----------------------------------------------------------------------
919# USAGE: path2list <path>
920#
921# Converts a path of the form "foo(a).bar.baz" into a list of the
922# form "foo(a) bar baz".  This is a little more complicated than
923# splitting on the .'s, since the stuff in ()'s might have embedded
924# .'s.  Returns a proper Tcl list for all elements of the path.
925# ----------------------------------------------------------------------
926itcl::body Rappture::LibraryObj::path2list {path} {
927    #
928    # Normally, we just split on .'s within the path.  But there
929    # might be some .'s embedded within ()'s in the path.  Change
930    # any embedded .'s to an out-of-band character, then split on
931    # the .'s, and change the embedded .'s back.
932    #
933    if {[regexp {(\([^\)]*)\.([^\)]*\))} $path]} {
934        while {[regsub -all {(\([^\)]*)\.([^\)]*\))} $path "\\1\007\\2" path]} {
935            # keep fixing...
936        }
937    }
938    set path [split $path .]
939    regsub -all {\007} $path {.} path
940
941    return $path
942}
943
944# ----------------------------------------------------------------------
945# USAGE: node2name <node>
946#
947# Used internally to create a name for the specified node.  If the
948# node doesn't have a specific name ("id" attribute) then a name of
949# the form "type123" is constructed.
950# ----------------------------------------------------------------------
951itcl::body Rappture::LibraryObj::node2name {node} {
952    if {[catch {$node getAttribute id} name]} { set name "" }
953    if {$name == ""} {
954        set pnode [$node parentNode]
955        if {$pnode == ""} {
956            return ""
957        }
958        set type [$node nodeName]
959        set siblings [childnodes $pnode $type]
960        set index [lsearch $siblings $node]
961        if {$index == 0} {
962            set name $type
963        } else {
964            set name "$type$index"
965        }
966    }
967    return $name
968}
969
970# ----------------------------------------------------------------------
971# USAGE: node2comp <node>
972#
973# Used internally to create a path component name for the specified
974# node.  A path component name has the form "type(id)" or just
975# "type##" if the node doesn't have a name.  This name can be used
976# in a path to uniquely address the component.
977# ----------------------------------------------------------------------
978itcl::body Rappture::LibraryObj::node2comp {node} {
979    set type [$node nodeName]
980    if {[catch {$node getAttribute id} name]} { set name "" }
981    if {$name == ""} {
982        set pnode [$node parentNode]
983        if {$pnode == ""} {
984            return ""
985        }
986        set siblings [childnodes $pnode $type]
987        set index [lsearch $siblings $node]
988        if {$index == 0} {
989            set name $type
990        } else {
991            set name "$type$index"
992        }
993    } else {
994        set name "${type}($name)"
995    }
996    return $name
997}
998
999# ----------------------------------------------------------------------
1000# USAGE: node2path <node>
1001#
1002# Used internally to create a full path name for the specified node.
1003# The path is relative to the current object, so it stops when the
1004# parent is the root node for this object.
1005# ----------------------------------------------------------------------
1006itcl::body Rappture::LibraryObj::node2path {node} {
1007    set path [node2comp $node]
1008    set node [$node parentNode]
1009    while {$node != "" && $node != $_node} {
1010        set path "[node2comp $node].$path"
1011        set node [$node parentNode]
1012    }
1013    return $path
1014}
1015
1016# ----------------------------------------------------------------------
1017# USAGE: childnodes <node> <type>
1018#
1019# Used internally to return a list of children for the given <node>
1020# that match a specified <type>.  Similar to XML getElementsByTagName,
1021# but returns only direct children of the <node>.
1022# ----------------------------------------------------------------------
1023itcl::body Rappture::LibraryObj::childnodes {node type} {
1024    set rlist ""
1025    foreach cnode [$node childNodes] {
1026        if {[$cnode nodeName] == $type} {
1027            lappend rlist $cnode
1028        }
1029    }
1030    return $rlist
1031}
Note: See TracBrowser for help on using the repository browser.