source: trunk/tcl/scripts/library.tcl @ 9

Last change on this file since 9 was 9, checked in by mmc, 16 years ago

Massive changes across the entire toolkit. Rearranged the
XML description to agree better with new documentation and
conventions.

Added a small start of Rappture.interface and Rappture.number
in the python directory. This is the new way of doing Rappture--
by declaring variables directly in the program, not using XML
directly at all.

File size: 19.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  Purdue Research Foundation, West Lafayette, IN
9# ======================================================================
10package require tdom
11package require Itcl
12
13namespace eval Rappture { # forward declaration }
14
15# ----------------------------------------------------------------------
16# USAGE: library ?-std? <file>
17# USAGE: library isvalid <object>
18#
19# Used to open a <file> containing an XML description of tool
20# parameters.  Loads the file and returns the name of the LibraryObj
21# file that represents it.
22#
23# If the -std flag is included, then the file is treated as the
24# name of a standard file, which is part of the Rappture installation.
25#
26# The isvalid operation checks an <object> to see if it is a valid
27# library object.  Returns 1 if so, and 0 otherwise.
28# ----------------------------------------------------------------------
29proc Rappture::library {args} {
30    # handle the isvalid operation...
31    if {[llength $args] > 1 && [lindex $args 0] == "isvalid"} {
32        if {[llength $args] != 2} {
33            error "wrong # args: should be \"library isvalid object\""
34        }
35        set obj [lindex $args 1]
36        if {[catch {$obj isa ::Rappture::LibraryObj} valid] == 0 && $valid} {
37            return 1
38        }
39        return 0
40    }
41
42    # handle the open operation...
43    set stdfile 0
44    while {[llength $args] > 1} {
45        set switch [lindex $args 0]
46        set args [lrange $args 1 end]
47        if {$switch == "-std"} {
48            set stdfile 1
49        } else {
50            error "bad option \"$switch\": should be -std"
51        }
52    }
53    set fname [lindex $args 0]
54
55    if {$stdfile && [file pathtype $fname] != "absolute"} {
56        set fname [file join $Rappture::installdir lib $fname]
57    }
58
59    if {[regexp {^<\?[Xx][Mm][Ll]} $fname]} {
60        set info $fname
61    } else {
62        # otherwise, try to open the file and create its LibraryObj
63        set fid [::open $fname r]
64        set info [read $fid]
65        close $fid
66    }
67
68    set obj [Rappture::LibraryObj ::#auto $info]
69    return $obj
70}
71
72# ----------------------------------------------------------------------
73itcl::class Rappture::LibraryObj {
74    constructor {info} { # defined below }
75    destructor { # defined below }
76
77    public method element {args}
78    public method children {args}
79    public method get {{path ""}}
80    public method put {args}
81    public method remove {{path ""}}
82    public method xml {}
83
84    protected method find {path}
85    protected method path2list {path}
86    protected method node2name {node}
87    protected method node2comp {node}
88
89    private variable _root 0       ;# non-zero => this obj owns document
90    private variable _document ""  ;# XML DOM tree
91    private variable _node ""      ;# node within
92}
93
94# ----------------------------------------------------------------------
95# CONSTRUCTOR
96# ----------------------------------------------------------------------
97itcl::body Rappture::LibraryObj::constructor {info} {
98    if {[regexp {<?[Xx][Mm][Ll]} $info]} {
99        set _root 1
100        set _document [dom parse $info]
101        set _node [$_document documentElement]
102    } elseif {[regexp {^domNode} $info]} {
103        set _root 0
104        set _document [$info ownerDocument]
105        set _node $info
106    } else {
107        error "bad info: should be XML text or DOM node"
108    }
109}
110
111# ----------------------------------------------------------------------
112# DESTRUCTOR
113# ----------------------------------------------------------------------
114itcl::body Rappture::LibraryObj::destructor {} {
115    if {$_root && $_document != ""} {
116        $_document delete
117    }
118}
119
120# ----------------------------------------------------------------------
121# USAGE: element ?-flavor <fval>? ?<path>?
122#
123# Clients use this to query a particular element within the entire
124# data structure.  The path is a string of the form
125# "structure.box(source).corner".  This example represents the tag
126# <corner> within a tag <box id="source"> within a tag <structure>,
127# which must be found at the top level within this document.
128#
129# By default, this method returns the component name "type(id)".
130# This is changed by setting the -flavor argument to "id" (for name
131# of the tail element), to "type" (for the type of the tail element),
132# to "object" (for an object representing the DOM node referenced by
133# the path.
134# ----------------------------------------------------------------------
135itcl::body Rappture::LibraryObj::element {args} {
136    array set params {
137        -flavor component
138    }
139    while {[llength $args] > 1} {
140        set first [lindex $args 0]
141        if {[string index $first 0] == "-"} {
142            set choices [array names params]
143            if {[lsearch $choices $first] < 0} {
144                error "bad option \"$first\": should be [join [lsort $choices] {, }]"
145            }
146            set params($first) [lindex $args 1]
147            set args [lrange $args 2 end]
148        } else {
149            break
150        }
151    }
152    if {[llength $args] > 1} {
153        error "wrong # args: should be \"element ?-flavor fval? ?path?\""
154    }
155    set path [lindex $args 0]
156
157    set node [find $path]
158    if {$node == ""} {
159        return ""
160    }
161
162    switch -- $params(-flavor) {
163      object {
164          return [::Rappture::LibraryObj ::#auto $node]
165      }
166      component {
167          return [node2comp $node]
168      }
169      id {
170          return [node2name $node]
171      }
172      type {
173          return [$node nodeName]
174      }
175      default {
176          error "bad flavor \"$params(-flavor)\": should be object, id, type, component"
177      }
178    }
179}
180
181# ----------------------------------------------------------------------
182# USAGE: children ?-flavor <fval>? ?-type <name>? ?<path>?
183#
184# Clients use this to query the children of a particular element
185# within the entire data structure.  This is just like the "element"
186# method, but it returns the children of the element instead of the
187# element itself.  If the optional -type argument is specified, then
188# the return list is restricted to children of the specified type.
189#
190# By default, this method returns a list of component names "type(id)".
191# This is changed by setting the -flavor argument to "id" (for tail
192# names of all children), to "type" (for the types of all children),
193# to "object" (for a list of objects representing the DOM nodes for
194# all children).
195# ----------------------------------------------------------------------
196itcl::body Rappture::LibraryObj::children {args} {
197    array set params {
198        -flavor component
199        -type ""
200    }
201    while {[llength $args] > 1} {
202        set first [lindex $args 0]
203        if {[string index $first 0] == "-"} {
204            set choices [array names params]
205            if {[lsearch $choices $first] < 0} {
206                error "bad option \"$first\": should be [join [lsort $choices] {, }]"
207            }
208            set params($first) [lindex $args 1]
209            set args [lrange $args 2 end]
210        } else {
211            break
212        }
213    }
214    if {[llength $args] > 1} {
215        error "wrong # args: should be \"children ?-flavor fval? ?-type name? ?path?\""
216    }
217    set path [lindex $args 0]
218
219    set node [find $path]
220    if {$node == ""} {
221        return ""
222    }
223
224    set nlist ""
225    foreach n [$node childNodes] {
226        set type [$n nodeName]
227        if {[regexp {^#} $type]} {
228            continue
229        }
230        if {$params(-type) != "" && $params(-type) != $type} {
231            continue
232        }
233        lappend nlist $n
234    }
235
236    set rlist ""
237    switch -- $params(-flavor) {
238      object {
239          foreach n $nlist {
240              lappend rlist [::Rappture::LibraryObj ::#auto $n]
241          }
242      }
243      component {
244          foreach n $nlist {
245              lappend rlist [node2comp $n]
246          }
247      }
248      id {
249          foreach n $nlist {
250              lappend rlist [node2name $n]
251          }
252      }
253      type {
254          foreach n $nlist {
255              lappend rlist [$n nodeName]
256          }
257      }
258      default {
259          error "bad flavor \"$params(-flavor)\": should be object, id, type, component"
260      }
261    }
262    return $rlist
263}
264
265# ----------------------------------------------------------------------
266# USAGE: get ?<path>?
267#
268# Clients use this to query the value of a node.  If the path is not
269# specified, it returns the value associated with the root node.
270# Otherwise, it returns the value for the element specified by the
271# path.
272# ----------------------------------------------------------------------
273itcl::body Rappture::LibraryObj::get {{path ""}} {
274    set node [find $path]
275    if {$node == ""} {
276        return ""
277    }
278    return [string trim [$node text]]
279}
280
281# ----------------------------------------------------------------------
282# USAGE: put ?-append yes? ?-id num? ?<path>? <string>
283#
284# Clients use this to set the value of a node.  If the path is not
285# specified, it sets the value for the root node.  Otherwise, it sets
286# the value for the element specified by the path.  If the value is a
287# string, then it is treated as the text within the tag at the tail
288# of the path.  If it is a DOM node or a library, then it is inserted
289# into the tree at the specified path.
290#
291# If the optional id is specified, then it sets the identifier for
292# the tag at the tail of the path.  If the optional append flag is
293# specified, then the value is appended to the current value.
294# Otherwise, the value replaces the current value.
295# ----------------------------------------------------------------------
296itcl::body Rappture::LibraryObj::put {args} {
297    array set params {
298        -id ""
299        -append no
300    }
301    while {[llength $args] > 1} {
302        set first [lindex $args 0]
303        if {[string index $first 0] == "-"} {
304            set choices [array names params]
305            if {[lsearch $choices $first] < 0} {
306                error "bad option \"$first\": should be [join [lsort $choices] {, }]"
307            }
308            set params($first) [lindex $args 1]
309            set args [lrange $args 2 end]
310        } else {
311            break
312        }
313    }
314    if {[llength $args] > 2} {
315        error "wrong # args: should be \"put ?-append bval? ?-id num? ?path? string\""
316    }
317    if {[llength $args] == 2} {
318        set path [lindex $args 0]
319        set str [lindex $args 1]
320    } else {
321        set path ""
322        set str [lindex $args 0]
323    }
324    set node [find -create $path]
325
326    #
327    # Clean up any nodes that don't belong.  If we're appending
328    # the value, then clean up only child <tag> nodes.  Otherwise,
329    # clean up all nodes.
330    #
331    set nlist ""
332    if {$params(-append)} {
333        foreach n [$node childNodes] {
334            if {[$n nodeType] != "TEXT_NODE"} {
335                lappend nlist $n
336            }
337        }
338    } else {
339        set nlist [$node childNodes]
340    }
341    foreach n $nlist {
342        $n delete
343    }
344
345    if {[Rappture::library isvalid $str]} {
346        error "not yet implemented"
347    } else {
348        set n [$_document createText $str]
349        $node appendChild $n
350        if {"" != $params(-id)} {
351            $node setAttribute id $params(-id)
352        }
353    }
354    return ""
355}
356
357# ----------------------------------------------------------------------
358# USAGE: remove ?<path>?
359#
360# Clients use this to remove the specified node.  Removes the node
361# from the tree.
362# ----------------------------------------------------------------------
363itcl::body Rappture::LibraryObj::remove {{path ""}} {
364    set node [find $path]
365    if {$node != ""} {
366        $node delete
367    }
368}
369
370# ----------------------------------------------------------------------
371# USAGE: xml
372#
373# Returns a string representing the XML information for the information
374# in this library.
375# ----------------------------------------------------------------------
376itcl::body Rappture::LibraryObj::xml {} {
377    return [$_node asXML]
378}
379
380# ----------------------------------------------------------------------
381# USAGE: find ?-create? <path>
382#
383# Used internally to find a particular element within the root node
384# according to the path, which is a string of the form
385# "typeNN(id).typeNN(id). ...", where each "type" is a tag <type>;
386# if the optional NN is specified, it indicates an index for the
387# <type> tag within its parent; if the optional (id) part is included,
388# it indicates a tag of the form <type id="id">.
389#
390# By default, it looks for an element along the path and returns None
391# if not found.  If the create flag is set, it creates various elements
392# along the path as it goes.  This is useful for "put" operations.
393#
394# If you include "#" instead of a specific number, a node will be
395# created automatically with a new number.  For example, the path
396# "foo.bar#" called the first time will create "foo.bar", the second
397# time "foo.bar1", the third time "foo.bar2" and so forth.
398#
399# Returns an object representing the element indicated by the path,
400# or "" if the path is not found.
401# ----------------------------------------------------------------------
402itcl::body Rappture::LibraryObj::find {args} {
403    set create 0
404    while {[llength $args] > 1} {
405        set first [lindex $args 0]
406        set args [lrange $args 1 end]
407        if {$first == "-create"} {
408            set create 1
409        } else {
410            error "bad option \"$first\": should be -create"
411        }
412    }
413    if {[llength $args] != 1} {
414        error "wrong # args: should be \"find ?-create? path\""
415    }
416    set path [lindex $args 0]
417
418    if {$path == ""} {
419        return $_node
420    }
421    set path [path2list $path]
422
423    #
424    # Follow the given path and look for all of the parts.
425    #
426    set lastnode $_node
427    set node $lastnode
428    foreach part $path {
429        if {![regexp {^(([a-zA-Z_]+#?)([0-9]*))?(\((.*)\))?$} $part \
430               match dummy type index dummy name]} {
431            error "bad path component \"$part\""
432        }
433        #
434        # If the name is like "type2", then look for elements with
435        # the type name and return the one with the given index.
436        # If the name is like "type", then assume the index is 0.
437        #
438        if {$name == ""} {
439            if {$index == ""} {
440                set index 0
441            }
442            set nlist [$node getElementsByTagName $type]
443            set node [lindex $nlist $index]
444        } else {
445            #
446            # If the name is like "type(id)", then look for elements
447            # that match the type and see if one has the requested name.
448            # if the name is like "(id)", then look for any elements
449            # with the requested name.
450            #
451            if {$type != ""} {
452                set nlist [$node getElementsByTagName $type]
453            } else {
454                set nlist [$node childNodes]
455            }
456            set found 0
457            foreach n $nlist {
458                if {[catch {$n getAttribute id} tag]} { set tag "" }
459                if {$tag == $name} {
460                    set found 1
461                    break
462                }
463            }
464            set node [expr {($found) ? $n : ""}]
465        }
466
467        if {$node == ""} {
468            if {!$create} {
469                return ""
470            }
471
472            #
473            # If the "create" flag is set, then create a node
474            # with the specified "type(id)" and continue on.
475            # If the type is "type#", then create a node with
476            # an automatic number.
477            #
478            if {![regexp {^([^\(]+)\(([^\)]+)\)$} $part match type name]} {
479                set type $part
480                set name ""
481            }
482
483            if {[string match *# $type]} {
484                set type [string trimright $type #]
485                set node [$_document createElement $type]
486
487                # find the last node of same type and append there
488                set pos ""
489                foreach n [$lastnode childNodes] {
490                    if {[$n nodeName] == $type} {
491                        set pos $n
492                    }
493                }
494                if {$pos != ""} {
495                    set pos [$pos nextSibling]
496                }
497                if {$pos != ""} {
498                    $lastnode insertBefore $node $pos
499                } else {
500                    $lastnode appendChild $node
501                }
502            } else {
503                set node [$_document createElement $type]
504                $lastnode appendChild $node
505            }
506            if {"" != $name} {
507                $node setAttribute id $name
508            }
509        }
510        set lastnode $node
511    }
512    return $node
513}
514
515# ----------------------------------------------------------------------
516# USAGE: path2list <path>
517#
518# Converts a path of the form "foo(a).bar.baz" into a list of the
519# form "foo(a) bar baz".  This is a little more complicated than
520# splitting on the .'s, since the stuff in ()'s might have embedded
521# .'s.  Returns a proper Tcl list for all elements of the path.
522# ----------------------------------------------------------------------
523itcl::body Rappture::LibraryObj::path2list {path} {
524    #
525    # Normally, we just split on .'s within the path.  But there
526    # might be some .'s embedded within ()'s in the path.  Change
527    # any embedded .'s to an out-of-band character, then split on
528    # the .'s, and change the embedded .'s back.
529    #
530    if {[regexp {(\([^\)]*)\.([^\)]*\))} $path]} {
531        while {[regsub -all {(\([^\)]*)\.([^\)]*\))} $path "\\1\007\\2" path]} {
532            # keep fixing...
533        }
534    }
535    set path [split $path .]
536    regsub -all {\007} $path {.} path
537
538    return $path
539}
540
541# ----------------------------------------------------------------------
542# USAGE: node2name <node>
543#
544# Used internally to create a name for the specified node.  If the
545# node doesn't have a specific name ("id" attribute) then a name of
546# the form "type123" is constructed.
547# ----------------------------------------------------------------------
548itcl::body Rappture::LibraryObj::node2name {node} {
549    if {[catch {$node getAttribute id} name]} { set name "" }
550    if {$name == ""} {
551        set pnode [$node parentNode]
552        if {$pnode == ""} {
553            return ""
554        }
555        set type [$node nodeName]
556        set siblings [$pnode getElementsByTagName $type]
557        set index [lsearch $siblings $node]
558        if {$index == 0} {
559            set name $type
560        } else {
561            set name "$type$index"
562        }
563    }
564    return $name
565}
566
567# ----------------------------------------------------------------------
568# USAGE: node2comp <node>
569#
570# Used internally to create a path component name for the specified
571# node.  A path component name has the form "type(id)" or just
572# "type##" if the node doesn't have a name.  This name can be used
573# in a path to uniquely address the component.
574# ----------------------------------------------------------------------
575itcl::body Rappture::LibraryObj::node2comp {node} {
576    set type [$node nodeName]
577    if {[catch {$node getAttribute id} name]} { set name "" }
578    if {$name == ""} {
579        set pnode [$node parentNode]
580        if {$pnode == ""} {
581            return ""
582        }
583        set siblings [$pnode getElementsByTagName $type]
584        set index [lsearch $siblings $node]
585        if {$index == 0} {
586            set name $type
587        } else {
588            set name "$type$index"
589        }
590    } else {
591        set name "${type}($name)"
592    }
593    return $name
594}
Note: See TracBrowser for help on using the repository browser.