You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
376 lines
12 KiB
Plaintext
376 lines
12 KiB
Plaintext
# 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
|
|
}
|
|
|