source: branches/1.6/lang/tcl/scripts/objects.tcl @ 6221

Last change on this file since 6221 was 3671, checked in by mmc, 11 years ago

Fixed the background coordinate scaling for the drawing. Now works with
either "coordinates" or "coords" and handles the "at XX% YY%" parts for
either end point.

Fixed the builder so that it doesn't warn about groups that have an empty
label. You should be able to create those sorts of invisible groups.
File size: 35.9 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-2012  HUBzero Foundation, LLC
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 clear Rappture::objects::parse_clear
54    $attrParser alias compare Rappture::objects::parse_compare
55    $attrParser alias export Rappture::objects::parse_export
56    $attrParser alias help Rappture::objects::parse_help
57    $attrParser alias import Rappture::objects::parse_import
58    $attrParser alias method Rappture::objects::parse_method
59    $attrParser alias palettes Rappture::objects::parse_palettes
60    $attrParser alias storage Rappture::objects::parse_storage
61    $attrParser alias terminal Rappture::objects::parse_terminal
62    $attrParser alias unknown Rappture::objects::parse_attr_unknown
63    proc ::Rappture::objects::parse_attr_unknown {args} {
64        error "bad option \"[lindex $args 0]\": should be attr, check, clear, compare, export, help, import, method, palettes, storage, terminal"
65    }
66
67    # this variable will hold ObjDef object as it is being built
68    variable currObjDef ""
69
70    # this variable will hold storage/import/export for object defn
71    variable currObjValDef
72
73    # this variable will hold the name of the object file being parsed
74    variable currFile ""
75}
76
77# ----------------------------------------------------------------------
78# USAGE: Rappture::objects::init
79#
80# Called at the beginning of a Rappture program to initialize the
81# object system.  Loads all object definitions in the "objects"
82# directory found at the system location.  Object types can be
83# queried by calling Rappture::objects::get.
84# ----------------------------------------------------------------------
85proc Rappture::objects::init {} {
86    variable installdir
87
88    # load supporting type definitions
89    foreach fname [glob [file join $installdir types *.tcl]] {
90        uplevel #0 source $fname
91    }
92
93    # load supporting validation procs
94    foreach fname [glob [file join $installdir validations *.tcl]] {
95        uplevel #0 source $fname
96    }
97
98    # load the base class
99    Rappture::objects::load [file join $installdir objects base.rp]
100
101    # load any other classes found
102    foreach dir [glob -nocomplain -types d [file join $installdir objects *]] {
103        Rappture::objects::load [file join $dir *.rp]
104    }
105
106    # if anyone tries to load again, do nothing
107    proc ::Rappture::objects::init {} { # already loaded }
108}
109
110# ----------------------------------------------------------------------
111# USAGE: Rappture::objects::load ?<filePattern> <filePattern> ...?
112#
113# Clients call this to load object definitions from all files that
114# match the given set of file patterns.  These may be specific
115# file names or patterns of the form "dir/*.rp".  Each object is
116# loaded and Rappture::ObjDef objects are created as a side effect
117# to represent them.  Object types can be queried by calling
118# Rappture::objects::get.
119# ----------------------------------------------------------------------
120proc Rappture::objects::load {args} {
121    variable objParser
122    variable objDefs
123    variable currFile
124
125    # scan through all matching files and load their definitions
126    foreach pattern $args {
127        foreach fname [glob -nocomplain $pattern] {
128            set currFile $fname
129            set fid [open $fname r]
130            set info [read $fid]
131            close $fid
132
133            if {[catch {$objParser eval $info} err] != 0} {
134                error $err "$err\n    (while loading object definition from file \"$fname\")"
135            }
136        }
137    }
138
139    # look at all inheritance relationships and make sure they're satisfied
140    foreach name [array names objDefs] {
141        set ilist [$objDefs($name) cget -inherit]
142        set newilist ""
143        foreach obj $ilist {
144            if {[string index $obj 0] == "@"} {
145                set tname [string range $obj 1 end]
146                if {[info exists objDefs($tname)]} {
147                    lappend newilist $objDefs($tname)
148                } else {
149                    set errs($tname) 1
150                }
151            } else {
152                lappend newilist $obj
153            }
154            $objDefs($name) configure -inherit $newilist
155        }
156    }
157
158    if {[array size errs] > 0} {
159        error "missing definition for base class: [join [lsort [array names errs]] {, }]"
160    }
161}
162
163# ----------------------------------------------------------------------
164# USAGE: Rappture::objects::get ?<name>? ?-what?
165#
166# Returns information about the known Rappture object types.
167# With no args, it returns a list of object class names.  With a
168# specified <name>, it returns all information for that object in
169# a key/value format:
170#
171#   -image xxx -palettes {xx xx xx} -attributes {{...} {...} ...}
172#   -help URL -terminal bool
173#
174# Otherwise, the -what indicates which specific value should be
175# returned.
176# ----------------------------------------------------------------------
177proc Rappture::objects::get {{name ""} {what ""}} {
178    variable objDefs
179
180    if {"" == $name} {
181        return [array names objDefs]
182    }
183
184    set name [string tolower $name]  ;# doesn't matter: Tool or tool
185    if {![info exists objDefs($name)]} {
186        error "bad object type \"$name\": should be one of [join [lsort [array names objDefs]] {, }]"
187    }
188
189    set info(-image) [$objDefs($name) cget -image]
190    set info(-help) [$objDefs($name) cget -help]
191    set info(-palettes) [$objDefs($name) cget -palettes]
192    set info(-terminal) [$objDefs($name) cget -terminal]
193
194    set rlist ""
195    foreach aname [$objDefs($name) getAttr] {
196        lappend rlist [$objDefs($name) getAttr $aname]
197    }
198    set info(-attributes) $rlist
199
200    if {"" == $what} {
201        return [array get info]
202    } elseif {[info exists info($what)]} {
203        return $info($what)
204    }
205    error "bad option \"$what\": should be [join [lsort [array names info]] {, }]"
206}
207
208# ----------------------------------------------------------------------
209# USAGE: Rappture::objects::import <xmlobj> <path>
210#
211# Tries to extract a value from the given <xmlobj> at the <path>.
212# ----------------------------------------------------------------------
213proc Rappture::objects::import {xmlobj path} {
214    set type [$xmlobj element -as type $path]
215    set ovclass "::Rappture::objects::[string totitle $type]Value"
216
217    # does this object type have a value class?
218    if {[catch {$ovclass ::#auto} obj]} {
219        return ""
220    }
221
222    # try to load the object via its xml scheme
223    if {[catch {$obj import xml $xmlobj $path} result] == 0} {
224        return $obj
225    }
226
227    # can't seem to load anything -- return null
228    itcl::delete object $obj
229    return ""
230}
231
232# ----------------------------------------------------------------------
233# USAGE: Rappture::objects::viewer <objVal>|<objDef>|<type> \
234    ?-for input|output? ?-parent win?
235#
236# Used to find/create a viewer for the given object.  The object can
237# be specified by an ObjVal object, an ObjDef object definition, or
238# a string name <type>.  The -for flag indicates whether the viewer
239# widget is for input or output.  The -parent indicates the parent
240# containing the widget.  If the widget already exists, it is returned
241# directly.  Otherwise, it is created and returned.
242# ----------------------------------------------------------------------
243proc Rappture::objects::viewer {what args} {
244    variable objDefs
245
246    # figure out the name of the desired object type
247    if {[catch {$what isa ::Rappture::objects::ObjVal} valid] == 0 && $valid} {
248        set type [[$what definition] type]
249    } elseif {[catch {$what isa ::Rappture::objects::ObjDef} valid] == 0
250                        && $valid} {
251        set type [$what type]
252    } else {
253        set type [string tolower $what]  ;# doesn't matter: Number or number
254        if {![info exists objDefs($type)]} {
255            error "bad object type \"$type\": should be one of [join [lsort [array names objDefs]] {, }]"
256        }
257    }
258
259    # process additional options
260    array set opt {
261        -for output
262        -parent "."
263    }
264    foreach {key val} $args {
265        if {![info exists opt($key)]} {
266            error "bad option \"$key\": should be [join [array names opt] {, }]"
267        }
268        set opt($key) $val
269    }
270    if {![winfo exists $opt(-parent)]} {
271        error "bad parent window \"$opt(-parent)\""
272    }
273    if {$opt(-parent) eq "."} {
274        set opt(-parent) ""  ;# avoid ".." below when we say: $parent.foo
275    }
276    if {[lsearch {input output} $opt(-for)] < 0} {
277        error "bad value \"$opt(-for)\": should be input, output"
278    }
279
280    # build the class name and widget name:
281    #   class: Rappture::objects::CurveOutput
282    #  widget: .foo.bar.curveOutput
283    set which [string totitle $opt(-for)]
284    set class "::Rappture::objects::[string totitle $type]$which"
285    set win "$opt(-parent).v$type$opt(-for)"
286
287    if {[winfo exists $win]} {
288        return $win
289    }
290    if {[catch {$class $win} err] == 0} {
291        return $win
292    }
293    return ""
294}
295
296# ----------------------------------------------------------------------
297# USAGE: Rappture::objects::palettes
298#
299# Returns a list of unique palette names from all known types.
300# ----------------------------------------------------------------------
301proc Rappture::objects::palettes {} {
302    variable objDefs
303
304    foreach name [array names objDefs] {
305        foreach pname [$objDefs($name) cget -palettes] {
306            set unique($pname) 1
307        }
308    }
309    return [lsort -dictionary [array names unique]]
310}
311
312# ----------------------------------------------------------------------
313# USAGE: Rappture::objects::check <type> <side> {<key> <val>...} <debugInfo>
314#
315# Checks the definition for an object of the given <type> to see if
316# there are any errors in the values.  The <side> indicates whether
317# it is an input or an output.  Some attributes don't apply when an
318# object is an output.  The current attribute values are specified as
319# a key/value list.  Returns a list of the form:
320#   error "something went wrong"
321#   warning "might check this"
322# ----------------------------------------------------------------------
323proc Rappture::objects::check {type side attrinfo debug} {
324    variable objDefs
325
326    set type [string tolower $type]  ;# doesn't matter: Tool or tool
327
328    if {[info exists objDefs($type)]} {
329        return [$objDefs($type) check $side $attrinfo $debug]
330    }
331    return ""
332}
333
334# ----------------------------------------------------------------------
335# PARSER:  Rappture::objects::parse_object
336#
337# Used internally to parse the definition of a Rappture object type:
338#
339#   object <name> ?-extends <type>? {
340#     attr <name> <args>...
341#     attr <name> <args>...
342#     ...
343#   }
344#
345# Builds an object in currObjDef and then registers the completed
346# object in the objDefs array.
347# ----------------------------------------------------------------------
348proc Rappture::objects::parse_object {args} {
349    variable currObjDef
350    variable currObjValDef
351    variable currFile
352    variable objDefs
353    variable attrParser
354
355    set name [lindex $args 0]
356    set args [lrange $args 1 end]
357
358    set ilist ""
359    while {1} {
360        set first [lindex $args 0]
361        if {[string index $first 0] != "-"} {
362            break
363        }
364        if {"-extends" == $first} {
365            set base [lindex $args 1]
366            set args [lrange $args 2 end]
367            lappend ilist @$base
368        } else {
369            error "bad option \"$first\": should be -extends"
370        }
371    }
372
373    if {[llength $args] != 1} {
374        error "wrong # args: should be \"object name ?-extends base? {...definition...}\""
375    }
376    set body [lindex $args end]
377
378    # create an object definition and add attributes to it
379    catch {unset currObjValDef}
380    array set currObjValDef {
381        clear ""
382        compare ""
383        storage ""
384        import ""
385        export ""
386        method ""
387    }
388
389    set currObjDef [Rappture::objects::ObjDef ::#auto $name -inherit $ilist]
390
391    set cmds {
392        # parse attribute definitions
393        $attrParser eval $body
394
395        # look for an image for this object
396        set rootf [file rootname $currFile]
397        foreach ext {png jpg gif} {
398            if {[file readable $rootf.$ext] &&
399                [catch {package present Tk}] == 0 &&
400                [catch {package present Img}] == 0} {
401                set imh [image create photo -file $rootf.$ext]
402                $currObjDef configure -image $imh
403                break
404            }
405        }
406
407        #
408        # Create a class to manage the object's value...
409        #
410        set ovdefn "inherit ::Rappture::objects::ObjVal\n"
411        append ovdefn $currObjValDef(storage) "\n"
412        append ovdefn "destructor { clear }\n"
413        append ovdefn "public method clear {} [list $currObjValDef(clear)]\n"
414        append ovdefn "public method definition {} {return $currObjDef}\n"
415
416        # define extra methods added specially to this object
417        foreach mn $currObjValDef(method) {
418            append ovdefn [list public method $mn $currObjValDef(m-$mn-arglist) $currObjValDef(m-$mn-body)] "\n"
419        }
420
421        append ovdefn [format "private method importTypes {} { return %s }\n" [list $currObjValDef(import)]]
422        append ovdefn [format "private method exportTypes {} { return %s }\n" [list $currObjValDef(export)]]
423
424        # define methods to handle each import type
425        foreach fmt $currObjValDef(import) {
426            append ovdefn [list public method import_$fmt $currObjValDef(im-$fmt-arglist) $currObjValDef(im-$fmt-body)] "\n"
427        }
428
429        # define methods to handle each export type
430        foreach fmt $currObjValDef(export) {
431            append ovdefn [list public method export_$fmt $currObjValDef(ex-$fmt-arglist) $currObjValDef(ex-$fmt-body)] "\n"
432        }
433
434        # define the "compare" method
435        set varcode ""
436        foreach line [split $currObjValDef(storage) \n] {
437            if {[regexp {(?:variable|common) +([a-zA-Z0-9_]+)} $line match var]} {
438                append varcode "_linkvar import \$obj $var\n"
439            }
440        }
441        if {$currObjValDef(compare) eq ""} {
442            set currObjValDef(compare) "return 1"
443        }
444        append ovdefn [format { public method compare {obj} { %s %s }
445            } $varcode $currObjValDef(compare)] "\n"
446
447        append ovdefn {
448            # utility used in "compare" method
449            # this must be defined in each derived class at the most
450            # specific scope, so that it has access to all of the storage
451            # variables for the class.  If it's defined in the base class,
452            # then it sees only the base class variables.
453            protected method _linkvar {option args} {
454              switch -- $option {
455                export {
456                    #
457                    # Look for the variable in the current object scope
458                    # and return a command that can be used to rebuild it.
459                    #
460                    set vname [lindex $args 0]
461                    set suffix [lindex $args 1]
462                    if {[array exists $vname]} {
463                        return [list array set ${vname}${suffix} [array get $vname]]
464                    } elseif {[info exists $vname]} {
465                        return [list set ${vname}${suffix} [set $vname]]
466                    } else {
467                        return [list set ${vname}${suffix} ""]
468                    }
469                }
470                import {
471                    #
472                    # The "_linkvar export" command produces a script that
473                    # will replicate the variable.  Invoke this script in
474                    # the calling context (uplevel) to copy the variable
475                    # to the proper call stack.
476                    #
477                    set obj [lindex $args 0]
478                    set vname [lindex $args 1]
479                    uplevel [$obj _linkvar export $vname 2]
480                }
481                default {
482                    error "bad option \"$option\": should be import, export"
483                }
484              }
485            }
486        }
487
488        # create the object value class
489        itcl::class "::Rappture::objects::[string totitle $name]Value" $ovdefn
490    }
491
492    if {[catch $cmds err] != 0} {
493        itcl::delete object $currObjDef
494        set currObjDef ""
495        error $err "\n    (while loading object definition for \"$name\")"
496    }
497
498    set objDefs($name) $currObjDef
499    set currObjDef ""
500}
501
502# ----------------------------------------------------------------------
503# PARSER:  Rappture::objects::parse_attr
504#
505# Used internally to parse the definition of an attribute within a
506# Rappture object definition:
507#
508#   attr <name> -title <string> -type <string> -path <string>
509#
510# Adds an attribute definition to the object in currObjDef.
511# ----------------------------------------------------------------------
512proc Rappture::objects::parse_attr {args} {
513    variable currObjDef
514
515    set name [lindex $args 0]
516    eval $currObjDef add attr $name [lrange $args 1 end]
517}
518
519# ----------------------------------------------------------------------
520# PARSER:  Rappture::objects::parse_check
521#
522# Used internally to register a bit of code that's used to check the
523# integrity of a value.
524#
525#   check attr { code... }
526#
527# The code assumes that attribute values are stored in an attr(...)
528# array.  It checks the values and returns errors in the following
529# format:
530#   error "something went wrong" {-node 2 -counter 7 -attr label}
531#   warning "watch out for this" {-node 8 -counter 1 -attr description}
532# ----------------------------------------------------------------------
533proc Rappture::objects::parse_check {attr code} {
534    variable currObjDef
535    $currObjDef add check $attr $code
536}
537
538# ----------------------------------------------------------------------
539# PARSER:  Rappture::objects::parse_clear
540#
541# Used internally to parse the definition of a clear block within a
542# Rappture object definition:
543#
544#   clear <body>
545#
546# The clear block is a block of code that clears the storage variables
547# before a new import operation, or whenever the object is destroyed.
548# Frees any objects stored in the storage variables.
549# ----------------------------------------------------------------------
550proc Rappture::objects::parse_clear {body} {
551    variable currObjValDef
552
553    if {$currObjValDef(clear) ne ""} {
554        error "clear block already defined"
555    }
556    set currObjValDef(clear) $body
557}
558
559# ----------------------------------------------------------------------
560# PARSER:  Rappture::objects::parse_compare
561#
562# Used internally to parse the definition of a compare block for the
563# object value within a Rappture object definition:
564#
565#   compare <body>
566#
567# The compare block is a block of code that compares the value of
568# the current object to another object, and returns -1/0/1, similar
569# to str_cmp.
570# ----------------------------------------------------------------------
571proc Rappture::objects::parse_compare {body} {
572    variable currObjValDef
573
574    if {$currObjValDef(compare) ne ""} {
575        error "compare block already defined"
576    }
577    set currObjValDef(compare) $body
578}
579
580# ----------------------------------------------------------------------
581# PARSER:  Rappture::objects::parse_export
582#
583# Used internally to parse the definition of an export scheme within
584# a Rappture object definition:
585#
586#   export <name> <arglist> <body>
587#
588# The export <name> defines a data type that the object's value can
589# be exported to.  The <arglist> arguments include the XML object, the
590# file handle, etc, depending on the export type.  The <body> is a
591# body of code invoked to handle the export operation.
592# ----------------------------------------------------------------------
593proc Rappture::objects::parse_export {name arglist body} {
594    variable currObjValDef
595
596    set i [lsearch $currObjValDef(export) $name]
597    if {$i >= 0} {
598        error "export type \"$name\" already defined"
599    }
600    lappend currObjValDef(export) $name
601    set currObjValDef(ex-$name-arglist) $arglist
602    set currObjValDef(ex-$name-body) $body
603}
604
605# ----------------------------------------------------------------------
606# PARSER:  Rappture::objects::parse_help
607#
608# Used internally to parse the definition of the help page URL for a
609# Rappture object definition:
610#
611#   help <url>
612#
613# Keeps the <url> around so it can be displayed later in a "Help"
614# button on the attribute editor.
615# ----------------------------------------------------------------------
616proc Rappture::objects::parse_help {url} {
617    variable currObjDef
618    if {![regexp {^https?://} $url]} {
619        error "bad value \"$url\": should be a URL for the help page"
620    }
621    $currObjDef configure -help $url
622}
623
624# ----------------------------------------------------------------------
625# PARSER:  Rappture::objects::parse_import
626#
627# Used internally to parse the definition of an import scheme within
628# a Rappture object definition:
629#
630#   import <name> <arglist> <body>
631#
632# The import <name> defines a data type that the object's value can
633# be imported to.  The <arglist> arguments include the XML object, the
634# file handle, etc, depending on the import type.  The <body> is a
635# body of code invoked to handle the import operation.
636# ----------------------------------------------------------------------
637proc Rappture::objects::parse_import {name arglist body} {
638    variable currObjValDef
639
640    set i [lsearch $currObjValDef(import) $name]
641    if {$i >= 0} {
642        error "import type \"$name\" already defined"
643    }
644    lappend currObjValDef(import) $name
645    set currObjValDef(im-$name-arglist) $arglist
646    set currObjValDef(im-$name-body) $body
647}
648
649# ----------------------------------------------------------------------
650# PARSER:  Rappture::objects::parse_method
651#
652# Used internally to parse the definition of an object method within
653# a Rappture object definition:
654#
655#   method <name> <arglist> <body>
656#
657# A method is an extra function supported by this object, used to
658# query or modify the object value (usually by the GUI viewer).
659# The <arglist> defines the arguments to the method, and the <body>
660# is the body of code invoked to implement the method.
661# ----------------------------------------------------------------------
662proc Rappture::objects::parse_method {name arglist body} {
663    variable currObjValDef
664
665    set i [lsearch $currObjValDef(method) $name]
666    if {$i >= 0} {
667        error "method \"$name\" already defined"
668    }
669    lappend currObjValDef(method) $name
670    set currObjValDef(m-$name-arglist) $arglist
671    set currObjValDef(m-$name-body) $body
672}
673
674# ----------------------------------------------------------------------
675# PARSER:  Rappture::objects::parse_palettes
676#
677# Used internally to parse the definition of the palettes for a
678# Rappture object definition:
679#
680#   palettes <name> <name> ...
681#
682# Adds the list of palettes to the object definition.  This determines
683# what palettes of controls will contain this object.
684# ----------------------------------------------------------------------
685proc Rappture::objects::parse_palettes {args} {
686    variable currObjDef
687    $currObjDef configure -palettes $args
688}
689
690# ----------------------------------------------------------------------
691# PARSER:  Rappture::objects::parse_storage
692#
693# Used internally to parse the definition of a storage block for the
694# object value within a Rappture object definition:
695#
696#   storage {
697#       private variable ...
698#   }
699#
700# The storage block is added directly to a class defined to hold the
701# object value.  Import/export code moves values into and out of the
702# storage area.
703# ----------------------------------------------------------------------
704proc Rappture::objects::parse_storage {body} {
705    variable currObjValDef
706
707    if {$currObjValDef(storage) ne ""} {
708        error "storage block already defined"
709    }
710    set currObjValDef(storage) $body
711}
712
713# ----------------------------------------------------------------------
714# PARSER:  Rappture::objects::parse_terminal
715#
716# Used internally to parse the "terminal" setting within a Rappture
717# object definition:
718#
719#   terminal yes|no
720#
721# Sets the Boolean value, which determines whether or not this object
722# can have other objects embedded within it.  If it is "terminal",
723# an object is a leaf node.
724# ----------------------------------------------------------------------
725proc Rappture::objects::parse_terminal {val} {
726    variable currObjDef
727    if {![string is boolean -strict $val]} {
728        error "bad value \"$val\": should be boolean"
729    }
730    $currObjDef configure -terminal $val
731}
732
733# ----------------------------------------------------------------------
734#  CLASS: ObjDef
735# ----------------------------------------------------------------------
736itcl::class Rappture::objects::ObjDef {
737    public variable inherit ""
738    public variable image ""
739    public variable help ""
740    public variable terminal "yes"
741    public variable palettes ""
742
743    constructor {type args} {
744        set _type $type
745        set _checks(num) 0
746        eval configure $args
747    }
748
749    public method type {} {
750        return $_type
751    }
752
753    public method add {what name args} {
754        switch -- $what {
755            attr {
756                if {[info exists _attr2def($name)]} {
757                    error "attribute \"$name\" already defined"
758                }
759                set obj [Rappture::objects::ObjAttr #auto]
760                if {[catch {eval $obj configure $args} err] != 0} {
761                    itcl::delete object $obj
762                    error $err
763                }
764                lappend _attrs $name
765                set _attr2def($name) $obj
766            }
767            check {
768                set n [incr _checks(num)]
769                set _checks($n-attr) $name
770                set _checks($n-code) [lindex $args 0]
771            }
772        }
773    }
774
775    public method getAttr {args} {
776        if {[llength $args] == 0} {
777            set rlist ""
778            foreach baseobj [cget -inherit] {
779                eval lappend rlist [$baseobj getAttr]
780            }
781            eval lappend rlist $_attrs
782            return $rlist
783        } elseif {[llength $args] > 2} {
784            error "wrong # args: should be \"getAttr ?name? ?-part?\""
785        }
786
787        set name [lindex $args 0]
788        set part [lindex $args 1]
789
790        # handle attributes defined right in this class
791        if {[info exists _attr2def($name)]} {
792            set rlist $name
793            foreach opt [$_attr2def($name) configure] {
794                if {[lindex $opt 0] eq $part} {
795                    return [lindex $opt 2]
796                }
797                lappend rlist [lindex $opt 0] [lindex $opt 2]
798            }
799            return $rlist
800        }
801
802        # handle attributes defined in a base class
803        foreach baseobj [cget -inherit] {
804            set rval [eval $baseobj getAttr $name $part]
805            if {$rval ne ""} {
806                return $rval
807            }
808        }
809        return ""
810    }
811
812    # call this to check the integrity of all values
813    public method check {side data debug {extra ""}} {
814        set rlist ""
815        array set attr $data
816
817        # code snippets sometimes use this object info
818        if {$extra ne ""} {
819            array set object $extra
820        } else {
821            array set object [list type [type] palettes $palettes help $help checked ""]
822        }
823
824        # do checks defined in the current class
825        for {set n 1} {$n <= $_checks(num)} {incr n} {
826            set aname $_checks($n-attr)
827
828            # if we already did this check on a derived class, then skip it
829            # derived classes override the base class
830            if {[lsearch $object(checked) $aname] >= 0} {
831                continue
832            }
833
834            # look at the -only option and see if the check applies here
835            set only [getAttr $aname -only]
836            if {$only ne "" && [lsearch $only $side] < 0} {
837                continue
838            }
839
840            # execute the code to look for errors in the value
841            set status [catch $_checks($n-code) result]
842            lappend object(checked) $aname
843
844            if {$status != 0 && $status != 2} {
845                puts stderr "ERROR DURING VALUE CHECK:\n$result"
846            } elseif {[llength $result] > 0} {
847                set class [lindex $result 0]
848                set mesg [lindex $result 1]
849                set dinfo $debug
850                lappend dinfo -attribute $aname
851                lappend rlist [list $class $mesg $dinfo]
852            }
853        }
854
855        # handle checks defined in a base class
856        foreach baseobj [cget -inherit] {
857            eval lappend rlist [$baseobj check $side $data $debug [array get object]]
858        }
859
860        return $rlist
861    }
862
863    private variable _type ""   ;# type name (lowercase) for object type
864    private variable _attrs ""  ;# list of attr names in order
865    private variable _attr2def  ;# maps attr name => ObjAttr object
866    private variable _checks    ;# bits of code used for checks
867}
868
869# ----------------------------------------------------------------------
870#  CLASS: ObjAttr
871# ----------------------------------------------------------------------
872itcl::class Rappture::objects::ObjAttr {
873    public variable title ""
874    public variable type ""
875    public variable path ""
876    public variable only ""
877    public variable expand "no"
878    public variable tooltip ""
879
880    constructor {args} {
881        eval configure $args
882    }
883}
884
885# ----------------------------------------------------------------------
886#  CLASS: ObjVal
887#  Able to import/export the value for a particular object class.
888# ----------------------------------------------------------------------
889itcl::class Rappture::objects::ObjVal {
890    public method definition {} { # returns the ObjDef class for this value }
891
892    public method attr {option args} {
893        switch -- $option {
894            get {
895                if {[llength $args] == 0} {
896                    return [[$this definition] getAttr]
897                } elseif {[llength $args] == 1} {
898                    set name [lindex $args 0]
899                    if {[catch {[$this definition] getAttr $name}]} {
900                        error "attribute \"$name\" not defined on $this"
901                    }
902                    if {[info exists attr($name)]} {
903                        return $attr($name)
904                    }
905                    return ""
906                } else {
907                    error "wrong # args: should be \"attr get ?name?\""
908                }
909            }
910            set {
911                if {[llength $args] != 2} {
912                    error "wrong # args: should be \"attr set name value\""
913                }
914                set name [lindex $args 0]
915                set val [lindex $args 1]
916                if {[catch {[$this definition] getAttr $name}] == 0} {
917                    set attr($name) $val
918                }
919                return $val
920            }
921            info {
922                if {[llength $args] == 1} {
923                    set name [lindex $args 0]
924                    return [[$this definition] getAttr $name]
925                } else {
926                    error "wrong # args: should be \"attr info name\""
927                }
928            }
929            import {
930                if {[llength $args] != 2} {
931                    error "wrong # args: should be \"attr import xmlobj path\""
932                }
933                set xmlobj [lindex $args 0]
934                set path [lindex $args 1]
935
936                set odef [$this definition]
937                foreach name [$odef getAttr] {
938                    set tail [$odef getAttr $name -path]
939                    set apath $path.$tail
940                    if {[$xmlobj element -as type $apath] ne ""} {
941                        set attr($name) [$xmlobj get $apath]
942                    }
943                }
944            }
945            export {
946                if {[llength $args] != 2} {
947                    error "wrong # args: should be \"attr export xmlobj path\""
948                }
949                set xmlobj [lindex $args 0]
950                set path [lindex $args 1]
951
952                set odef [$this definition]
953                foreach name [$odef getAttr] {
954                    if {[info exists attr($name)]} {
955                        set tail [$odef getAttr $name -path]
956                        $xmlobj put $path.$tail $attr($name)
957                    }
958                }
959            }
960            default {
961                error "bad option \"$option\": should be get, set, info, import, export"
962            }
963        }
964    }
965    protected variable attr  ;# maps attribute name => value
966
967    public method clear {} { # nothing to do for base class }
968
969    public method import {pattern args} {
970        clear
971        set errs ""
972
973        # scan through all matching types and try to import the value
974        foreach type [importTypes] {
975            if {[string match $pattern $type]} {
976                set cmd [format {eval $this import_%s $args} $type]
977                if {[catch $cmd result] == 0} {
978                    return 1
979                }
980                lappend errs "not $type: $result"
981            }
982        }
983        return [concat 0 $errs]
984    }
985
986    public method export {pattern args} {
987        set errs ""
988
989        # scan through all matching types and try to export the value
990        foreach type [exportTypes] {
991            if {[string match $pattern $type]} {
992                set cmd {uplevel $this export_$type $args}
993                if {[catch $cmd result] == 0} {
994                    return 1
995                }
996                lappend errs "not $type: $result"
997            }
998        }
999        return [concat 0 $errs]
1000    }
1001
1002    private method importTypes {} { # derived classes override this }
1003    private method exportTypes {} { # derived classes override this }
1004
1005    # utility used in "compare" method
1006    # links a variable $vname from object $obj into the current scope
1007    # with a similar variable name, but with $suffix on the end
1008    #
1009    # usage: _linkvar import _foo 2
1010    #
1011    # this triggers a call to "$obj _linkvar export" to produce a command
1012    # that can be used to rebuild the desired variable from $obj into the
1013    # local context.
1014    #
1015    # the _linkvar method must be defined in each derived class so that
1016    # it has access to variables in the most-specific object context.
1017    protected method _linkvar {option args} {
1018        error "derived classes should override this method"
1019    }
1020
1021    # utility to compare two double-prec numbers within a tolerance
1022    proc cmpdbl {num1 num2 {max ""}} {
1023        set mag [expr {0.5*(abs($num1)+abs($num2))}]
1024        set diff [expr {abs($num1-$num2)}]
1025
1026        if {$diff <= 1e-6*$mag} {
1027            # very small difference
1028            return 0
1029        } elseif {$max ne "" && $mag <= 1e-6*abs($max)} {
1030            # very small numbers -- treat them as zero
1031            return 0
1032        } elseif {$num1 < $num2} {
1033            return -1
1034        } else {
1035            return 1
1036        }
1037    }
1038}
Note: See TracBrowser for help on using the repository browser.