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