iwidgets4 4.0.1-6 / usr / share / tcltk / iwidgets4.0.1 / scripts / shell.itk

# Shell
# ----------------------------------------------------------------------
# This class is implements a shell which is a top level widget
# giving a childsite and providing activate, deactivate, and center 
# methods.
#    
# ----------------------------------------------------------------------
#  AUTHOR: Mark L. Ulferts              EMAIL: mulferts@austin.dsccc.com
#          Kris Raney                   EMAIL: kraney@spd.dsccc.com
#
#  @(#) $Id: shell.itk,v 1.7 2002/02/25 06:43:26 mgbacke Exp $
# ----------------------------------------------------------------------
#            Copyright (c) 1996 DSC Technologies Corporation
# ======================================================================
# Permission to use, copy, modify, distribute and license this software 
# and its documentation for any purpose, and without fee or written 
# agreement with DSC, is hereby granted, provided that the above copyright 
# notice appears in all copies and that both the copyright notice and 
# warranty disclaimer below appear in supporting documentation, and that 
# the names of DSC Technologies Corporation or DSC Communications 
# Corporation not be used in advertising or publicity pertaining to the 
# software without specific, written prior permission.
# 
# DSC DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING 
# ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, AND NON-
# INFRINGEMENT. THIS SOFTWARE IS PROVIDED ON AN "AS IS" BASIS, AND THE
# AUTHORS AND DISTRIBUTORS HAVE NO OBLIGATION TO PROVIDE MAINTENANCE, 
# SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. IN NO EVENT SHALL 
# DSC BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR 
# ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, 
# WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTUOUS ACTION,
# ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS 
# SOFTWARE.
# ======================================================================
 
#
# Usual options.
#
itk::usual Shell {
    keep -background -cursor -modality 
}
 
# ------------------------------------------------------------------
#                            SHELL
# ------------------------------------------------------------------
itcl::class iwidgets::Shell {
    inherit itk::Toplevel
 
    constructor {args} {}
 
    itk_option define -master master Window "" 
    itk_option define -modality modality Modality none
    itk_option define -padx padX Pad 0
    itk_option define -pady padY Pad 0
    itk_option define -width width Width 0
    itk_option define -height height Height 0
 
    public method childsite {}
    public method activate {}
    public method deactivate {args}
    public method center {{widget {}}}
 
    private variable _result {}     ;# Resultant value for modal activation.
    private variable _busied {}     ;# List of busied top level widgets.

    common grabstack {}
    common _wait
}

#
# Provide a lowercased access method for the Shell class.
# 
proc ::iwidgets::shell {pathName args} {
    uplevel ::iwidgets::Shell $pathName $args
}

# ------------------------------------------------------------------
#                        CONSTRUCTOR
# ------------------------------------------------------------------
itcl::body iwidgets::Shell::constructor {args} {
    itk_option add hull.width hull.height

    #
    # Maintain a withdrawn state until activated.  
    #
    wm withdraw $itk_component(hull)
    
    #
    # Create the user child site
    #
    itk_component add -protected shellchildsite {
        frame $itk_interior.shellchildsite
    } 
    pack $itk_component(shellchildsite) -fill both -expand yes

    #
    # Set the itk_interior variable to be the childsite for derived 
    # classes.
    #
    set itk_interior $itk_component(shellchildsite)

    #
    # Bind the window manager delete protocol to deactivation of the 
    # widget.  This can be overridden by the user via the execution 
    # of a similar command outside the class.
    #
    wm protocol $itk_component(hull) WM_DELETE_WINDOW [itcl::code $this deactivate]
    
    #
    # Initialize the widget based on the command line options.
    #
    eval itk_initialize $args
}

# ------------------------------------------------------------------
#                             OPTIONS
# ------------------------------------------------------------------
 
# ------------------------------------------------------------------
# OPTION: -master
#
# Specifies the master window for the shell.  The window manager is
# informed that the shell is a transient window whose master is
# -masterwindow.
# ------------------------------------------------------------------
itcl::configbody iwidgets::Shell::master {}

# ------------------------------------------------------------------
# OPTION: -modality
#
# Specify the modality of the dialog.
# ------------------------------------------------------------------
itcl::configbody iwidgets::Shell::modality {
    switch $itk_option(-modality) {
        none -
        application -
        global {
        }
        
        default {
            error "bad modality option \"$itk_option(-modality)\":\
                    should be none, application, or global"
        }
    }
}
 
# ------------------------------------------------------------------
# OPTION: -padx
#
# Specifies a padding distance for the childsite in the X-direction.
# ------------------------------------------------------------------
itcl::configbody iwidgets::Shell::padx {
    pack config $itk_component(shellchildsite) -padx $itk_option(-padx)
}
 
# ------------------------------------------------------------------
# OPTION: -pady
#
# Specifies a padding distance for the childsite in the Y-direction.
# ------------------------------------------------------------------
itcl::configbody iwidgets::Shell::pady {
    pack config $itk_component(shellchildsite) -pady $itk_option(-pady)
}

# ------------------------------------------------------------------
# OPTION: -width
#
# Specifies the width of the shell.  The value may be specified in 
# any of the forms acceptable to Tk_GetPixels.  A value of zero 
# causes the width to be adjusted to the required value based on 
# the size requests of the components placed in the childsite.  
# Otherwise, the width is fixed.
# ------------------------------------------------------------------
itcl::configbody iwidgets::Shell::width {
    #
    # The width option was added to the hull in the constructor.
    # So, any width value given is passed automatically to the
    # hull.  All we have to do is play with the propagation.
    #
    if {$itk_option(-width) != 0} {
    pack propagate $itk_component(hull) no
    } else {
    pack propagate $itk_component(hull) yes
    }
}

