source: trunk/gui/scripts/controlOwner.tcl @ 115

# ----------------------------------------------------------------------
#  COMPONENT: owner - manages Rappture controls
#
#  This object represents an entity managing Rappture controls.
#  It is typically a Tool, a DeviceEditor, or some other large entity
#  that manages a Rappture XML tree.  All controlling widgets are
#  registered with an owner, and the owner propagates notifications
#  out to clients who have an interest in a particular control.
# ======================================================================
#  AUTHOR:  Michael McLennan, Purdue University
#  Copyright (c) 2004-2005  Purdue Research Foundation
#
#  See the file "license.terms" for information on usage and
#  redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# ======================================================================
package require Itcl

itcl::class Rappture::ControlOwner {
    constructor {owner} { # defined below }

    public method xml {args}

    public method load {newobj}
    public method widgetfor {path args}
    public method changed {path}
    public method notify {option owner args}
    public method sync {}
    public method tool {}

    protected variable _owner ""     ;# ControlOwner containing this one
    protected variable _xmlobj ""    ;# Rappture XML description
    private variable _path2widget    ;# maps path => widget on this page
    private variable _owner2paths    ;# for notify: maps owner => interests
    private variable _callbacks      ;# for notify: maps owner/path => callback
}
                                                                                
# ----------------------------------------------------------------------
# CONSTRUCTOR
# ----------------------------------------------------------------------
itcl::body Rappture::ControlOwner::constructor {owner} {
    set _owner $owner
}

# ----------------------------------------------------------------------
# USAGE: xml <subcommand> ?<arg> <arg> ...?
# USAGE: xml object
#
# Used by clients to manipulate the underlying XML data for this
# tool.  The <subcommand> can be any operation supported by a
# Rappture::library object.  Clients can also request the XML object
# directly by using the "object" subcommand.
# ----------------------------------------------------------------------
itcl::body Rappture::ControlOwner::xml {args} {
    if {"object" == $args} {
        return $_xmlobj
    }
    return [eval $_xmlobj $args]
}

# ----------------------------------------------------------------------
# USAGE: widgetfor <path> ?<widget>?
#
# Used by embedded widgets such as a Controls panel to register the
# various controls associated with this page.  That way, this
# ControlOwner knows what widgets to look at when syncing itself
# to the underlying XML data.
# ----------------------------------------------------------------------
itcl::body Rappture::ControlOwner::widgetfor {path args} {
    # if this is a query operation, then look for the path
    if {[llength $args] == 0} {
        if {[info exists _path2widget($path)]} {
            return $_path2widget($path)
        }
        return ""
    }

    # otherwise, associate the path with the given widget
    set widget [lindex $args 0]
    if {"" != $widget} {
        if {[info exists _path2widget($path)]} {
            error "$path already associated with widget $_path2widget($path)"
        }
        set _path2widget($path) $widget
    } else {
        unset _path2widget($path)
    }
}

# ----------------------------------------------------------------------
# USAGE: load <xmlobj>
#
# Loads the contents of a Rappture <xmlobj> into the controls
# associated with this tool.
# ----------------------------------------------------------------------
itcl::body Rappture::ControlOwner::load {newobj} {
    if {![Rappture::library isvalid $newobj]} {
        error "\"$newobj\" is not a Rappture::library"
    }

    foreach path [array names _path2widget] {
        # copy new value to the XML tree
        [tool] xml copy $path.current from $newobj $path.current

        # also copy to the widget associated with the tree
        if {"" != [$newobj element -as type $path.current]} {
            set val [$newobj get $path.current]
            if {[string length $val] > 0
                  || [llength [$newobj children $path.current]] == 0} {
                $_path2widget($path) value $val
            } else {
                set obj [$newobj element -as object $path.current]
                $_path2widget($path) value $obj
            }
        }
    }
}

# ----------------------------------------------------------------------
# USAGE: changed <path>
#
# Invoked automatically by the various widgets associated with this
# tool whenever their value changes.  Sends notifications to any
# client that has registered an interest via "notify add".
# ----------------------------------------------------------------------
itcl::body Rappture::ControlOwner::changed {path} {
    if {"" != $_owner} {
        $_owner changed $path
    } else {
        foreach owner [array names _owner2paths] {
            foreach pattern $_owner2paths($owner) {
                if {[string match $pattern $path]} {
                    uplevel #0 $_callbacks($owner/$pattern)
                    break
                }
            }
        }
    }
}

# ----------------------------------------------------------------------
# USAGE: notify add <owner> <path> <callback>
# USAGE: notify info ?<owner>? ?<path>?
# USAGE: notify remove <owner> ?<path> ...?
#
# Clients use this to request notifications about changes to a
# particular <path> for a control under this tool.  Whenever the
# value associated with <path> changes, the client identified by
# <owner> is sent a message by invoking its <callback> routine.
#
# Notifications can be silenced by calling the "notify remove"
# function.
# ----------------------------------------------------------------------
itcl::body Rappture::ControlOwner::notify {option args} {
    switch -- $option {
        add {
            if {[llength $args] != 3} {
                error "wrong # args: should be \"notify add owner path callback\""
            }
            set owner [lindex $args 0]
            set path [lindex $args 1]
            set cb [lindex $args 2]

            if {[info exists _owner2paths($owner)]} {
                set plist $_owner2paths($owner)
            } else {
                set plist ""
            }

            set i [lsearch -exact $plist $path]
            if {$i < 0} { lappend _owner2paths($owner) $path }
            set _callbacks($owner/$path) $cb
        }
        info {
            if {[llength $args] == 0} {
                # no args? then return all owners
                return [array names _owner2paths]
            } else {
                set owner [lindex $args 0]
                if {[info exists _owner2paths($owner)]} {
                    set plist $_owner2paths($owner)
                } else {
                    set plist ""
                }
                if {[llength $args] == 1} {
                    # 1 arg? then return paths for this owner
                    return $plist
                } elseif {[llength $args] == 2} {
                    # 2 args? then return callback for this path
                    set path [lindex $args 1]
                    if {[info exists _callbacks($owner/$path)]} {
                        return $_callbacks($owner/$path)
                    }
                    return ""
                } else {
                    error "wrong # args: should be \"notify info ?owner? ?path?\""
                }
            }
        }
        remove {
            if {[llength $args] < 1} {
                error "wrong # args: should be \"notify remove owner ?path ...?\""
            }
            set owner [lindex $args 0]

            if {[llength $args] == 1} {
                # no args? then delete all paths for this owner
                if {[info exists _owner2paths($owner)]} {
                    set plist $_owner2paths($owner)
                } else {
                    set plist ""
                }
            } else {
                set plist [lrange $args 1 end]
            }

            # forget about the callback for each path
            foreach path $plist {
                catch {unset _callbacks($owner/$path)}

                if {[info exists _owner2paths($owner)]} {
                    set i [lsearch -exact $_owner2paths($owner) $path]
                    if {$i >= 0} {
                        set _owner2paths($owner) \
                            [lreplace $_owner2paths($owner) $i $i]
                    }
                }
            }
        }
    }
}

# ----------------------------------------------------------------------
# USAGE: sync
#
# Used by descendents such as a Controls panel to register the
# various controls associated with this page.  That way, this
# ControlOwner knows what widgets to look at when syncing itself
# to the underlying XML data.
# ----------------------------------------------------------------------
itcl::body Rappture::ControlOwner::sync {} {
    foreach path [array names _path2widget] {
        $_xmlobj put $path.current [$_path2widget($path) value]
    }
}

# ----------------------------------------------------------------------
# USAGE: tool
#
# Clients use this to figure out which tool is associated with
# this object.  If there is no parent ControlOwner, then this
# must be the top-level tool.
# ----------------------------------------------------------------------
itcl::body Rappture::ControlOwner::tool {} {
    if {"" != $_owner} {
        return [$_owner tool]
    }
    return $this
}