home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / tk42r2x.zip / TclTk / lib / tk4.2 / msgbox.tcl < prev    next >
Text File  |  1999-07-27  |  7KB  |  246 lines
  1. # msgbox.tcl --
  2. #
  3. #    Implements messageboxes for platforms that do not have native
  4. #    messagebox support.
  5. #
  6. # SCCS: @(#) msgbox.tcl 1.4 96/09/05 11:30:30
  7. #
  8. # Copyright (c) 1994-1996 Sun Microsystems, Inc.
  9. #
  10. # See the file "license.terms" for information on usage and redistribution
  11. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  12. #
  13.  
  14.  
  15. # tkMessageBox --
  16. #
  17. #    Pops up a messagebox with an application-supplied message with
  18. #    an icon and a list of buttons. This procedure will be called
  19. #    by tk_messageBox if the platform does not have native
  20. #    messagebox support, or if the particular type of messagebox is
  21. #    not supported natively.
  22. #
  23. #    This procedure is a private procedure shouldn't be called
  24. #    directly. Call tk_messageBox instead.
  25. #
  26. #    See the user documentation for details on what tk_messageBox does.
  27. #
  28. proc tkMessageBox {args} {
  29.     global tkPriv 
  30.  
  31.     set w tkPrivMsgBox
  32.     upvar #0 $w data
  33.  
  34.     #
  35.     # The default value of the title is space (" ") not the empty string
  36.     # because for some window managers, a 
  37.     #        wm title .foo ""
  38.     # causes the window title to be "foo" instead of the empty string.
  39.     #
  40.     set specs {
  41.     {-default "" "" ""}
  42.         {-icon "" "" "info"}
  43.         {-message "" "" ""}
  44.         {-parent "" "" .}
  45.         {-title "" "" " "}
  46.         {-type "" "" "ok"}
  47.     }
  48.  
  49.     tclParseConfigSpec $w $specs "" $args
  50.  
  51.     if {[lsearch {info warning error question} $data(-icon)] == -1} {
  52.     error "invalid icon \"$data(-icon)\", must be error, info, question or warning"
  53.     }
  54.  
  55.     if ![winfo exists $data(-parent)] {
  56.     error "bad window path name \"$data(-parent)\""
  57.     }
  58.  
  59.     case $data(-type) {
  60.     abortretryignore {
  61.         set buttons {
  62.         {abort  -width 6 -text Abort -under 0}
  63.         {retry  -width 6 -text Retry -under 0}
  64.         {ignore -width 6 -text Ignore -under 0}
  65.         }
  66.     }
  67.     ok {
  68.         set buttons {
  69.         {ok -width 6 -text OK -under 0}
  70.         }
  71.         if {$data(-default) == ""} {
  72.         set data(-default) "ok"
  73.         }
  74.     }
  75.     okcancel {
  76.         set buttons {
  77.         {ok     -width 6 -text OK     -under 0}
  78.         {cancel -width 6 -text Cancel -under 0}
  79.         }
  80.     }
  81.     retrycancel {
  82.         set buttons {
  83.         {retry  -width 6 -text Retry  -under 0}
  84.         {cancel -width 6 -text Cancel -under 0}
  85.         }
  86.     }
  87.     yesno {
  88.         set buttons {
  89.         {yes    -width 6 -text Yes -under 0}
  90.         {no     -width 6 -text No  -under 0}
  91.         }
  92.     }
  93.     yesnocancel {
  94.         set buttons {
  95.         {yes    -width 6 -text Yes -under 0}
  96.         {no     -width 6 -text No  -under 0}
  97.         {cancel -width 6 -text Cancel -under 0}
  98.         }
  99.     }
  100.     default {
  101.         error "invalid message box type \"$data(-type)\", must be abortretryignore, ok, okcancel, retrycancel, yesno or yesnocancel"
  102.     }
  103.     }
  104.  
  105.     if [string compare $data(-default) ""] {
  106.     set valid 0
  107.     foreach btn $buttons {
  108.         if ![string compare [lindex $btn 0] $data(-default)] {
  109.         set valid 1
  110.         break
  111.         }
  112.     }
  113.     if !$valid {
  114.         error "invalid default button \"$data(-default)\""
  115.     }
  116.     }
  117.  
  118.     # 2. Set the dialog to be a child window of $parent
  119.     #
  120.     #
  121.     if [string compare $data(-parent) .] {
  122.     set w $data(-parent).__tk__messagebox
  123.     } else {
  124.     set w .__tk__messagebox
  125.     }
  126.  
  127.     # 3. Create the top-level window and divide it into top
  128.     # and bottom parts.
  129.  
  130.     catch {destroy $w}
  131.     toplevel $w -class Dialog
  132.     wm title $w $data(-title)
  133.     wm iconname $w Dialog
  134.     wm protocol $w WM_DELETE_WINDOW { }
  135.     wm transient $w $data(-parent)
  136.  
  137.     frame $w.bot -relief raised -bd 1
  138.     pack $w.bot -side bottom -fill both
  139.     frame $w.top -relief raised -bd 1
  140.     pack $w.top -side top -fill both -expand 1
  141.  
  142.     # 4. Fill the top part with bitmap and message (use the option
  143.     # database for -wraplength so that it can be overridden by
  144.     # the caller).
  145.  
  146.     option add *Dialog.msg.wrapLength 3i widgetDefault
  147.     label $w.msg -justify left -text $data(-message)
  148.     catch {$w.msg configure -font \
  149.         -Adobe-Times-Medium-R-Normal--*-180-*-*-*-*-*-*
  150.     }
  151.     pack $w.msg -in $w.top -side right -expand 1 -fill both -padx 3m -pady 3m
  152.     if {$data(-icon) != ""} {
  153.     label $w.bitmap -bitmap $data(-icon)
  154.     pack $w.bitmap -in $w.top -side left -padx 3m -pady 3m
  155.     }
  156.  
  157.     # 5. Create a row of buttons at the bottom of the dialog.
  158.  
  159.     set i 0
  160.     foreach but $buttons {
  161.     set name [lindex $but 0]
  162.     set opts [lrange $but 1 end]
  163.     if ![string compare $opts {}] {
  164.         # Capitalize the first letter of $name
  165.         set capName \
  166.         [string toupper \
  167.             [string index $name 0]][string range $name 1 end]
  168.         set opts [list -text $capName]
  169.     }
  170.  
  171.     eval button $w.$name $opts -command [list "set tkPriv(button) $name"]
  172.  
  173.     if ![string compare $name $data(-default)] {
  174.         frame $w.default -relief sunken -bd 1
  175.         raise $w.$name $w.default
  176.         pack $w.default -in $w.bot -side left -expand 1 -padx 3m -pady 2m
  177.         pack $w.$name -in $w.default -padx 2m -pady 2m
  178.     } else {
  179.         pack $w.$name -in $w.bot -side left -expand 1 \
  180.         -padx 3m -pady 2m
  181.     }
  182.  
  183.     # create the binding for the key accelerator, based on the underline
  184.     #
  185.     set underIdx [$w.$name cget -under]
  186.     if {$underIdx >= 0} {
  187.         set key [string index [$w.$name cget -text] $underIdx]
  188.         bind $w <Alt-[string tolower $key]>  "$w.$name invoke"
  189.         bind $w <Alt-[string toupper $key]>  "$w.$name invoke"
  190.     }
  191.     incr i
  192.     }
  193.  
  194.     # 6. Create a binding for <Return> on the dialog if there is a
  195.     # default button.
  196.  
  197.     if [string compare $data(-default) ""] {
  198.     bind $w <Return> "tkButtonInvoke $w.$data(-default)"
  199.     }
  200.  
  201.     # 7. Withdraw the window, then update all the geometry information
  202.     # so we know how big it wants to be, then center the window in the
  203.     # display and de-iconify it.
  204.  
  205.     wm withdraw $w
  206.     update idletasks
  207.     set x [expr [winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \
  208.         - [winfo vrootx [winfo parent $w]]]
  209.     set y [expr [winfo screenheight $w]/2 - [winfo reqheight $w]/2 \
  210.         - [winfo vrooty [winfo parent $w]]]
  211.     wm geom $w +$x+$y
  212.     wm deiconify $w
  213.  
  214.     # 8. Set a grab and claim the focus too.
  215.  
  216.     set oldFocus [focus]
  217.     set oldGrab [grab current $w]
  218.     if {$oldGrab != ""} {
  219.     set grabStatus [grab status $oldGrab]
  220.     }
  221.     grab $w
  222.     if [string compare $data(-default) ""] {
  223.     focus $w.$data(-default)
  224.     } else {
  225.     focus $w
  226.     }
  227.  
  228.     # 9. Wait for the user to respond, then restore the focus and
  229.     # return the index of the selected button.  Restore the focus
  230.     # before deleting the window, since otherwise the window manager
  231.     # may take the focus away so we can't redirect it.  Finally,
  232.     # restore any grab that was in effect.
  233.  
  234.     tkwait variable tkPriv(button)
  235.     catch {focus $oldFocus}
  236.     destroy $w
  237.     if {$oldGrab != ""} {
  238.     if {$grabStatus == "global"} {
  239.         grab -global $oldGrab
  240.     } else {
  241.         grab $oldGrab
  242.     }
  243.     }
  244.     return $tkPriv(button)
  245. }
  246.