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