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

# ----------------------------------------------------------------------
#  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 valuefor {path args}
    public method dependenciesfor {path args}
    public method ownerfor {path {skip ""}}
    public method changed {path}
    public method regularize {path}
    public method notify {option owner args}
    public method sync {}
    public method tool {}

    protected method _slave {option args}

    protected variable _owner ""     ;# ControlOwner containing this one
    protected variable _path ""      ;# paths within are relative to this
    protected variable _slaves ""    ;# this owner has these slaves
    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
    private variable _dependencies   ;# maps path => other paths dep on this
}
                                                                                
# ----------------------------------------------------------------------
# CONSTRUCTOR
# ----------------------------------------------------------------------
itcl::body Rappture::ControlOwner::constructor {owner} {
    if {"" != $owner} {
        set parts [split $owner @]
        set _owner [lindex $parts 0]
        set _path [lindex $parts 1]
        $_owner _slave add $this
    }
}

# ----------------------------------------------------------------------
# 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} {
        set owner [ownerfor $path]
        if {$owner != $this && $owner != ""} {
            return [$owner widgetfor $path]
        }
        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 {
        catch {unset _path2widget($path)}
    }
}

# ----------------------------------------------------------------------
# USAGE: valuefor <path> ?<newValue>?
#
# Used by embedded widgets such as a Loader to query or set the
# value of another control.  With no extra args, it returns the
# value of the widget at the <path> in the XML.  Otherwise, it
# sets the value of the widget to <newValue>.
# ----------------------------------------------------------------------
itcl::body Rappture::ControlOwner::valuefor {path args} {
    set owner [ownerfor $path]

    # if this is a query operation, then look for the path
    if {[llength $args] == 0} {
        if {$owner != $this && $owner != ""} {
            return [$owner valuefor $path]
        }
        if {[info exists _path2widget($path)]} {
            return [$_path2widget($path) value]
        }
        # can't find the path? try removing the prefix for this owner
        set plen [string length $_path]
        if {[string equal -length $plen $_path $path]} {
            set relpath [string range $path [expr {$plen+1}] end]
            if {[info exists _path2widget($relpath)]} {
                return [$_path2widget($relpath) value]
            }
        }
        return ""
    }

    # otherwise, set the value
    if {$owner != $this && $owner != ""} {
        return [eval $owner valuefor $path $args]
    }
    if {[llength $args] > 1} {
        error "wrong # args: should be \"valuefor path ?newValue?\""
    }

    if {[info exists _path2widget($path)]} {
        $_path2widget($path) value [lindex $args 0]
    } else {
        error "bad path \"$path\": should be one of [join [lsort [array names _path2widget]] {, }]"
    }
}

# ----------------------------------------------------------------------
# USAGE: dependenciesfor <path> ?<path>...?
#
# Used by embedded widgets such as a Controls panel to register the
# various controls that are dependent on another one.  If only one
# path is specified, then this method returns all known dependencies
# for the specified <path>.  Otherwise, the additional <path>'s are
# noted as being dependent on the first <path>.
# ----------------------------------------------------------------------
itcl::body Rappture::ControlOwner::dependenciesfor {path args} {
    if {"" != $_owner} {
        #
        # Keep all dependencies at the highest level.
        # That way, a structure can come and go, but the
        # dependencies remain fixed in the topmost tool.
        #
        set plen [string length $_path]
        if {"" != $_path && ![string equal -length $plen $_path $path]} {
            set path $_path.$path
        }
        return [eval $_owner dependenciesfor $path $args]
    }

    # if this is a query operation, then look for the path
    if {[llength $args] == 0} {
        if {[info exists _dependencies($path)]} {
            return $_dependencies($path)
        }
        return ""
    }

    # add new dependencies
    if {![info exists _dependencies($path)]} {
        set _dependencies($path) ""
    }
    foreach dpath $args {
        set i [lsearch -exact $_dependencies($path) $dpath]
        if {$i < 0} {
            lappend _dependencies($path) $dpath
        }
    }
}

