1# Shell 2# ---------------------------------------------------------------------- 3# This class is implements a shell which is a top level widget 4# giving a childsite and providing activate, deactivate, and center 5# methods. 6# 7# ---------------------------------------------------------------------- 8# AUTHOR: Mark L. Ulferts EMAIL: mulferts@austin.dsccc.com 9# Kris Raney EMAIL: kraney@spd.dsccc.com 10# 11# @(#) $Id: shell.itk,v 1.9 2007/06/10 19:35:04 hobbs Exp $ 12# ---------------------------------------------------------------------- 13# Copyright (c) 1996 DSC Technologies Corporation 14# ====================================================================== 15# Permission to use, copy, modify, distribute and license this software 16# and its documentation for any purpose, and without fee or written 17# agreement with DSC, is hereby granted, provided that the above copyright 18# notice appears in all copies and that both the copyright notice and 19# warranty disclaimer below appear in supporting documentation, and that 20# the names of DSC Technologies Corporation or DSC Communications 21# Corporation not be used in advertising or publicity pertaining to the 22# software without specific, written prior permission. 23# 24# DSC DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING 25# ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, AND NON- 26# INFRINGEMENT. THIS SOFTWARE IS PROVIDED ON AN "AS IS" BASIS, AND THE 27# AUTHORS AND DISTRIBUTORS HAVE NO OBLIGATION TO PROVIDE MAINTENANCE, 28# SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. IN NO EVENT SHALL 29# DSC BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR 30# ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, 31# WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTUOUS ACTION, 32# ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS 33# SOFTWARE. 34# ====================================================================== 35 36# 37# Usual options. 38# 39itk::usual Shell { 40 keep -background -cursor -modality 41} 42 43# ------------------------------------------------------------------ 44# SHELL 45# ------------------------------------------------------------------ 46itcl::class iwidgets::Shell { 47 inherit itk::Toplevel 48 49 constructor {args} {} 50 51 itk_option define -master master Window "" 52 itk_option define -modality modality Modality none 53 itk_option define -padx padX Pad 0 54 itk_option define -pady padY Pad 0 55 itk_option define -width width Width 0 56 itk_option define -height height Height 0 57 58 public method childsite {} 59 public method activate {} 60 public method deactivate {args} 61 public method center {{widget {}}} 62 63 protected variable _result {} ;# Resultant value for modal activation. 64 65 private variable _busied {} ;# List of busied top level widgets. 66 67 common grabstack {} 68 common _wait 69} 70 71# 72# Provide a lowercased access method for the Shell class. 73# 74proc ::iwidgets::shell {pathName args} { 75 uplevel ::iwidgets::Shell $pathName $args 76} 77 78# ------------------------------------------------------------------ 79# CONSTRUCTOR 80# ------------------------------------------------------------------ 81itcl::body iwidgets::Shell::constructor {args} { 82 itk_option add hull.width hull.height 83 84 # 85 # Maintain a withdrawn state until activated. 86 # 87 wm withdraw $itk_component(hull) 88 89 # 90 # Create the user child site 91 # 92 itk_component add -protected shellchildsite { 93 frame $itk_interior.shellchildsite 94 } 95 pack $itk_component(shellchildsite) -fill both -expand yes 96 97 # 98 # Set the itk_interior variable to be the childsite for derived 99 # classes. 100 # 101 set itk_interior $itk_component(shellchildsite) 102 103 # 104 # Bind the window manager delete protocol to deactivation of the 105 # widget. This can be overridden by the user via the execution 106 # of a similar command outside the class. 107 # 108 wm protocol $itk_component(hull) WM_DELETE_WINDOW [itcl::code $this deactivate] 109 110 # 111 # Initialize the widget based on the command line options. 112 # 113 eval itk_initialize $args 114} 115 116# ------------------------------------------------------------------ 117# OPTIONS 118# ------------------------------------------------------------------ 119 120# ------------------------------------------------------------------ 121# OPTION: -master 122# 123# Specifies the master window for the shell. The window manager is 124# informed that the shell is a transient window whose master is 125# -masterwindow. 126# ------------------------------------------------------------------ 127itcl::configbody iwidgets::Shell::master {} 128 129# ------------------------------------------------------------------ 130# OPTION: -modality 131# 132# Specify the modality of the dialog. 133# ------------------------------------------------------------------ 134itcl::configbody iwidgets::Shell::modality { 135 switch $itk_option(-modality) { 136 none - 137 application - 138 global { 139 } 140 141 default { 142 error "bad modality option \"$itk_option(-modality)\":\ 143 should be none, application, or global" 144 } 145 } 146} 147 148# ------------------------------------------------------------------ 149# OPTION: -padx 150# 151# Specifies a padding distance for the childsite in the X-direction. 152# ------------------------------------------------------------------ 153itcl::configbody iwidgets::Shell::padx { 154 pack config $itk_component(shellchildsite) -padx $itk_option(-padx) 155} 156 157# ------------------------------------------------------------------ 158# OPTION: -pady 159# 160# Specifies a padding distance for the childsite in the Y-direction. 161# ------------------------------------------------------------------ 162itcl::configbody iwidgets::Shell::pady { 163 pack config $itk_component(shellchildsite) -pady $itk_option(-pady) 164} 165 166# ------------------------------------------------------------------ 167# OPTION: -width 168# 169# Specifies the width of the shell. The value may be specified in 170# any of the forms acceptable to Tk_GetPixels. A value of zero 171# causes the width to be adjusted to the required value based on 172# the size requests of the components placed in the childsite. 173# Otherwise, the width is fixed. 174# ------------------------------------------------------------------ 175itcl::configbody iwidgets::Shell::width { 176 # 177 # The width option was added to the hull in the constructor. 178 # So, any width value given is passed automatically to the 179 # hull. All we have to do is play with the propagation. 180 # 181 if {$itk_option(-width) != 0} { 182 pack propagate $itk_component(hull) no 183 } else { 184 pack propagate $itk_component(hull) yes 185 } 186} 187 188# ------------------------------------------------------------------ 189# OPTION: -height 190# 191# Specifies the height of the shell. The value may be specified in 192# any of the forms acceptable to Tk_GetPixels. A value of zero 193# causes the height to be adjusted to the required value based on 194# the size requests of the components placed in the childsite. 195# Otherwise, the height is fixed. 196# ------------------------------------------------------------------ 197itcl::configbody iwidgets::Shell::height { 198 # 199 # The height option was added to the hull in the constructor. 200 # So, any height value given is passed automatically to the 201 # hull. All we have to do is play with the propagation. 202 # 203 if {$itk_option(-height) != 0} { 204 pack propagate $itk_component(hull) no 205 } else { 206 pack propagate $itk_component(hull) yes 207 } 208} 209 210# ------------------------------------------------------------------ 211# METHODS 212# ------------------------------------------------------------------ 213 214# ------------------------------------------------------------------ 215# METHOD: childsite 216# 217# Return the pathname of the user accessible area. 218# ------------------------------------------------------------------ 219itcl::body iwidgets::Shell::childsite {} { 220 return $itk_component(shellchildsite) 221} 222 223# ------------------------------------------------------------------ 224# METHOD: activate 225# 226# Display the dialog and wait based on the modality. For application 227# and global modal activations, perform a grab operation, and wait 228# for the result. The result may be returned via an argument to the 229# "deactivate" method. 230# ------------------------------------------------------------------ 231itcl::body iwidgets::Shell::activate {} { 232 233 if {[winfo ismapped $itk_component(hull)]} { 234 raise $itk_component(hull) 235 return 236 } 237 238 if {($itk_option(-master) != {}) && \ 239 [winfo exists $itk_option(-master)]} { 240 wm transient $itk_component(hull) $itk_option(-master) 241 } 242 243 set _wait($this) 0 244 raise $itk_component(hull) 245 wm deiconify $itk_component(hull) 246 tkwait visibility $itk_component(hull) 247 # For some mysterious reason, Tk sometimes returns too late from the 248 # "tkwait visibility", i.e. after the "deactivate" method was invoked, 249 # i.e. after the dialog window already disappeared. This would lead to 250 # an infinite vwait on _wait($this) further on. Trap this case. 251 # See also 2002-03-15 message to the Tcl/Tk newsgroup. 252 # Remark that tests show that if "raise" is given *after* "deiconify" 253 # (see above), "tkwait visibility" always returns duly on time..... 254 if {![winfo ismapped $itk_component(hull)]} { 255 # means "deactivate" went already through the grab-release stuff. 256 return $_result 257 } 258 259 # Need to flush the event loop. This line added as a result of 260 # SF ticket #227885. 261 update idletasks 262 263 if {$itk_option(-modality) == "application"} { 264 if {$grabstack != {}} { 265 grab release [lindex $grabstack end] 266 } 267 268 set err 1 269 while {$err == 1} { 270 set err [catch [list grab $itk_component(hull)]] 271 if {$err == 1} { 272 after 1000 273 } 274 } 275 276 lappend grabstack [list grab $itk_component(hull)] 277 278 tkwait variable [itcl::scope _wait($this)] 279 return $_result 280 281 } elseif {$itk_option(-modality) == "global" } { 282 if {$grabstack != {}} { 283 grab release [lindex $grabstack end] 284 } 285 286 set err 1 287 while {$err == 1} { 288 set err [catch [list grab -global $itk_component(hull)]] 289 if {$err == 1} { 290 after 1000 291 } 292 } 293 294 lappend grabstack [list grab -global $itk_component(hull)] 295 296 tkwait variable [itcl::scope _wait($this)] 297 return $_result 298 } 299} 300 301# ------------------------------------------------------------------ 302# METHOD: deactivate 303# 304# Deactivate the display of the dialog. The method takes an optional 305# argument to passed to the "activate" method which returns the value. 306# This is only effective for application and global modal dialogs. 307# ------------------------------------------------------------------ 308itcl::body iwidgets::Shell::deactivate {args} { 309 310 if {! [winfo ismapped $itk_component(hull)]} { 311 return 312 } 313 314 if {$itk_option(-modality) == "none"} { 315 wm withdraw $itk_component(hull) 316 } elseif {$itk_option(-modality) == "application"} { 317 grab release $itk_component(hull) 318 if {$grabstack != {}} { 319 if {[set grabstack [lreplace $grabstack end end]] != {}} { 320 eval [lindex $grabstack end] 321 } 322 } 323 324 wm withdraw $itk_component(hull) 325 326 } elseif {$itk_option(-modality) == "global"} { 327 grab release $itk_component(hull) 328 if {$grabstack != {}} { 329 if {[set grabstack [lreplace $grabstack end end]] != {}} { 330 eval [lindex $grabstack end] 331 } 332 } 333 334 wm withdraw $itk_component(hull) 335 } 336 337 if {[llength $args]} { 338 set _result $args 339 } else { 340 set _result {} 341 } 342 343 set _wait($this) 1 344 return 345} 346 347# ------------------------------------------------------------------ 348# METHOD: center 349# 350# Centers the dialog with respect to another widget or the screen 351# as a whole. 352# ------------------------------------------------------------------ 353itcl::body iwidgets::Shell::center {{widget {}}} { 354 update idletasks 355 356 set hull $itk_component(hull) 357 set w [winfo width $hull] 358 set h [winfo height $hull] 359 set sh [winfo screenheight $hull] ;# display screen's height/width 360 set sw [winfo screenwidth $hull] 361 362 # 363 # User can request it centered with respect to root by passing in '{}' 364 # 365 if { $widget == "" } { 366 set reqX [expr {($sw-$w)/2}] 367 set reqY [expr {($sh-$h)/2}] 368 } else { 369 set wfudge 5 ;# wm width fudge factor 370 set hfudge 20 ;# wm height fudge factor 371 set widgetW [winfo width $widget] 372 set widgetH [winfo height $widget] 373 set reqX [expr {[winfo rootx $widget]+($widgetW-($widgetW/2))-($w/2)}] 374 set reqY [expr {[winfo rooty $widget]+($widgetH-($widgetH/2))-($h/2)}] 375 376 # 377 # Adjust for errors - if too long or too tall 378 # 379 if { ($reqX+$w+$wfudge) > $sw } { set reqX [expr {$sw-$w-$wfudge}] } 380 if { $reqX < $wfudge } { set reqX $wfudge } 381 if { ($reqY+$h+$hfudge) > $sh } { set reqY [expr {$sh-$h-$hfudge}] } 382 if { $reqY < $hfudge } { set reqY $hfudge } 383 } 384 385 wm geometry $hull +$reqX+$reqY 386} 387 388