source: trunk/lang/tcl/scripts/objects.tcl @ 2081

Last change on this file since 2081 was 2081, checked in by mmc, 13 years ago

Part 2 of the major reorganization to group all of the rappture utilties
under a single rappture command. Builds better now. Still need to fix
up the builder to work with the objects in a different location now.
File size: 16.1 KB
Line 
1# ----------------------------------------------------------------------
2#  COMPONENT: objects
3#
4#  This file contains routines to parse object data from files in
5#  the "objects" directory.  Each file defines a Rappture object and
6#  all information needed to specify the object in a tool.xml file.
7#
8#    object NAME ?-extends BASE? {
9#        attr NAME -title XX -type TYPE -path PATH
10#        check attr { code... }
11#        palettes NAME NAME ...
12#        help URL
13#        terminal yes|no
14#        ...
15#    }
16#
17# ======================================================================
18#  AUTHOR:  Michael McLennan, Purdue University
19#  Copyright (c) 2004-2011  Purdue Research Foundation
20#
21#  See the file "license.terms" for information on usage and
22#  redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
23# ======================================================================
24package require Itcl
25
26namespace eval Rappture { # forward declaration }
27namespace eval Rappture::objects {
28    # location of system object info
29    variable installdir [file dirname [file normalize [info script]]]
30
31    #
32    # Set up a safe interpreter for loading object defn files...
33    #
34    variable objParser [interp create -safe]
35    foreach cmd [$objParser eval {info commands}] {
36        $objParser hide $cmd
37    }
38    $objParser alias object Rappture::objects::parse_object
39    $objParser alias unknown Rappture::objects::parse_obj_unknown
40    proc ::Rappture::objects::parse_obj_unknown {args} {
41        error "bad option \"[lindex $args 0]\": should be object"
42    }
43
44    #
45    # Set up a safe interpreter for loading object attributes...
46    #
47    variable attrParser [interp create -safe]
48    foreach cmd [$attrParser eval {info commands}] {
49        $attrParser hide $cmd
50    }
51    $attrParser alias attr Rappture::objects::parse_attr
52    $attrParser alias check Rappture::objects::parse_check
53    $attrParser alias help Rappture::objects::parse_help
54    $attrParser alias palettes Rappture::objects::parse_palettes
55    $attrParser alias terminal Rappture::objects::parse_terminal
56    $attrParser alias unknown Rappture::objects::parse_attr_unknown
57    proc ::Rappture::objects::parse_attr_unknown {args} {
58        error "bad option \"[lindex $args 0]\": should be attr, check, help, palettes, terminal"
59    }
60
61    # this variable will hold ObjDef object as it is being built
62    variable currObjDef ""
63
64    # this variable will hold the name of the object file being parsed
65    variable currFile ""
66}
67
68# ----------------------------------------------------------------------
69# USAGE: Rappture::objects::init
70#
71# Called at the beginning of a Rappture program to initialize the
72# object system.  Loads all object definitions in the "objects"
73# directory found at the system location.  Object types can be
74# queried by calling Rappture::objects::get.
75# ----------------------------------------------------------------------
76proc Rappture::objects::init {} {
77    variable installdir
78
79    # load supporting type definitions
80    foreach fname [glob [file join $installdir types *.tcl]] {
81        source $fname
82    }
83
84    # load supporting validation procs
85    foreach fname [glob [file join $installdir validations *.tcl]] {
86        source $fname
87    }
88
89    # load the base class
90    Rappture::objects::load [file join $installdir objects base.rp]
91
92    # load any other classes found
93    foreach dir [glob -nocomplain -types d [file join $installdir objects *]] {
94        Rappture::objects::load [file join $dir *.rp]
95    }
96}
97
98# ----------------------------------------------------------------------
99# USAGE: Rappture::objects::load ?<filePattern> <filePattern> ...?
100#
101# Clients call this to load object definitions from all files that
102# match the given set of file patterns.  These may be specific
103# file names or patterns of the form "dir/*.rp".  Each object is
104# loaded and Rappture::ObjDef objects are created as a side effect
105# to represent them.  Object types can be queried by calling
106# Rappture::objects::get.
107# ----------------------------------------------------------------------
108proc Rappture::objects::load {args} {
109    variable objParser
110    variable objDefs
111    variable currFile
112
113    # scan through all matching files and load their definitions
114    foreach pattern $args {
115        foreach fname [glob -nocomplain $pattern] {
116            set currFile $fname
117            set fid [open $fname r]
118            set info [read $fid]
119            close $fid
120
121            if {[catch {$objParser eval $info} err] != 0} {
122                error $err "\n    (while loading object definition from file \"$fname\")"
123            }
124        }
125    }
126
127    # look at all inheritance relationships and make sure they're satisfied
128    foreach name [array names objDefs] {
129        set ilist [$objDefs($name) cget -inherit]
130        set newilist ""
131        foreach obj $ilist {
132            if {[string index $obj 0] == "@"} {
133                set tname [string range $obj 1 end]
134                if {[info exists objDefs($tname)]} {
135                    lappend newilist $objDefs($tname)
136                } else {
137                    set errs($tname) 1
138                }
139            }
140            $objDefs($name) configure -inherit $newilist
141        }
142    }
143
144    if {[array size errs] > 0} {
145        error "missing definition for base class: [join [lsort [array names errs]] {, }]"
146    }
147}
148
149# ----------------------------------------------------------------------
150# USAGE: Rappture::objects::get ?<name>? ?-what?
151#
152# Returns information about the known Rappture object types.
153# With no args, it returns a list of object class names.  With a
154# specified <name>, it returns all information for that object in
155# a key/value format:
156#
157#   -image xxx -palettes {xx xx xx} -attributes {{...} {...} ...}
158#   -help URL -terminal bool
159#
160# Otherwise, the -what indicates which specific value should be
161# returned.
162# ----------------------------------------------------------------------
163proc Rappture::objects::get {{name ""} {what ""}} {
164    variable objDefs
165
166    if {"" == $name} {
167        return [array names objDefs]
168    }
169
170    set name [string tolower $name]  ;# doesn't matter: Tool or tool
171    set info(-image) [$objDefs($name) cget -image]
172    set info(-help) [$objDefs($name) cget -help]
173    set info(-palettes) [$objDefs($name) cget -palettes]
174    set info(-terminal) [$objDefs($name) cget -terminal]
175
176    set rlist ""
177    set olist $objDefs($name)
178    while {[llength $olist] > 0} {
179        set obj [lindex $olist 0]
180        if {![info exists gotparents($obj)]} {
181            set pos 0
182            foreach baseobj [$obj cget -inherit] {
183                set olist [linsert $olist $pos $baseobj]
184                incr pos
185            }
186            set gotparents($obj) 1
187        }
188
189        set obj [lindex $olist 0]
190        set olist [lrange $olist 1 end]
191
192        foreach aname [$obj get] {
193            lappend rlist [$obj get $aname]
194        }
195    }
196    set info(-attributes) $rlist
197
198    if {"" == $what} {
199        return [array get info]
200    } elseif {[info exists info($what)]} {
201        return $info($what)
202    }
203    error "bad option \"$what\": should be [join [lsort [array names info]] {, }]"
204}
205
206# ----------------------------------------------------------------------
207# USAGE: Rappture::objects::palettes
208#
209# Returns a list of unique palette names from all known types.
210# ----------------------------------------------------------------------
211proc Rappture::objects::palettes {} {
212    variable objDefs
213
214    foreach name [array names objDefs] {
215        foreach pname [$objDefs($name) cget -palettes] {
216            set unique($pname) 1
217        }
218    }
219    return [lsort -dictionary [array names unique]]
220}
221
222# ----------------------------------------------------------------------
223# USAGE: Rappture::objects::check <type> {<key> <val>...} <debugInfo>
224#
225# Checks the definition for an object of the given <type> to see if
226# there are any errors in the values.  The attribute values are
227# specified as a key/value list.  Returns a list of the form:
228#   error "something went wrong"
229#   warning "might check this"
230# ----------------------------------------------------------------------
231proc Rappture::objects::check {type attrinfo debug} {
232    variable objDefs
233
234    set type [string tolower $type]  ;# doesn't matter: Tool or tool
235
236    if {[info exists objDefs($type)]} {
237        return [$objDefs($type) check $attrinfo $debug]
238    }
239    return ""
240}
241
242# ----------------------------------------------------------------------
243# PARSER:  Rappture::objects::parse_object
244#
245# Used internally to parse the definition of a Rappture object type:
246#
247#   object <name> ?-extends <type>? {
248#     attr <name> <args>...
249#     attr <name> <args>...
250#     ...
251#   }
252#
253# Builds an object in currObjDef and then registers the completed
254# object in the objDefs array.
255# ----------------------------------------------------------------------
256proc Rappture::objects::parse_object {args} {
257    variable currObjDef
258    variable currFile
259    variable objDefs
260    variable attrParser
261
262    set name [lindex $args 0]
263    set args [lrange $args 1 end]
264
265    set ilist ""
266    while {1} {
267        set first [lindex $args 0]
268        if {[string index $first 0] != "-"} {
269            break
270        }
271        if {"-extends" == $first} {
272            set base [lindex $args 1]
273            set args [lrange $args 2 end]
274            lappend ilist @$base
275        } else {
276            error "bad option \"$first\": should be -extends"
277        }
278    }
279
280    if {[llength $args] != 1} {
281        error "wrong # args: should be \"object name ?-extends base? {...definition...}\""
282    }
283    set body [lindex $args end]
284
285    # create an object definition and add attributes to it
286    set currObjDef [Rappture::objects::ObjDef ::#auto -inherit $ilist]
287    set cmds {
288        # parse attribute definitions
289        $attrParser eval $body
290
291        # look for an image for this object
292        set rootf [file rootname $currFile]
293        foreach ext {png jpg gif} {
294            if {[file readable $rootf.$ext]
295                  && [catch {package present Tk}] == 0} {
296                set imh [image create photo -file $rootf.$ext]
297                $currObjDef configure -image $imh
298                break
299            }
300        }
301    }
302
303    if {[catch $cmds err] != 0} {
304        itcl::delete object $currObjDef
305        set currObjDef ""
306        error $err "\n    (while loading object definition for \"$name\")"
307    }
308
309    set objDefs($name) $currObjDef
310    set currObjDef ""
311}
312
313# ----------------------------------------------------------------------
314# PARSER:  Rappture::objects::parse_attr
315#
316# Used internally to parse the definition of an attribute within a
317# Rappture object definition:
318#
319#   attr <name> -title <string> -type <string> -path <string>
320#
321# Adds an attribute definition to the object in currObjDef.
322# ----------------------------------------------------------------------
323proc Rappture::objects::parse_attr {args} {
324    variable currObjDef
325
326    set name [lindex $args 0]
327    eval $currObjDef add attr $name [lrange $args 1 end]
328}
329
330# ----------------------------------------------------------------------
331# PARSER:  Rappture::objects::parse_check
332#
333# Used internally to register a bit of code that's used to check the
334# integrity of a value.
335#
336#   check attr { code... }
337#
338# The code assumes that attribute values are stored in an attr(...)
339# array.  It checks the values and returns errors in the following
340# format:
341#   error "something went wrong" {-node 2 -counter 7 -attr label}
342#   warning "watch out for this" {-node 8 -counter 1 -attr description}
343# ----------------------------------------------------------------------
344proc Rappture::objects::parse_check {attr code} {
345    variable currObjDef
346    $currObjDef add check $attr $code
347}
348
349# ----------------------------------------------------------------------
350# PARSER:  Rappture::objects::parse_help
351#
352# Used internally to parse the definition of the help page URL for a
353# Rappture object definition:
354#
355#   help <url>
356#
357# Keeps the <url> around so it can be displayed later in a "Help"
358# button on the attribute editor.
359# ----------------------------------------------------------------------
360proc Rappture::objects::parse_help {url} {
361    variable currObjDef
362    if {![regexp {^https?://} $url]} {
363        error "bad value \"$url\": should be a URL for the help page"
364    }
365    $currObjDef configure -help $url
366}
367
368# ----------------------------------------------------------------------
369# PARSER:  Rappture::objects::parse_palettes
370#
371# Used internally to parse the definition of the palettes for a
372# Rappture object definition:
373#
374#   palettes <name> <name> ...
375#
376# Adds the list of palettes to the object definition.  This determines
377# what palettes of controls will contain this object.
378# ----------------------------------------------------------------------
379proc Rappture::objects::parse_palettes {args} {
380    variable currObjDef
381    $currObjDef configure -palettes $args
382}
383
384# ----------------------------------------------------------------------
385# PARSER:  Rappture::objects::parse_terminal
386#
387# Used internally to parse the "terminal" setting within a Rappture
388# object definition:
389#
390#   terminal yes|no
391#
392# Sets the Boolean value, which determines whether or not this object
393# can have other objects embedded within it.  If it is "terminal",
394# an object is a leaf node.
395# ----------------------------------------------------------------------
396proc Rappture::objects::parse_terminal {val} {
397    variable currObjDef
398    if {![string is boolean -strict $val]} {
399        error "bad value \"$val\": should be boolean"
400    }
401    $currObjDef configure -terminal $val
402}
403
404# ----------------------------------------------------------------------
405#  CLASS: ObjDef
406# ----------------------------------------------------------------------
407itcl::class Rappture::objects::ObjDef {
408    public variable inherit ""
409    public variable image ""
410    public variable help ""
411    public variable terminal "yes"
412    public variable palettes ""
413
414    constructor {args} {
415        set _checks(num) 0
416        eval configure $args
417    }
418
419    public method add {what name args} {
420        switch -- $what {
421            attr {
422                if {[info exists _attr2def($name)]} {
423                    error "attribute \"$name\" already defined"
424                }
425                set obj [Rappture::objects::ObjAttr #auto]
426                if {[catch {eval $obj configure $args} err] != 0} {
427                    itcl::delete object $obj
428                    error $err
429                }
430                lappend _attrs $name
431                set _attr2def($name) $obj
432            }
433            check {
434                set n [incr _checks(num)]
435                set _checks($n-attr) $name
436                set _checks($n-code) [lindex $args 0]
437            }
438        }
439    }
440
441    public method get {{name ""}} {
442        if {"" == $name} {
443            return $_attrs
444        } elseif {[info exists _attr2def($name)]} {
445            set rlist $name
446            foreach opt [$_attr2def($name) configure] {
447                lappend rlist [lindex $opt 0] [lindex $opt 2]
448            }
449            return $rlist
450        }
451    }
452
453    # call this to check the integrity of all values
454    public method check {data debug} {
455        set rlist ""
456        array set attr $data
457        for {set n 1} {$n <= $_checks(num)} {incr n} {
458            set status [catch $_checks($n-code) result]
459            if {$status != 0 && $status != 2} {
460                puts stderr "ERROR DURING VALUE CHECK:\n$result"
461            } elseif {[llength $result] > 0} {
462                set class [lindex $result 0]
463                set mesg [lindex $result 1]
464                set dinfo $debug
465                lappend dinfo -attribute $_checks($n-attr)
466                lappend rlist [list $class $mesg $dinfo]
467            }
468        }
469        return $rlist
470    }
471
472    private variable _attrs ""  ;# list of attr names in order
473    private variable _attr2def  ;# maps attr name => ObjAttr object
474    private variable _checks    ;# bits of code used for checks
475}
476
477# ----------------------------------------------------------------------
478#  CLASS: ObjAttr
479# ----------------------------------------------------------------------
480itcl::class Rappture::objects::ObjAttr {
481    public variable title ""
482    public variable type ""
483    public variable path ""
484    public variable expand "no"
485
486    constructor {args} {
487        eval configure $args
488    }
489}
Note: See TracBrowser for help on using the repository browser.