# ----------------------------------------------------------------------
# USAGE: ownerfor <path> ?<skip>?
#
# Returns the ControlOwner that directly controls the specified <path>.
# ----------------------------------------------------------------------
itcl::body Rappture::ControlOwner::ownerfor {path {skip ""}} {
    if {[info exists _path2widget($path)]} {
        return $this
    }

    # can't find the path? try removing the prefix for this owner
    set plen [string length $_path]
    if {[string equal -length $plen $_path $path]} {
        set relpath [string range $path [expr {$plen+1}] end]
        if {[info exists _path2widget($relpath)]} {
            return $this
        }
    }

    # couldn't find this path?  then check all subordinates
    foreach slave $_slaves {
        if {$slave == $skip} {
            continue  ;# skip this slave if it's already been searched
        }
        set rval [$slave ownerfor $path $this]
        if {"" != $rval} {
            return $rval
        }
    }

    # check the owner as a last resort
    if {"" != $_owner && $_owner != $skip} {
        set rval [$_owner ownerfor $path $this]
        if {"" != $rval} {
            return $rval
        }
    }

    return ""
}

# ----------------------------------------------------------------------
# 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] {
        # the following elements do not accept "current" tags, skip them
        set type [[tool] xml element -as type $path]
        if {[lsearch {group separator control note} $type] >= 0} {
            continue
        }

        # 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} {
        set plen [string length $_path]
        if {"" != $_path && ![string equal -length $plen $_path $path]} {
            set path $_path.$path
        }
        $_owner changed $path
    } else {
        # send out any callback notifications
        foreach owner [array names _owner2paths] {
            foreach pattern $_owner2paths($owner) {
                if {[string match $pattern $path]} {
                    uplevel #0 $_callbacks($owner/$pattern)
                    break
                }
            }
        }

        # find the control panel for each dependency, and tell it
        # to update its layout.
        foreach cpath [dependenciesfor $path] {
            set wv [widgetfor $cpath]
            while {"" != $wv} {
                set wv [winfo parent $wv]
                if {[winfo class $wv] == "Controls"} {
                    $wv refresh
                    break
                }
            }
        }
    }
}

# ----------------------------------------------------------------------
# USAGE: regularize <path>
#
# Clients use this to get a full, regularized path for the specified
# <path>, which may be relative to the current owner.
# ----------------------------------------------------------------------
itcl::body Rappture::ControlOwner::regularize {path} {
    set owner [ownerfor $path]
    if {$owner != $this && $owner != ""} {
        return [$owner regularize $path]
    }
    set rpath ""
    if {"" != $_xmlobj} {
        set rpath [$_xmlobj element -as path $path]

        # can't find the path? try removing the prefix for this owner
        if {"" == $rpath} {
            set plen [string length $_path]
            if {[string equal -length $plen $_path $path]} {
                set relpath [string range $path [expr {$plen+2}] end]
                set rpath [$_xmlobj element -as path $relpath]
            }
        }

        if {"" != $rpath && "" != $_path} {
            # return a full name for the path
            set rpath "$_path.$rpath"
        }
    }
    return $rpath
}

# ----------------------------------------------------------------------
# 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 {} {
    # sync all of the widgets under control of this owner
    if {"" != $_xmlobj} {
        foreach path [lsort [array names _path2widget]] {
            set type [$_xmlobj element -as type $path]
            if {[lsearch {group separator control note} $type] >= 0} {
                continue
            }
            $_xmlobj put $path.current [$_path2widget($path) value]
        }
    }

    # sync all subordinate slaves as well
    foreach slave $_slaves {
        $slave sync
    }
}

# ----------------------------------------------------------------------
# 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
}

# ----------------------------------------------------------------------
# USAGE: _slave add <newobj>...
#
# Used internally to register the parent-child relationship whenever
# one ControlOwner is registered to another.  When the parent syncs,
# it causes all of its children to sync.  When a name is being
# resolved, it is resolved locally first, then up to the parent for
# further resolution.
# ----------------------------------------------------------------------
itcl::body Rappture::ControlOwner::_slave {option args} {
    switch -- $option {
        add {
            eval lappend _slaves $args
        }
        default {
            error "bad option \"$option\": should be add"
        }
    }
}