# ------------------------------------------------------------------
# OPTION: -height
#
# Specifies the height of the shell.  The value may be specified in 
# any of the forms acceptable to Tk_GetPixels.  A value of zero 
# causes the height to be adjusted to the required value based on 
# the size requests of the components placed in the childsite.
# Otherwise, the height is fixed.
# ------------------------------------------------------------------
itcl::configbody iwidgets::Shell::height {
    #
    # The height option was added to the hull in the constructor.
    # So, any height value given is passed automatically to the
    # hull.  All we have to do is play with the propagation.
    #
    if {$itk_option(-height) != 0} {
    pack propagate $itk_component(hull) no
    } else {
    pack propagate $itk_component(hull) yes
    }
}

# ------------------------------------------------------------------
#                            METHODS
# ------------------------------------------------------------------

# ------------------------------------------------------------------
# METHOD: childsite
#
# Return the pathname of the user accessible area.
# ------------------------------------------------------------------
itcl::body iwidgets::Shell::childsite {} {
    return $itk_component(shellchildsite)
}
 
# ------------------------------------------------------------------
# METHOD: activate
#
# Display the dialog and wait based on the modality.  For application
# and global modal activations, perform a grab operation, and wait
# for the result.  The result may be returned via an argument to the
# "deactivate" method.
# ------------------------------------------------------------------
itcl::body iwidgets::Shell::activate {} {

    if {[winfo ismapped $itk_component(hull)]} {
        raise $itk_component(hull)
    return
    }
    
    if {($itk_option(-master) != {}) && \
        [winfo exists $itk_option(-master)]} {
    wm transient $itk_component(hull) $itk_option(-master)
    } 

    set _wait($this) 0
    raise $itk_component(hull)
    wm deiconify $itk_component(hull)
    tkwait visibility $itk_component(hull)

    # Need to flush the event loop.  This line added as a result of
    # SF ticket #227885.
    update idletasks
    
    if {$itk_option(-modality) == "application"} {
        if {$grabstack != {}} {
            grab release [lindex $grabstack end]
        }

    set err 1
    while {$err == 1} {
        set err [catch [list grab $itk_component(hull)]]
        if {$err == 1} {
        after 1000
        }
    }

        lappend grabstack [list grab $itk_component(hull)]
        
        tkwait variable [itcl::scope _wait($this)]
        return $_result
        
    } elseif {$itk_option(-modality) == "global" }  {
        if {$grabstack != {}} {
            grab release [lindex $grabstack end]
        }

    set err 1
    while {$err == 1} {
        set err [catch [list grab -global $itk_component(hull)]]
        if {$err == 1} {
        after 1000
        }
    }

        lappend grabstack [list grab -global $itk_component(hull)]
 
        tkwait variable [itcl::scope _wait($this)]
        return $_result
    }
}
 
# ------------------------------------------------------------------
# METHOD: deactivate
#
# Deactivate the display of the dialog.  The method takes an optional
# argument to passed to the "activate" method which returns the value.
# This is only effective for application and global modal dialogs.
# ------------------------------------------------------------------
itcl::body iwidgets::Shell::deactivate {args} {

    if {! [winfo ismapped $itk_component(hull)]} {
        return
    }
    
    if {$itk_option(-modality) == "none"} {
        wm withdraw $itk_component(hull)
    } elseif {$itk_option(-modality) == "application"} {
        grab release $itk_component(hull)
        if {$grabstack != {}} {
            if {[set grabstack [lreplace $grabstack end end]] != {}} {
                eval [lindex $grabstack end]
            }
        }
 
        wm withdraw $itk_component(hull)
        
    } elseif {$itk_option(-modality) == "global"} {
        grab release $itk_component(hull)
        if {$grabstack != {}} {
            if {[set grabstack [lreplace $grabstack end end]] != {}} {
                eval [lindex $grabstack end]
            }
        }
 
        wm withdraw $itk_component(hull)
    }
    
    if {[llength $args]} {
        set _result $args
    } else {
        set _result {}
    }
    
    set _wait($this) 1
    return
}
 
# ------------------------------------------------------------------
# METHOD: center
#
# Centers the dialog with respect to another widget or the screen
# as a whole.
# ------------------------------------------------------------------
itcl::body iwidgets::Shell::center {{widget {}}} {
    update idletasks
 
    set hull $itk_component(hull)
    set w [winfo width $hull]
    set h [winfo height $hull]
    set sh [winfo screenheight $hull]     ;# display screen's height/width
    set sw [winfo screenwidth $hull]
 
    #
    # User can request it centered with respect to root by passing in '{}'
    #
    if { $widget == "" } {
        set reqX [expr {($sw-$w)/2}]
        set reqY [expr {($sh-$h)/2}]
    } else {
        set wfudge 5      ;# wm width fudge factor
        set hfudge 20     ;# wm height fudge factor
        set widgetW [winfo width $widget]
        set widgetH [winfo height $widget]
        set reqX [expr {[winfo rootx $widget]+($widgetW-($widgetW/2))-($w/2)}]
        set reqY [expr {[winfo rooty $widget]+($widgetH-($widgetH/2))-($h/2)}]
 
        #
        # Adjust for errors - if too long or too tall
        #
        if { ($reqX+$w+$wfudge) > $sw } { set reqX [expr {$sw-$w-$wfudge}] }
        if { $reqX < $wfudge } { set reqX $wfudge }
        if { ($reqY+$h+$hfudge) > $sh } { set reqY [expr {$sh-$h-$hfudge}] }
        if { $reqY < $hfudge } { set reqY $hfudge }
    } 
 
    wm geometry $hull +$reqX+$reqY
}