Changeset 6 for trunk/tcl


Ignore:
Timestamp:
Mar 23, 2005 8:19:29 PM (16 years ago)
Author:
mmc
Message:

Fixed the Tcl library to mirror the API developed for XML
libraries on the Python side. The Tcl Rappture::library
now has methods like "children", "element", "put", etc.
One difference: On the Tcl side, the default -flavor for
element/children is "component", since that works better
in Tcl code. In Python, the default is flavor=object.

Also fixed the Tcl install script to install not just
the tcl/scripts library, but also the ../gui and ../lib
directories.

Location:
trunk/tcl
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • trunk/tcl/install

    r1 r6  
    4040set targetdir [file join $dir $package$version]
    4141
    42 mkindex scripts
    43 
    4442if {![file exists $targetdir]} {
    4543    puts "making directory $targetdir..."
     
    4745}
    4846
    49 foreach file [find .] {
     47set origdir [pwd]
     48foreach context {. ../gui} {
     49    cd $context
     50
     51    foreach file [find .] {
     52        set target [file join $targetdir $file]
     53        if {[file isdirectory $file]} {
     54            puts "making directory $target..."
     55            catch {file mkdir $target}
     56            file attributes $target -permissions ugo+rx
     57        } else {
     58            puts "installing $target..."
     59            file copy -force $file $target
     60            file attributes $target -permissions ugo+r
     61        }
     62    }
     63}
     64
     65cd ..
     66catch {file mkdir [file join $targetdir lib]}
     67foreach file [find ./lib] {
    5068    set target [file join $targetdir $file]
    5169    if {[file isdirectory $file]} {
     
    6078}
    6179
     80cd $origdir
     81
    6282set fid [open [file join $targetdir pkgIndex.tcl] w]
    6383puts $fid "# Tcl package index file"
     
    6989close $fid
    7090
     91mkindex [file join $targetdir scripts]
     92
    7193puts "== $package-$version INSTALLED"
  • trunk/tcl/scripts/library.tcl

    r1 r6  
    1212
    1313namespace eval Rappture { # forward declaration }
    14 namespace eval Rappture::Library { # forward declaration }
    15 
    16 # ----------------------------------------------------------------------
    17 # USAGE: open ?-std? <file>
     14
     15# ----------------------------------------------------------------------
     16# USAGE: library ?-std? <file>
     17# USAGE: library isvalid <object>
    1818#
    1919# Used to open a <file> containing an XML description of tool
     
    2323# If the -std flag is included, then the file is treated as the
    2424# name of a standard file, which is part of the Rappture installation.
    25 # ----------------------------------------------------------------------
    26 proc Rappture::Library::open {args} {
     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...
    2743    set stdfile 0
    2844    while {[llength $args] > 1} {
     
    5167
    5268# ----------------------------------------------------------------------
    53 # USAGE: valid <obj>
    54 #
    55 # Checks to see if the given object is a valid Library.  Returns 1
    56 # if so, and 0 otherwise.
    57 # ----------------------------------------------------------------------
    58 proc Rappture::Library::valid {obj} {
    59     if {[catch {$obj isa ::Rappture::LibraryObj} valid] == 0 && $valid} {
    60         return 1
    61     }
    62     return 0
    63 }
    64 
    65 # ----------------------------------------------------------------------
    6669itcl::class Rappture::LibraryObj {
    6770    constructor {info} { # defined below }
    6871    destructor { # defined below }
    6972
    70     public method get {args}
     73    public method element {args}
     74    public method children {args}
     75    public method get {{path ""}}
    7176    public method put {args}
     77    public method remove {{path ""}}
    7278    public method xml {}
    7379
    7480    protected method find {path}
    7581    protected method path2list {path}
     82    protected method node2name {node}
     83    protected method node2comp {node}
    7684
    7785    private variable _root 0       ;# non-zero => this obj owns document
     
    107115
    108116# ----------------------------------------------------------------------
    109 # USAGE: get ?-exists|-object|-type|-info|-count|-children? ?<path>?
    110 #
    111 # Searches the DOM inside this object for the information on the
    112 # requested <path>.  By default, it returns the -info associated
    113 # with the path.  The other flags can be used to query other
    114 # aspects of the information at the requested node.
    115 # ----------------------------------------------------------------------
    116 itcl::body Rappture::LibraryObj::get {args} {
    117     set format -info
    118     while {[llength $args] > 0} {
     117# USAGE: element ?-flavor <fval>? ?<path>?
     118#
     119# Clients use this to query a particular element within the entire
     120# data structure.  The path is a string of the form
     121# "structure.box(source).corner".  This example represents the tag
     122# <corner> within a tag <box id="source"> within a tag <structure>,
     123# which must be found at the top level within this document.
     124#
     125# By default, this method returns the component name "type(id)".
     126# This is changed by setting the -flavor argument to "id" (for name
     127# of the tail element), to "type" (for the type of the tail element),
     128# to "object" (for an object representing the DOM node referenced by
     129# the path.
     130# ----------------------------------------------------------------------
     131itcl::body Rappture::LibraryObj::element {args} {
     132    array set params {
     133        -flavor component
     134    }
     135    while {[llength $args] > 1} {
    119136        set first [lindex $args 0]
    120137        if {[string index $first 0] == "-"} {
    121             set choices {-exists -object -type -info -count -children}
     138            set choices [array names params]
    122139            if {[lsearch $choices $first] < 0} {
    123140                error "bad option \"$first\": should be [join [lsort $choices] {, }]"
    124141            }
    125             set format $first
    126             set args [lrange $args 1 end]
     142            set params($first) [lindex $args 1]
     143            set args [lrange $args 2 end]
    127144        } else {
    128145            break
     
    130147    }
    131148    if {[llength $args] > 1} {
    132         error "wrong # args: should be \"get ?-exists? ?-object? ?-type? ?-info? ?-count? ?-children? ?path?\""
     149        error "wrong # args: should be \"element ?-flavor fval? ?path?\""
    133150    }
    134151    set path [lindex $args 0]
    135152
    136153    set node [find $path]
    137 
    138     switch -- $format {
    139         -exists {
    140             if {$node != ""} {
    141                 return 1
    142             }
    143             return 0
    144         }
    145         -object {
    146             if {$node != ""} {
    147                 return [::Rappture::LibraryObj ::#auto $node]
    148             }
    149             return ""
    150         }
    151         -info {
    152             if {$node != ""} {
    153                 return [string trim [$node text]]
    154             }
    155             return ""
    156         }
    157         -type   {
    158             if {$node != ""} {
    159                 return [$node nodeName]
    160             }
    161         }
    162         -count {
    163             if {$node == ""} {
    164                 return ""
    165             }
    166             set node [$node parent]
    167             set type [lindex [path2list $path] end]
    168             set nlist [$node getElementsByTagName $type]
    169             return [llength $nlist]
    170         }
    171         -children {
    172             if {$node == ""} {
    173                 return ""
    174             }
    175             set rlist ""
    176             set nlist [$node childNodes]
    177             foreach n $nlist {
    178                 set type [$n nodeName]
    179                 if {[regexp {^#} $type]} {
    180                     continue
    181                 }
    182                 if {![info exists count($type)]} {
    183                     set count($type) 0
    184                     lappend rlist $type
    185                 } else {
    186                     lappend rlist "$type[incr count($type)]"
    187                 }
    188             }
    189             return $rlist
    190         }
    191     }
    192     return ""
    193 }
    194 
    195 # ----------------------------------------------------------------------
    196 # USAGE: put <path> ?-text|-object? <string>
    197 #
    198 # Inserts information into the DOM represented by this object.
    199 # The <path> is a path to the insertion point, which uses a syntax
    200 # similar to the "get" method.  The <string> being inserted can either
    201 # be ordinary text, or another LibraryObj object.
    202 # ----------------------------------------------------------------------
    203 itcl::body Rappture::LibraryObj::put {args} {
    204     set what "-text"
    205     set path [lindex $args 0]
    206     set args [lrange $args 1 end]
     154    if {$node == ""} {
     155        return ""
     156    }
     157
     158    switch -- $params(-flavor) {
     159      object {
     160          return [::Rappture::LibraryObj ::#auto $node]
     161      }
     162      component {
     163          return [node2comp $node]
     164      }
     165      id {
     166          return [node2name $node]
     167      }
     168      type {
     169          return [$node nodeName]
     170      }
     171      default {
     172          error "bad flavor \"$params(-flavor)\": should be object, id, type, component"
     173      }
     174    }
     175}
     176
     177# ----------------------------------------------------------------------
     178# USAGE: children ?-flavor <fval>? ?-type <name>? ?<path>?
     179#
     180# Clients use this to query the children of a particular element
     181# within the entire data structure.  This is just like the "element"
     182# method, but it returns the children of the element instead of the
     183# element itself.  If the optional -type argument is specified, then
     184# the return list is restricted to children of the specified type.
     185#
     186# By default, this method returns a list of component names "type(id)".
     187# This is changed by setting the -flavor argument to "id" (for tail
     188# names of all children), to "type" (for the types of all children),
     189# to "object" (for a list of objects representing the DOM nodes for
     190# all children).
     191# ----------------------------------------------------------------------
     192itcl::body Rappture::LibraryObj::children {args} {
     193    array set params {
     194        -flavor component
     195        -type ""
     196    }
    207197    while {[llength $args] > 1} {
    208198        set first [lindex $args 0]
    209         set args [lrange $args 1 end]
    210         if {$first != "-text" && $first != "-object"} {
    211             error "bad option \"$first\": should be -object, -text"
    212         }
    213         set what $first
    214     }
    215     if {[llength $args] != 1} {
    216         error "wrong # args: should be \"put path ?-text? ?-object? string\""
    217     }
    218     set str [lindex $args 0]
    219 
    220     switch -- $what {
    221         -text {
    222             set node [find -create $path]
    223             foreach n [$node childNodes] {
    224                 if {[$n nodeType] == "TEXT_NODE"} {
    225                     $n delete
    226                 }
    227             }
    228             set n [$_document createText $str]
    229             $node appendChild $n
    230         }
    231         -object {
    232             error "not yet implemented"
    233         }
     199        if {[string index $first 0] == "-"} {
     200            set choices [array names params]
     201            if {[lsearch $choices $first] < 0} {
     202                error "bad option \"$first\": should be [join [lsort $choices] {, }]"
     203            }
     204            set params($first) [lindex $args 1]
     205            set args [lrange $args 2 end]
     206        } else {
     207            break
     208        }
     209    }
     210    if {[llength $args] > 1} {
     211        error "wrong # args: should be \"children ?-flavor fval? ?-type name? ?path?\""
     212    }
     213    set path [lindex $args 0]
     214
     215    set node [find $path]
     216    if {$node == ""} {
     217        return ""
     218    }
     219
     220    set nlist ""
     221    foreach n [$node childNodes] {
     222        set type [$n nodeName]
     223        if {[regexp {^#} $type]} {
     224            continue
     225        }
     226        if {$params(-type) != "" && $params(-type) != $type} {
     227            continue
     228        }
     229        lappend nlist $n
     230    }
     231
     232    set rlist ""
     233    switch -- $params(-flavor) {
     234      object {
     235          foreach n $nlist {
     236              lappend rlist [::Rappture::LibraryObj ::#auto $n]
     237          }
     238      }
     239      component {
     240          foreach n $nlist {
     241              lappend rlist [node2comp $n]
     242          }
     243      }
     244      id {
     245          foreach n $nlist {
     246              lappend rlist [node2name $n]
     247          }
     248      }
     249      type {
     250          foreach n $nlist {
     251              lappend rlist [$n nodeName]
     252          }
     253      }
     254      default {
     255          error "bad flavor \"$params(-flavor)\": should be object, id, type, component"
     256      }
     257    }
     258    return $rlist
     259}
     260
     261# ----------------------------------------------------------------------
     262# USAGE: get ?<path>?
     263#
     264# Clients use this to query the value of a node.  If the path is not
     265# specified, it returns the value associated with the root node.
     266# Otherwise, it returns the value for the element specified by the
     267# path.
     268# ----------------------------------------------------------------------
     269itcl::body Rappture::LibraryObj::get {{path ""}} {
     270    set node [find $path]
     271    if {$node == ""} {
     272        return ""
     273    }
     274    return [string trim [$node text]]
     275}
     276
     277# ----------------------------------------------------------------------
     278# USAGE: put ?-append yes? ?-id num? ?<path>? <string>
     279#
     280# Clients use this to set the value of a node.  If the path is not
     281# specified, it sets the value for the root node.  Otherwise, it sets
     282# the value for the element specified by the path.  If the value is a
     283# string, then it is treated as the text within the tag at the tail
     284# of the path.  If it is a DOM node or a library, then it is inserted
     285# into the tree at the specified path.
     286#
     287# If the optional id is specified, then it sets the identifier for
     288# the tag at the tail of the path.  If the optional append flag is
     289# specified, then the value is appended to the current value.
     290# Otherwise, the value replaces the current value.
     291# ----------------------------------------------------------------------
     292itcl::body Rappture::LibraryObj::put {args} {
     293    array set params {
     294        -id ""
     295        -append no
     296    }
     297    while {[llength $args] > 1} {
     298        set first [lindex $args 0]
     299        if {[string index $first 0] == "-"} {
     300            set choices [array names params]
     301            if {[lsearch $choices $first] < 0} {
     302                error "bad option \"$first\": should be [join [lsort $choices] {, }]"
     303            }
     304            set params($first) [lindex $args 1]
     305            set args [lrange $args 2 end]
     306        } else {
     307            break
     308        }
     309    }
     310    if {[llength $args] > 2} {
     311        error "wrong # args: should be \"put ?-append bval? ?-id num? ?path? string\""
     312    }
     313    if {[llength $args] == 2} {
     314        set path [lindex $args 0]
     315        set str [lindex $args 1]
     316    } else {
     317        set path ""
     318        set str [lindex $args 0]
     319    }
     320    set node [find -create $path]
     321
     322    #
     323    # Clean up any nodes that don't belong.  If we're appending
     324    # the value, then clean up only child <tag> nodes.  Otherwise,
     325    # clean up all nodes.
     326    #
     327    set nlist ""
     328    if {$params(-append)} {
     329        foreach n [$node childNodes] {
     330            if {[$n nodeType] != "TEXT_NODE"} {
     331                lappend nlist $n
     332            }
     333        }
     334    } else {
     335        set nlist [$node childNodes]
     336    }
     337    foreach n $nlist {
     338        $n delete
     339    }
     340
     341    if {[Rappture::library isvalid $str]} {
     342        error "not yet implemented"
     343    } else {
     344        set n [$_document createText $str]
     345        $node appendChild $n
     346        if {"" != $params(-id)} {
     347            $node setAttribute id $params(-id)
     348        }
     349    }
     350    return ""
     351}
     352
     353# ----------------------------------------------------------------------
     354# USAGE: remove ?<path>?
     355#
     356# Clients use this to remove the specified node.  Removes the node
     357# from the tree.
     358# ----------------------------------------------------------------------
     359itcl::body Rappture::LibraryObj::remove {{path ""}} {
     360    set node [find $path]
     361    if {$node != ""} {
     362        $node delete
    234363    }
    235364}
     
    248377# USAGE: find ?-create? <path>
    249378#
    250 # Searches from the starting node for this object according to the
    251 # given <path>.  Returns the node found at the end of the path,
    252 # or "" if the node was not found.
     379# Used internally to find a particular element within the root node
     380# according to the path, which is a string of the form
     381# "typeNN(id).typeNN(id). ...", where each "type" is a tag <type>;
     382# if the optional NN is specified, it indicates an index for the
     383# <type> tag within its parent; if the optional (id) part is included,
     384# it indicates a tag of the form <type id="id">.
     385#
     386# By default, it looks for an element along the path and returns None
     387# if not found.  If the create flag is set, it creates various elements
     388# along the path as it goes.  This is useful for "put" operations.
     389#
     390# If you include "#" instead of a specific number, a node will be
     391# created automatically with a new number.  For example, the path
     392# "foo.bar#" called the first time will create "foo.bar", the second
     393# time "foo.bar1", the third time "foo.bar2" and so forth.
     394#
     395# Returns an object representing the element indicated by the path,
     396# or "" if the path is not found.
    253397# ----------------------------------------------------------------------
    254398itcl::body Rappture::LibraryObj::find {args} {
     
    266410        error "wrong # args: should be \"find ?-create? path\""
    267411    }
    268     set path [path2list [lindex $args 0]]
     412    set path [lindex $args 0]
     413
     414    if {$path == ""} {
     415        return $_node
     416    }
     417    set path [path2list $path]
    269418
    270419    #
    271420    # Follow the given path and look for all of the parts.
    272421    #
    273     set nnum 1
    274422    set lastnode $_node
    275423    set node $lastnode
    276424    foreach part $path {
    277         if {[regexp {^([a-zA-Z_]+)([0-9]*)$} $part match type index]
    278               && ($index != "" || [$node getElementsByTagName $type] != "")} {
    279             #
    280             # If the name is like "type2", then look for elements with
    281             # the type name and return the one with the given index.
    282             # If the name is like "type", then assume the index is 0.
    283             #
     425        if {![regexp {^(([a-zA-Z_]+#?)([0-9]*))?(\(([^\)]+)\))?$} $part \
     426               match dummy type index dummy name]} {
     427            error "bad path component \"$part\""
     428        }
     429        #
     430        # If the name is like "type2", then look for elements with
     431        # the type name and return the one with the given index.
     432        # If the name is like "type", then assume the index is 0.
     433        #
     434        if {$name == ""} {
    284435            if {$index == ""} {
    285436                set index 0
     
    287438            set nlist [$node getElementsByTagName $type]
    288439            set node [lindex $nlist $index]
    289         } elseif {[regexp {^([a-zA-Z_]+)\(([^\)]*)\)$} $part match type name]} {
     440        } else {
    290441            #
    291             # If the name is like "type(name)", then look for elements
     442            # If the name is like "type(id)", then look for elements
    292443            # that match the type and see if one has the requested name.
     444            # if the name is like "(id)", then look for any elements
     445            # with the requested name.
    293446            #
    294             set nlist [$node getElementsByTagName $type]
     447            if {$type != ""} {
     448                set nlist [$node getElementsByTagName $type]
     449            } else {
     450                set nlist [$node childNodes]
     451            }
    295452            set found 0
    296453            foreach n $nlist {
    297                 if {[catch {$n getAttribute name} tag]} { set tag "" }
     454                if {[catch {$n getAttribute id} tag]} { set tag "" }
    298455                if {$tag == $name} {
    299456                    set found 1
     
    302459            }
    303460            set node [expr {($found) ? $n : ""}]
    304         } else {
    305             #
    306             # Otherwise, the name might be something like "name".
    307             # Scan through all elements and see if any has the
    308             # matching name.
    309             #
    310             set nlist [$node childNodes]
    311             set found 0
    312             foreach n $nlist {
    313                 if {[catch {$n getAttribute name} tag]} { set tag "" }
    314                 if {$tag == $part} {
    315                     set found 1
    316                     break
    317                 }
    318             }
    319             set node [expr {($found) ? $n : ""}]
    320461        }
    321462
     
    324465                return ""
    325466            }
     467
     468            #
     469            # If the "create" flag is set, then create a node
     470            # with the specified "type(id)" and continue on.
     471            # If the type is "type#", then create a node with
     472            # an automatic number.
     473            #
    326474            if {![regexp {^([^\(]+)\(([^\)]+)\)$} $part match type name]} {
    327475                set type $part
    328476                set name ""
    329477            }
    330             set node [$_document createElement $type]
    331             $lastnode appendChild $node
    332 
     478
     479            if {[string match *# $type]} {
     480                set type [string trimright $type #]
     481                set node [$_document createElement $type]
     482
     483                # find the last node of same type and append there
     484                set pos ""
     485                foreach n [$lastnode childNodes] {
     486                    if {[$n nodeName] == $type} {
     487                        set pos $n
     488                    }
     489                }
     490                if {$pos != ""} {
     491                    set pos [$pos nextSibling]
     492                }
     493                if {$pos != ""} {
     494                    $lastnode insertBefore $node $pos
     495                } else {
     496                    $lastnode appendChild $node
     497                }
     498            } else {
     499                set node [$_document createElement $type]
     500                $lastnode appendChild $node
     501            }
    333502            if {"" != $name} {
    334                 $node setAttribute name $name
     503                $node setAttribute id $name
    335504            }
    336505        }
    337506        set lastnode $node
    338         incr nnum
    339507    }
    340508    return $node
     
    366534    return $path
    367535}
     536
     537# ----------------------------------------------------------------------
     538# USAGE: node2name <node>
     539#
     540# Used internally to create a name for the specified node.  If the
     541# node doesn't have a specific name ("id" attribute) then a name of
     542# the form "type123" is constructed.
     543# ----------------------------------------------------------------------
     544itcl::body Rappture::LibraryObj::node2name {node} {
     545    if {[catch {$node getAttribute id} name]} { set name "" }
     546    if {$name == ""} {
     547        set pnode [$node parentNode]
     548        if {$pnode == ""} {
     549            return ""
     550        }
     551        set type [$node nodeName]
     552        set siblings [$pnode getElementsByTagName $type]
     553        set index [lsearch $siblings $node]
     554        if {$index == 0} {
     555            set name $type
     556        } else {
     557            set name "$type$index"
     558        }
     559    }
     560    return $name
     561}
     562
     563# ----------------------------------------------------------------------
     564# USAGE: node2comp <node>
     565#
     566# Used internally to create a path component name for the specified
     567# node.  A path component name has the form "type(id)" or just
     568# "type##" if the node doesn't have a name.  This name can be used
     569# in a path to uniquely address the component.
     570# ----------------------------------------------------------------------
     571itcl::body Rappture::LibraryObj::node2comp {node} {
     572    set type [$node nodeName]
     573    if {[catch {$node getAttribute id} name]} { set name "" }
     574    if {$name == ""} {
     575        set pnode [$node parentNode]
     576        if {$pnode == ""} {
     577            return ""
     578        }
     579        set siblings [$pnode getElementsByTagName $type]
     580        set index [lsearch $siblings $node]
     581        if {$index == 0} {
     582            set name $type
     583        } else {
     584            set name "$type$index"
     585        }
     586    } else {
     587        set name "${type}($name)"
     588    }
     589    return $name
     590}
Note: See TracChangeset for help on using the changeset viewer.