library/msgbox.tcl

   1 # msgbox.tcl --
   2 #
   3 #       Implements messageboxes.
   4 #
   5 # Copyright (c) 1994-1997 Sun Microsystems, Inc.
   6 # Copyright (c) 1999 Christian Werner
   7 #
   8 # See the file "license.terms" for information on usage and redistribution
   9 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  10
  11
  12 # ck_messageBox --
  13 #
  14 #       Pops up a messagebox with an application-supplied message with
  15 #       an icon and a list of buttons.
  16 #       See the user documentation for details on what ck_messageBox does.
  17
  18 proc ck_messageBox args {
  19     global ckPriv
  20     set w ckPrivMsgBox
  21     upvar #0 $w data
  22     set specs {
  23         {-default "" "" ""}
  24         {-icon "" "" "info"}
  25         {-message "" "" ""}
  26         {-parent "" "" .}
  27         {-title "" "" ""}
  28         {-type "" "" "ok"}
  29     }
  30     tclParseConfigSpec $w $specs "" $args
  31     if {[lsearch {info warning error question} $data(-icon)] == -1} {
  32         error "invalid icon \"$data(-icon)\", must be error, info, question or warning"
  33     }
  34     if {![winfo exists $data(-parent)]} {
  35         error "bad window path name \"$data(-parent)\""
  36     }
  37     switch -- $data(-type) {
  38         abortretryignore {
  39             set buttons {
  40                 {abort  -width 6 -text Abort -underline 0}
  41                 {retry  -width 6 -text Retry -underline 0}
  42                 {ignore -width 6 -text Ignore -underline 0}
  43             }
  44         }
  45         ok {
  46             set buttons {
  47                 {ok -width 6 -text OK -underline 0}
  48             }
  49             if {$data(-default) == ""} {
  50                 set data(-default) "ok"
  51             }
  52         }
  53         okcancel {
  54             set buttons {
  55                 {ok     -width 6 -text OK     -underline 0}
  56                 {cancel -width 6 -text Cancel -underline 0}
  57             }
  58         }
  59         retrycancel {
  60             set buttons {
  61                 {retry  -width 6 -text Retry  -underline 0}
  62                 {cancel -width 6 -text Cancel -underline 0}
  63             }
  64         }
  65         yesno {
  66             set buttons {
  67                 {yes    -width 6 -text Yes -underline 0}
  68                 {no     -width 6 -text No  -underline 0}
  69             }
  70         }
  71         yesnocancel {
  72             set buttons {
  73                 {yes    -width 6 -text Yes -underline 0}
  74                 {no     -width 6 -text No  -underline 0}
  75                 {cancel -width 6 -text Cancel -underline 0}
  76             }
  77         }
  78         default {
  79             error "invalid message box type \"$data(-type)\", must be abortretryignore, ok, okcancel, retrycancel, yesno or yesnocancel"
  80         }
  81     }
  82     if {[string compare $data(-default) ""]} {
  83         set valid 0
  84         foreach btn $buttons {
  85             if {![string compare [lindex $btn 0] $data(-default)]} {
  86                 set valid 1
  87                 break
  88             }
  89         }
  90         if {!$valid} {
  91             error "invalid default button \"$data(-default)\""
  92         }
  93     }
  94     # 2. Set the dialog to be a child window of $parent
  95     if {[string compare $data(-parent) .]} {
  96         set w $data(-parent).__ck__messagebox
  97     } else {
  98         set w .__ck__messagebox
  99     }
 100
 101     # 3. Create the top-level window and divide it into top
 102     # and bottom parts.
 103     catch {destroy $w}
 104     toplevel $w -class Dialog \
 105         -border { ulcorner hline urcorner vline lrcorner hline llcorner vline }
 106     place $w -relx 0.5 -rely 0.5 -anchor center
 107     label $w.title -text $data(-title)
 108     pack $w.title -side top -fill x
 109     frame $w.bot
 110     pack $w.bot -side bottom -fill both
 111     frame $w.top
 112     pack $w.top -side top -fill both -expand 1
 113     # 4. Fill the top part with bitmap and message (use the option
 114     # database for -wraplength so that it can be overridden by
 115     # the caller).
 116     message $w.top.msg -text $data(-message) -aspect 1000
 117     pack $w.top.msg -side right -expand 1 -fill both -padx 1 -pady 1
 118     # 5. Create a row of buttons at the bottom of the dialog.
 119     set i 0
 120     foreach but $buttons {
 121         set name [lindex $but 0]
 122         set opts [lrange $but 1 end]
 123         if {![string compare $opts {}]} {
 124             # Capitalize the first letter of $name
 125             set capName \
 126                 [string toupper \
 127                     [string index $name 0]][string range $name 1 end]
 128             set opts [list -text $capName]
 129         }
 130         eval button $w.bot.$name $opts \
 131             -command [list [list set ckPriv(button) $name]]
 132         pack $w.bot.$name -side left -expand 1 -padx 1 -pady 1
 133         # create the binding for the key accelerator, based on the underline
 134         set underIdx [$w.bot.$name cget -underline]
 135         if {$underIdx >= 0} {
 136             set key [string index [$w.bot.$name cget -text] $underIdx]
 137             bind $w [string tolower $key] [list $w.bot.$name invoke]
 138             bind $w [string toupper $key] [list $w.bot.$name invoke]
 139         }
 140         incr i
 141     }
 142     # 6. Create a binding for <Return> on the dialog if there is a
 143     # default button.
 144     if {[string compare $data(-default) ""]} {
 145         bind $w <Return> "ckButtonInvoke $w.bot.$data(-default) ; break"
 146         bind $w <Linefeed> "ckButtonInvoke $w.bot.$data(-default) ; break"
 147     }
 148     # 7. Claim the focus.
 149     set oldFocus [focus]
 150     if {[string compare $data(-default) ""]} {
 151         focus $w.bot.$data(-default)
 152     } else {
 153         focus [lindex [winfo children $w.bot] 0]
 154     }
 155     # 8. Wait for the user to respond, then restore the focus and
 156     # return the index of the selected button.  Restore the focus
 157     # before deleting the window, since otherwise the window manager
 158     # may take the focus away so we can't redirect it.  Finally,
 159     # restore any grab that was in effect.
 160     tkwait variable ckPriv(button)
 161     catch {focus $oldFocus}
 162     destroy $w
 163     return $ckPriv(button)
 164 }