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

Last change on this file since 3177 was 3177, checked in by mmc, 12 years ago

Updated all of the copyright notices to reference the transfer to
the new HUBzero Foundation, LLC.
File size: 35.6 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]
822        }
823
824        # handle checks defined in a base class
825        foreach baseobj [cget -inherit] {
826            eval lappend rlist [$baseobj check $side $data $debug [array get object]]
827        }
828
829        # add checks defined in the current class
830        for {set n 1} {$n <= $_checks(num)} {incr n} {
831            # look at the -only option and see if the check applies here
832            set aname $_checks($n-attr)
833            set only [getAttr $aname -only]
834            if {$only ne "" && [lsearch $only $side] < 0} {
835                continue
836            }
837
838            # execute the code to look for errors in the value
839            set status [catch $_checks($n-code) result]
840            if {$status != 0 && $status != 2} {
841                puts stderr "ERROR DURING VALUE CHECK:\n$result"
842            } elseif {[llength $result] > 0} {
843                set class [lindex $result 0]
844                set mesg [lindex $result 1]
845                set dinfo $debug
846                lappend dinfo -attribute $aname
847                lappend rlist [list $class $mesg $dinfo]
848            }
849        }
850        return $rlist
851    }
852
853    private variable _type ""   ;# type name (lowercase) for object type
854    private variable _attrs ""  ;# list of attr names in order
855    private variable _attr2def  ;# maps attr name => ObjAttr object
856    private variable _checks    ;# bits of code used for checks
857}
858
859# ----------------------------------------------------------------------
860#  CLASS: ObjAttr
861# ----------------------------------------------------------------------
862itcl::class Rappture::objects::ObjAttr {
863    public variable title ""
864    public variable type ""
865    public variable path ""
866    public variable only ""
867    public variable expand "no"
868    public variable tooltip ""
869
870    constructor {args} {
871        eval configure $args
872    }
873}
874
875# ----------------------------------------------------------------------
876#  CLASS: ObjVal
877#  Able to import/export the value for a particular object class.
878# ----------------------------------------------------------------------
879itcl::class Rappture::objects::ObjVal {
880    public method definition {} { # returns the ObjDef class for this value }
881
882    public method attr {option args} {
883        switch -- $option {
884            get {
885                if {[llength $args] == 0} {
886                    return [[$this definition] getAttr]
887                } elseif {[llength $args] == 1} {
888                    set name [lindex $args 0]
889                    if {[catch {[$this definition] getAttr $name}]} {
890                        error "attribute \"$name\" not defined on $this"
891                    }
892                    if {[info exists attr($name)]} {
893                        return $attr($name)
894                    }
895                    return ""
896                } else {
897                    error "wrong # args: should be \"attr get ?name?\""
898                }
899            }
900            set {
901                if {[llength $args] != 2} {
902                    error "wrong # args: should be \"attr set name value\""
903                }
904                set name [lindex $args 0]
905                set val [lindex $args 1]
906                if {[catch {[$this definition] getAttr $name}] == 0} {
907                    set attr($name) $val
908                }
909                return $val
910            }
911            info {
912                if {[llength $args] == 1} {
913                    set name [lindex $args 0]
914                    return [[$this definition] getAttr $name]
915                } else {
916                    error "wrong # args: should be \"attr info name\""
917                }
918            }
919            import {
920                if {[llength $args] != 2} {
921                    error "wrong # args: should be \"attr import xmlobj path\""
922                }
923                set xmlobj [lindex $args 0]
924                set path [lindex $args 1]
925
926                set odef [$this definition]
927                foreach name [$odef getAttr] {
928                    set tail [$odef getAttr $name -path]
929                    set apath $path.$tail
930                    if {[$xmlobj element -as type $apath] ne ""} {
931                        set attr($name) [$xmlobj get $apath]
932                    }
933                }
934            }
935            export {
936                if {[llength $args] != 2} {
937                    error "wrong # args: should be \"attr export xmlobj path\""
938                }
939                set xmlobj [lindex $args 0]
940                set path [lindex $args 1]
941
942                set odef [$this definition]
943                foreach name [$odef getAttr] {
944                    if {[info exists attr($name)]} {
945                        set tail [$odef getAttr $name -path]
946                        $xmlobj put $path.$tail $attr($name)
947                    }
948                }
949            }
950            default {
951                error "bad option \"$option\": should be get, set, info, import, export"
952            }
953        }
954    }
955    protected variable attr  ;# maps attribute name => value
956
957    public method clear {} { # nothing to do for base class }
958
959    public method import {pattern args} {
960        clear
961        set errs ""
962
963        # scan through all matching types and try to import the value
964        foreach type [importTypes] {
965            if {[string match $pattern $type]} {
966                set cmd [format {eval $this import_%s $args} $type]
967                if {[catch $cmd result] == 0} {
968                    return 1
969                }
970                lappend errs "not $type: $result"
971            }
972        }
973        return [concat 0 $errs]
974    }
975
976    public method export {pattern args} {
977        set errs ""
978
979        # scan through all matching types and try to export the value
980        foreach type [exportTypes] {
981            if {[string match $pattern $type]} {
982                set cmd {uplevel $this export_$type $args}
983                if {[catch $cmd result] == 0} {
984                    return 1
985                }
986                lappend errs "not $type: $result"
987            }
988        }
989        return [concat 0 $errs]
990    }
991
992    private method importTypes {} { # derived classes override this }
993    private method exportTypes {} { # derived classes override this }
994
995    # utility used in "compare" method
996    # links a variable $vname from object $obj into the current scope
997    # with a similar variable name, but with $suffix on the end
998    #
999    # usage: _linkvar import _foo 2
1000    #
1001    # this triggers a call to "$obj _linkvar export" to produce a command
1002    # that can be used to rebuild the desired variable from $obj into the
1003    # local context.
1004    #
1005    # the _linkvar method must be defined in each derived class so that
1006    # it has access to variables in the most-specific object context.
1007    protected method _linkvar {option args} {
1008        error "derived classes should override this method"
1009    }
1010
1011    # utility to compare two double-prec numbers within a tolerance
1012    proc cmpdbl {num1 num2 {max ""}} {
1013        set mag [expr {0.5*(abs($num1)+abs($num2))}]
1014        set diff [expr {abs($num1-$num2)}]
1015
1016        if {$diff <= 1e-6*$mag} {
1017            # very small difference
1018            return 0
1019        } elseif {$max ne "" && $mag <= 1e-6*abs($max)} {
1020            # very small numbers -- treat them as zero
1021            return 0
1022        } elseif {$num1 < $num2} {
1023            return -1
1024        } else {
1025            return 1
1026        }
1027    }
1028}
Note: See TracBrowser for help on using the repository browser.