share/iwidgets4.0.1/scripts/shell.itk - toolchains/skids - Git at Google

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