1
2if {![info exists UseNativeDialogs] || $UseNativeDialogs == ""} {
3  if {$tcl_platform(platform) == "windows"} {
4    set UseNativeDialogs 1
5  } else {
6    set UseNativeDialogs 0
7  }
8}
9
10#----- pop-up dialog window - borrowed from tk_dialog
11
12proc dialog {w x y title text bitmap default args} {
13  global _DialogDone
14  catch {destroy $w}
15  toplevel $w -class Dialog
16  wm title $w $title
17  if {$x != {} && [winfo exists $x] && [winfo ismapped $x]} {
18    wm transient $w [winfo toplevel $x]
19  } else {
20    wm transient $w [winfo toplevel [winfo parent $w]]
21  }
22
23  frame $w.top -relief raised -bd 1
24  pack $w.top -side top -fill both
25
26  message $w.msg -width 10c -text $text
27  pack $w.msg -in $w.top -side right -expand 1 -fill both -padx 5 -pady 5
28  if {$bitmap != ""} {
29    if {![catch {image type $bitmap} type] && $type == "photo"} {
30      label $w.bitmap -image $bitmap
31    } else {
32      label $w.bitmap -bitmap $bitmap
33    }
34    pack $w.bitmap -in $w.top -side left -padx 5 -pady 5
35  }
36
37  set nbut 0
38  set wbut 0
39  set fbut $w
40  foreach but $args {
41    if {$but != ""} {
42      incr nbut
43      if {$wbut < [string length $but]} {
44        set wbut [string length $but]
45      }
46    }
47  }
48  if {$nbut} {
49    if {$wbut < 4} {set wbut 4}
50    frame $w.bot -relief raised -bd 1
51    pack $w.bot -side bottom -fill both
52    set i 0
53    foreach but $args {
54      if {$but != ""} {
55        button $w.button$i -text $but -width $wbut -command "set _DialogDone $i"
56        pack $w.button$i -in $w.bot -side left -expand 1 -padx 3 -pady 5
57        if {$i == $default} {
58          set fbut $w.button$i
59          $fbut configure -default active
60          bind $w <Return> "$fbut flash; set _DialogDone $i"
61        }
62      }
63      incr i
64    }
65  }
66
67  center_window $w $x $y
68
69  if {!$nbut} {
70    update idletasks
71    return 0
72  }
73
74  set oldFocus [focus]
75  set oldGrab [grab current $w]
76  if {$oldGrab != ""} {
77    set grabStatus [grab status $oldGrab]
78  }
79  catch {grab $w}
80  tkwait visibility $w
81  focus $fbut
82  tkwait variable _DialogDone
83  catch {focus $oldFocus}
84  destroy $w
85  if {$oldGrab != ""} {
86    if {$grabStatus == "global"} {
87      grab -global $oldGrab
88    } else {
89      grab $oldGrab
90    }
91  }
92  return $_DialogDone
93}
94
95proc MessageBox {title msg {icon ""} {type ""} {default ""}} {
96  global UseNativeDialogs
97  if {$UseNativeDialogs} {
98    set cmd "tk_messageBox -title {$title} -message {$msg}"
99    if {$icon != ""} {
100      append cmd " -icon $icon"
101    }
102    if {$type != ""} {
103      append cmd " -type $type"
104    }
105    if {$default != ""} {
106      append cmd " -default $default"
107    }
108    return [eval $cmd]
109  }
110
111  set buttons OK
112  case $type {
113    abortretryignore {set buttons "Abort Retry Ignore"}
114    okcancel {set buttons "OK Cancel"}
115    retrycancel {set buttons "Retry Cancel"}
116    yesno {set buttons "Yes No"}
117    yesnocancel {set buttons "Yes No Cancel"}
118  }
119  set defbut 0
120  if {$default != ""} {
121    set n 0
122    foreach b [split $buttons] {
123      if {$default == [string tolower $b]} {
124        set defbut $n
125        break
126      }
127      incr n
128    }
129  }
130  set cmd "dialog .messagewin {} {} {$title} {$msg} \
131    {$icon} $defbut $buttons"
132  set n [eval $cmd]
133  if [catch {lindex $buttons $n} result] {
134    return ""
135  }
136  return [string tolower $result]
137}
138
139proc DialogBox {w x y title text bitmap args} {
140  global _DialogDone
141
142  # get button width
143
144  set width 0
145  foreach btn $args {
146    if {[string length [lindex $btn 0]] > $width} {
147      set width [string length [lindex $btn 0]]
148    }
149  }
150  if !$width {
151    return [dialog $w $x $y $title $text $bitmap {} {}]
152  }
153  incr width 2
154
155  catch {destroy $w}
156  toplevel $w -class Dialog
157  wm title $w $title
158  if {$x != {} && [winfo exists $x] && [winfo ismapped $x]} {
159    wm transient $w [winfo toplevel $x]
160  } else {
161    wm transient $w [winfo toplevel [winfo parent $w]]
162  }
163
164  # top message
165
166  frame $w.msg -relief raised -bd 1
167  pack $w.msg -side top -fill both -expand 1
168  if {$bitmap != ""} {
169    if {![catch {image type $bitmap} type] && $type == "photo"} {
170      label $w.msg.icon -image $bitmap
171    } else {
172      label $w.msg.icon -bitmap $bitmap
173    }
174    pack $w.msg.icon -side left -padx 10 -pady 3
175  }
176  message $w.msg.msg -text $text -width 8c
177  pack $w.msg.msg -pady 3 -anchor w
178
179  # button selections
180
181  set cnt -1
182  foreach btn $args {
183    incr cnt
184    set f [frame $w.f$cnt -relief raised -bd 1]
185    pack $f -side top -fill x
186    button $f.btn -width $width -text [lindex $btn 0] \
187      -padx 3 -pady 2 -command "set _DialogDone $cnt"
188    pack $f.btn -side left -padx 3 -pady 3
189    pack $f.btn -side left
190    message $f.msg -text [lindex $btn 1] -width 10c
191    pack $f.msg -anchor w -padx 3 -pady 3
192  }
193
194  center_window $w $x $y
195
196  set oldFocus [focus]
197  set oldGrab [grab current $w]
198  if {$oldGrab != ""} {
199    set grabStatus [grab status $oldGrab]
200  }
201  catch {grab $w}
202  focus $w
203  tkwait variable _DialogDone
204  catch {focus $oldFocus}
205  destroy $w
206  if {$oldGrab != ""} {
207    if {$grabStatus == "global"} {
208      grab -global $oldGrab
209    } else {
210      grab $oldGrab
211    }
212  }
213  return $_DialogDone
214}
215
216#----- error message popup window
217
218proc errormsg {msg {x -1} {y -1}} {
219  if {$msg != ""} {
220    dialog .errorwin $x $y Error $msg error 0 Dismiss
221  }
222}
223
224proc ErrorMessage {msg} {
225  MessageBox Error "$msg" error
226}
227
228#----- center a window
229
230proc center_window {w xref {yref -1}} {
231  wm withdraw $w
232  update idletasks
233  set ww [winfo reqwidth $w]
234  set wh [winfo reqheight $w]
235
236  if {$xref == ""} {
237    set x [expr ([winfo screenwidth  $w] - $ww) / 2]
238    set y [expr ([winfo screenheight $w] - $wh) / 2]
239  } elseif {[winfo exists $xref] && [winfo ismapped $xref]} {
240    set x [expr [winfo rootx $xref] + ([winfo width  $xref] - $ww) / 2]
241    set y [expr [winfo rooty $xref] + ([winfo height $xref] - $wh) / 2]
242  } else {
243    if [catch {expr $xref < 0} x] {
244      set x 1
245    }
246    if {$x} {
247      if [winfo ismapped .] {
248        set x [expr [winfo rootx .] + ([winfo width .] - $ww) / 2]
249      } else {
250        set x [expr ([winfo screenwidth $w] - $ww) / 2]
251      }
252    } else {
253      set x [expr $xref - $ww / 2]
254    }
255    if [catch {expr $yref < 0} y] {
256      set y 1
257    }
258    if {$y} {
259      if [winfo ismapped .] {
260        set y [expr [winfo rooty .] + ([winfo height .] - $wh) / 2]
261      } else {
262        set y [expr ([winfo screenheight $w] - $wh) / 2]
263      }
264    } else {
265      set y [expr $yref - $wh / 2]
266    }
267  }
268
269  if {$x < 0} {
270    set pos +0
271  } elseif {[expr $x + $ww] > [winfo screenwidth $w]} {
272    set pos -0
273  } else {
274    set pos +$x
275  }
276
277  if {$y < 0} {
278    set pos $pos+0
279  } elseif {[expr $y + $wh] > [winfo screenheight $w]} {
280    set pos $pos-0
281  } else {
282    set pos $pos+$y
283  }
284
285  wm geometry $w $pos
286  update idletasks
287  wm deiconify $w
288}
289
290#----- about message window
291
292proc about {title text {bitmap ""}} {
293  dialog .about -1 -1 $title $text $bitmap 0 Close
294}
295
296#----- popup message
297
298proc popup_message {msg args} {
299  global Font
300
301  set font $Font(normal)
302  set bg #ffffcc
303  set fg black
304  set parent .
305  set pos ""
306  set width 5c
307  set wrap 1
308  foreach {opt val} $args {
309    switch -glob -- $opt {
310      -fon* {set font $val}
311      -par* {set parent $val}
312      -pos* {set pos $val}
313      -for* - -fg {set fg $val}
314      -bac* - -bg {set bg $val}
315      -wid* {set width $val}
316      -wra* {set wrap $val}
317    }
318  }
319  if {$pos == ""} {set pos $parent}
320
321  set w .popup
322  catch {destroy $w}
323  toplevel $w -bg black
324  wm overrideredirect $w 1
325  wm transient $w [winfo toplevel $parent]
326  if {$wrap} {
327    message $w.l -text $msg -font $font -relief flat -bg $bg -fg $fg \
328      -padx 2 -pady 0 -anchor w -width $width
329  } else {
330    label $w.l -text $msg -font $font -relief flat -bg $bg -fg $fg \
331      -padx 2 -pady 0 -anchor w -justify left -wraplength 0
332  }
333  pack $w.l -side left -padx 1 -pady 1
334  eval center_window $w $pos
335
336  bind $w <ButtonRelease> {catch {destroy .popup};break}
337  bind $w <KeyRelease> {catch {destroy .popup};break}
338  bind $w <FocusOut> {catch {destroy .popup}}
339
340  set oldFocus [focus]
341  set oldGrab [grab current $w]
342  if {$oldGrab != ""} {
343    set grabStatus [grab status $oldGrab]
344  }
345  catch {grab $w}
346  focus $w
347  tkwait window $w
348  catch {focus $oldFocus}
349  if {$oldGrab != ""} {
350    if {$grabStatus == "global"} {
351      grab -global $oldGrab
352    } else {
353      grab $oldGrab
354    }
355  }
356}
357
358