Mercurial > hg > xemacs-beta
annotate lisp/dialog.el @ 5750:66d2f63df75f
Correct some spelling and formatting in behavior.el.
Mentioned in tracker issue 826, the third thing mentioned there (the file
name at the bottom of the file) had already been fixed.
lisp/ChangeLog addition:
2013-08-05 Aidan Kehoe <kehoea@parhasard.net>
* behavior.el:
(override-behavior):
Correct some spelling and formatting here, thank you Steven
Mitchell in tracker issue 826.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Mon, 05 Aug 2013 10:05:32 +0100 |
| parents | 3bc58dc9d688 |
| children |
| rev | line source |
|---|---|
| 209 | 1 ;;; dialog.el --- Dialog-box support for XEmacs |
| 2 | |
| 3 ;; Copyright (C) 1991-4, 1997 Free Software Foundation, Inc. | |
| 844 | 4 ;; Copyright (C) 2000, 2002 Ben Wing. |
| 209 | 5 |
| 6 ;; Maintainer: XEmacs Development Team | |
| 7 ;; Keywords: extensions, internal, dumped | |
| 8 | |
| 9 ;; This file is part of XEmacs. | |
| 10 | |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
2730
diff
changeset
|
11 ;; XEmacs is free software: you can redistribute it and/or modify it |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
2730
diff
changeset
|
12 ;; under the terms of the GNU General Public License as published by the |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
2730
diff
changeset
|
13 ;; Free Software Foundation, either version 3 of the License, or (at your |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
2730
diff
changeset
|
14 ;; option) any later version. |
| 209 | 15 |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
2730
diff
changeset
|
16 ;; XEmacs is distributed in the hope that it will be useful, but WITHOUT |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
2730
diff
changeset
|
17 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
2730
diff
changeset
|
18 ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
2730
diff
changeset
|
19 ;; for more details. |
| 209 | 20 |
| 21 ;; You should have received a copy of the GNU General Public License | |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
2730
diff
changeset
|
22 ;; along with XEmacs. If not, see <http://www.gnu.org/licenses/>. |
| 209 | 23 |
| 24 ;;; Synched up with: Not in FSF. | |
| 25 | |
| 844 | 26 ;;; Authorship: Mostly written or rewritten by Ben Wing; some old old stuff |
| 27 ;;; that underlies some current code was written by JWZ. | |
| 28 | |
| 209 | 29 ;;; Commentary: |
| 30 | |
| 31 ;; This file is dumped with XEmacs (when dialog boxes are compiled in). | |
| 32 | |
| 442 | 33 ;; Dialog boxes are non-modal at the C level, but made modal at the |
| 34 ;; Lisp level via hacks in functions such as yes-or-no-p-dialog-box | |
| 35 ;; below. Perhaps there should be truly modal dialog boxes | |
| 36 ;; implemented at the C level for safety. All code using dialog boxes | |
| 37 ;; should be careful to assume that the environment, for example the | |
| 38 ;; current buffer, might be completely different after returning from | |
| 39 ;; yes-or-no-p-dialog-box, but such code is difficult to write and test. | |
| 40 | |
| 209 | 41 ;;; Code: |
| 42 (defun yes-or-no-p-dialog-box (prompt) | |
| 442 | 43 "Ask user a yes-or-no question with a popup dialog box. |
| 44 Return t if the answer is \"yes\". | |
| 209 | 45 Takes one argument, which is the string to display to ask the question." |
| 442 | 46 (save-selected-frame |
| 47 (make-dialog-box 'question | |
| 48 :question prompt | |
| 49 :modal t | |
| 50 :buttons '(["Yes" (dialog-box-finish t)] | |
| 51 ["No" (dialog-box-finish nil)] | |
| 52 nil | |
| 53 ["Cancel" (dialog-box-cancel)])))) | |
| 209 | 54 |
| 442 | 55 ;; FSF has a similar function `x-popup-dialog'. |
| 209 | 56 (defun get-dialog-box-response (position contents) |
| 57 "Pop up a dialog box and return user's selection. | |
| 58 POSITION specifies which frame to use. | |
| 59 This is normally an event or a window or frame. | |
| 60 If POSITION is t or nil, it means to use the frame the mouse is on. | |
| 61 The dialog box appears in the middle of the specified frame. | |
| 62 | |
| 63 CONTENTS specifies the alternatives to display in the dialog box. | |
| 64 It is a list of the form (TITLE ITEM1 ITEM2...). | |
| 65 Each ITEM is a cons cell (STRING . VALUE). | |
| 66 The return value is VALUE from the chosen item. | |
| 67 | |
| 68 An ITEM may also be just a string--that makes a nonselectable item. | |
| 69 An ITEM may also be nil--that means to put all preceding items | |
| 70 on the left of the dialog box and all following items on the right." | |
| 71 (cond | |
| 72 ((eventp position) | |
| 73 (select-frame (event-frame position))) | |
| 74 ((framep position) | |
| 75 (select-frame position)) | |
| 76 ((windowp position) | |
| 77 (select-window position))) | |
| 442 | 78 (make-dialog-box 'question |
| 79 :question (car contents) | |
| 80 :modal t | |
| 81 :buttons | |
| 82 (mapcar #'(lambda (x) | |
| 83 (cond | |
| 84 ((null x) | |
| 85 nil) | |
| 86 ((stringp x) | |
| 87 ;;this will never get selected | |
| 88 `[,x 'ignore nil]) | |
| 89 (t | |
| 90 `[,(car x) (dialog-box-finish ',(cdr x)) t]))) | |
| 91 (cdr contents)))) | |
| 209 | 92 |
| 93 (defun message-box (fmt &rest args) | |
| 94 "Display a message, in a dialog box if possible. | |
| 95 If the selected device has no dialog-box support, use the echo area. | |
| 96 The arguments are the same as to `format'. | |
| 97 | |
| 98 If the only argument is nil, clear any existing message; let the | |
| 99 minibuffer contents show." | |
| 100 (if (and (null fmt) (null args)) | |
| 101 (progn | |
| 102 (clear-message nil) | |
| 103 nil) | |
| 104 (let ((str (apply 'format fmt args))) | |
| 105 (if (device-on-window-system-p) | |
| 442 | 106 (get-dialog-box-response nil (list str (cons "%_OK" t))) |
| 209 | 107 (display-message 'message str)) |
| 108 str))) | |
| 109 | |
| 110 (defun message-or-box (fmt &rest args) | |
| 442 | 111 "Display a message in a dialog box or in the echo area. |
| 112 If this command was invoked with the mouse, use a dialog box. | |
| 209 | 113 Otherwise, use the echo area. |
| 114 The arguments are the same as to `format'. | |
| 115 | |
| 116 If the only argument is nil, clear any existing message; let the | |
| 117 minibuffer contents show." | |
| 118 (if (should-use-dialog-box-p) | |
| 119 (apply 'message-box fmt args) | |
| 120 (apply 'message fmt args))) | |
| 121 | |
|
5330
fbafdc1bb4d2
Use defun*, not cl-parsing-keywords, #'make-dialog-box, #'display-completion-list
Aidan Kehoe <kehoea@parhasard.net>
parents:
2730
diff
changeset
|
122 (defun* make-dialog-box (type &rest rest &key (title "XEmacs") |
|
fbafdc1bb4d2
Use defun*, not cl-parsing-keywords, #'make-dialog-box, #'display-completion-list
Aidan Kehoe <kehoea@parhasard.net>
parents:
2730
diff
changeset
|
123 (parent (selected-frame)) modal properties autosize |
|
fbafdc1bb4d2
Use defun*, not cl-parsing-keywords, #'make-dialog-box, #'display-completion-list
Aidan Kehoe <kehoea@parhasard.net>
parents:
2730
diff
changeset
|
124 spec &allow-other-keys) |
| 442 | 125 "Pop up a dialog box. |
| 126 TYPE is a symbol, the type of dialog box. Remaining arguments are | |
| 127 keyword-value pairs, specifying the particular characteristics of the | |
| 128 dialog box. The allowed keywords are particular to each type, but | |
| 129 some standard keywords are common to many types: | |
| 130 | |
| 131 :title | |
| 132 The title of the dialog box's window. | |
| 133 | |
| 134 :modal | |
| 135 If true, indicates that XEmacs will wait until the user is \"done\" | |
| 136 with the dialog box (usually, this means that a response has been | |
| 137 given). Typically, the response is returned. NOTE: Some dialog | |
| 138 boxes are always modal. If the dialog box is modal, `make-dialog-box' | |
| 139 returns immediately. The return value will be either nil or a | |
| 140 dialog box handle of some sort, e.g. a frame for type `general'. | |
| 141 | |
| 142 --------------------------------------------------------------------------- | |
| 143 | |
| 144 Recognized types are | |
| 145 | |
| 146 general | |
| 147 A dialog box consisting of an XEmacs glyph, typically a `layout' | |
| 148 widget specifying a dialog box arrangement. This is the most | |
| 149 general and powerful dialog box type, but requires more work than | |
| 150 the other types below. | |
| 151 | |
| 152 question | |
| 153 A simple dialog box that displays a question and contains one or | |
| 154 more user-defined buttons to specify possible responses. (This is | |
| 155 compatible with the old built-in dialog boxes formerly specified | |
| 156 using `popup-dialog-box'.) | |
| 157 | |
| 158 file | |
| 159 A file dialog box, of the type typically used in the window system | |
| 160 XEmacs is running on. | |
| 161 | |
| 162 color | |
| 163 A color picker. | |
| 164 | |
| 165 find | |
| 166 A find dialog box. | |
| 167 | |
| 168 font | |
| 169 A font chooser. | |
| 170 | |
| 171 print | |
| 172 A dialog box used when printing (e.g. number of pages, printer). | |
| 173 | |
| 174 page-setup | |
| 175 A dialog box for setting page options (e.g. margins) for printing. | |
| 176 | |
| 177 replace | |
| 178 A find/replace dialog box. | |
| 179 | |
| 180 mswindows-message | |
| 181 An MS Windows-specific standard dialog box type similar to `question'. | |
| 182 | |
| 183 --------------------------------------------------------------------------- | |
| 184 | |
| 185 For type `general': | |
| 186 | |
| 187 This type creates a frame and puts the specified widget layout in it. | |
| 188 \(Currently this is done by eliminating all areas but the gutter and placing | |
| 189 the layout there; but this is an implementation detail and may change.) | |
| 190 | |
| 191 The keywords allowed for `general' are | |
| 192 | |
| 193 :spec | |
| 194 The widget spec -- anything that can be passed to `make-glyph'. | |
| 195 :title | |
| 196 The title of the frame. | |
| 197 :parent | |
| 198 The frame is made a child of this frame (defaults to the selected frame). | |
| 199 :properties | |
| 200 Additional properties of the frame, as well as `dialog-frame-plist'. | |
| 863 | 201 :autosize |
| 202 If t the frame is sized to exactly fit the widgets given by :spec. | |
| 442 | 203 |
| 204 --------------------------------------------------------------------------- | |
| 205 | |
| 206 For type `question': | |
| 207 | |
| 208 The keywords allowed are | |
| 209 | |
| 210 :modal | |
| 211 t or nil. When t, the dialog box callback should exit the dialog box | |
| 212 using the functions `dialog-box-finish' or `dialog-box-cancel'. | |
| 213 :title | |
| 214 The title of the frame. | |
| 215 :question | |
| 216 A string, the question. | |
| 217 :buttons | |
| 218 A list, describing the buttons below the question. Each of these is a | |
| 219 vector, the syntax of which is essentially the same as that of popup menu | |
| 220 items. They may have any of the following forms: | |
| 221 | |
| 222 [ \"name\" callback <active-p> ] | |
| 223 [ \"name\" callback <active-p> \"suffix\" ] | |
| 224 [ \"name\" callback :<keyword> <value> :<keyword> <value> ... ] | |
| 225 | |
| 226 The name is the string to display on the button; it is filtered through the | |
| 227 resource database, so it is possible for resources to override what string | |
| 228 is actually displayed. | |
| 229 | |
| 230 Accelerators can be indicated in the string by putting the sequence | |
| 231 \"%_\" before the character corresponding to the key that will invoke | |
| 232 the button. Uppercase and lowercase accelerators are equivalent. The | |
| 233 sequence \"%%\" is also special, and is translated into a single %. | |
| 234 | |
| 235 If the `callback' of a button is a symbol, then it must name a command. | |
| 236 It will be invoked with `call-interactively'. If it is a list, then it is | |
| 237 evaluated with `eval'. | |
| 238 | |
| 239 One (and only one) of the buttons may be `nil'. This marker means that all | |
| 240 following buttons should be flushright instead of flushleft. | |
| 241 | |
| 242 Though the keyword/value syntax is supported for dialog boxes just as in | |
| 243 popup menus, the only keyword which is both meaningful and fully implemented | |
| 244 for dialog box buttons is `:active'. | |
| 245 | |
| 246 --------------------------------------------------------------------------- | |
| 247 | |
| 248 For type `file': | |
| 249 | |
| 250 The keywords allowed are | |
| 251 | |
| 252 :initial-filename | |
| 253 The initial filename to be placed in the dialog box (defaults to nothing). | |
| 254 :initial-directory | |
| 255 The initial directory to be selected in the dialog box (defaults to the | |
| 256 current buffer's `default-directory). | |
| 257 :filter-list | |
| 258 A list of (filter-desc filter ...) | |
| 259 :title | |
| 260 The title of the dialog box (defaults to \"Open\"). | |
| 261 :allow-multi-select t or nil | |
| 262 :create-prompt-on-nonexistent t or nil | |
| 263 :overwrite-prompt t or nil | |
| 264 :file-must-exist t or nil | |
| 265 :no-network-button t or nil | |
| 266 :no-read-only-return t or nil | |
| 267 | |
| 268 --------------------------------------------------------------------------- | |
| 269 | |
| 673 | 270 For type `directory': |
| 271 | |
| 272 The keywords allowed are | |
| 273 | |
| 274 :initial-directory | |
| 275 The initial directory to be selected in the dialog box (defaults to the | |
| 276 current buffer's `default-directory). | |
| 277 :title | |
| 278 The title of the dialog box (defaults to \"Open\"). | |
| 279 | |
| 280 --------------------------------------------------------------------------- | |
| 281 | |
| 442 | 282 For type `print': |
| 283 | |
| 284 This invokes the Windows standard Print dialog. | |
| 285 This dialog is usually invoked when the user selects the Print command. | |
| 286 After the user presses OK, the program should start actual printout. | |
| 287 | |
| 288 The keywords allowed are | |
| 289 | |
| 290 :device | |
| 291 An 'msprinter device. | |
| 292 :print-settings | |
| 293 A printer settings object. | |
| 510 | 294 :allow-selection |
| 295 t or nil -- whether the \"Selection\" button is enabled (defaults to nil). | |
| 296 :allow-pages | |
| 297 t or nil -- whether the \"Pages\" button and associated edit controls | |
| 298 are enabled (defaults to t). | |
| 299 :selected-page-button | |
| 300 `all', `selection', or `pages' -- which page button is initially | |
| 301 selected. | |
| 442 | 302 |
| 510 | 303 Exactly one of :device and :print-settings must be given. |
| 442 | 304 |
| 305 The function brings up the Print dialog, where the user can | |
| 506 | 306 select a different printer and/or change printer options. Connection |
| 442 | 307 name can change as a result of selecting a different printer device. If |
| 506 | 308 a device is specified, then changes are stored into the settings object |
| 442 | 309 currently selected into that printer. If a settings object is supplied, |
| 629 | 310 then changes are recorded into it, and, it is selected into a |
| 442 | 311 printer, then changes are propagated to that printer |
| 312 too. | |
| 313 | |
| 314 Return value is nil if the user has canceled the dialog. Otherwise, it | |
| 315 is a new plist, with the following properties: | |
| 510 | 316 name Printer device name, even if unchanged by the user. |
| 317 from-page First page to print, 1-based. Returned if | |
| 318 `selected-page-button' is `pages'. | |
| 319 user, then this value is not included in the plist. | |
| 320 to-page Last page to print, inclusive, 1-based. Returned if | |
| 321 `selected-page-button' is `pages'. | |
| 322 copies Number of copies to print. Always returned. | |
| 323 selected-page-button Which page button was selected (`all', `selection', | |
| 324 or `pages'). | |
| 442 | 325 |
| 326 The DEVICE is destroyed and an error is signaled in case of | |
| 327 initialization problem with the new printer. | |
| 328 | |
| 510 | 329 See also the `page-setup' dialog box type. |
| 442 | 330 |
| 331 --------------------------------------------------------------------------- | |
| 332 | |
| 333 For type `page-setup': | |
| 334 | |
| 335 This invokes the Windows standard Page Setup dialog. | |
| 506 | 336 This dialog is usually invoked in response to the Page Setup command, |
| 337 and used to choose such parameters as page orientation, print margins | |
| 338 etc. Note that this dialog contains the \"Printer\" button, which | |
| 339 invokes the Printer Setup dialog so that the user can update the | |
| 340 printer options or even select a different printer as well. | |
| 442 | 341 |
| 342 The keywords allowed are | |
| 343 | |
| 344 :device | |
| 345 An 'msprinter device. | |
| 346 :print-settings | |
| 347 A printer settings object. | |
| 348 :properties | |
| 349 A plist of job properties. | |
| 350 | |
| 351 Exactly one of these keywords must be given. | |
| 352 | |
| 353 The function brings up the Page Setup dialog, where the user | |
| 354 can select a different printer and/or change printer options. | |
| 355 Connection name can change as a result of selecting a different printer | |
| 506 | 356 device. If a device is specified, then changes are stored into the |
| 442 | 357 settings object currently selected into that printer. If a settings |
| 629 | 358 object is supplied, then changes are recorded into it, and, it is |
| 442 | 359 selected into a printer, then changes are propagated to that printer |
| 360 too. | |
| 361 | |
| 362 :properties specifies a plist of job properties; | |
| 363 see `default-msprinter-frame-plist' for the complete list. The plist | |
| 364 is used to initialize the dialog. | |
| 365 | |
| 366 Return value is nil if the user has canceled the dialog. Otherwise, | |
| 367 it is a new plist, containing the new list of properties. | |
| 368 | |
| 506 | 369 NOTE: The margin properties (returned by this function) are *NOT* stored |
| 370 into the print-settings or device object. | |
| 371 | |
| 442 | 372 The DEVICE is destroyed and an error is signaled in case of |
| 373 initialization problem with the new printer. | |
| 374 | |
| 510 | 375 See also the `print' dialog box type. |
| 442 | 376 |
| 377 --------------------------------------------------------------------------- | |
| 378 | |
| 379 For type `mswindows-message': | |
| 380 | |
| 381 The keywords allowed are | |
| 382 | |
| 383 :title | |
| 384 The title of the dialog box. | |
| 385 :message | |
| 386 The string to display. | |
| 387 :flags | |
| 388 A symbol or list of symbols: | |
| 389 | |
| 390 -- To specify the buttons in the message box: | |
| 391 | |
| 392 abortretryignore | |
| 393 The message box contains three push buttons: Abort, Retry, and Ignore. | |
| 394 ok | |
| 395 The message box contains one push button: OK. This is the default. | |
| 396 okcancel | |
| 397 The message box contains two push buttons: OK and Cancel. | |
| 398 retrycancel | |
| 399 The message box contains two push buttons: Retry and Cancel. | |
| 400 yesno | |
| 401 The message box contains two push buttons: Yes and No. | |
| 402 yesnocancel | |
| 403 The message box contains three push buttons: Yes, No, and Cancel. | |
| 404 | |
| 405 | |
| 406 -- To display an icon in the message box: | |
| 407 | |
| 408 iconexclamation, iconwarning | |
| 409 An exclamation-point icon appears in the message box. | |
| 410 iconinformation, iconasterisk | |
| 411 An icon consisting of a lowercase letter i in a circle appears in | |
| 412 the message box. | |
| 413 iconquestion | |
| 414 A question-mark icon appears in the message box. | |
| 415 iconstop, iconerror, iconhand | |
| 416 A stop-sign icon appears in the message box. | |
| 417 | |
| 418 | |
| 419 -- To indicate the default button: | |
| 420 | |
| 421 defbutton1 | |
| 422 The first button is the default button. This is the default. | |
| 423 defbutton2 | |
| 424 The second button is the default button. | |
| 425 defbutton3 | |
| 426 The third button is the default button. | |
| 427 defbutton4 | |
| 428 The fourth button is the default button. | |
| 429 | |
| 430 | |
| 431 -- To indicate the modality of the dialog box: | |
| 432 | |
| 433 applmodal | |
| 434 The user must respond to the message box before continuing work in | |
| 435 the window identified by the hWnd parameter. However, the user can | |
| 436 move to the windows of other applications and work in those windows. | |
| 437 Depending on the hierarchy of windows in the application, the user | |
| 438 may be able to move to other windows within the application. All | |
| 439 child windows of the parent of the message box are automatically | |
| 440 disabled, but popup windows are not. This is the default. | |
| 441 systemmodal | |
| 442 Same as applmodal except that the message box has the WS_EX_TOPMOST | |
| 443 style. Use system-modal message boxes to notify the user of serious, | |
| 444 potentially damaging errors that require immediate attention (for | |
| 445 example, running out of memory). This flag has no effect on the | |
| 446 user's ability to interact with windows other than those associated | |
| 447 with hWnd. | |
| 448 taskmodal | |
| 449 Same as applmodal except that all the top-level windows belonging to | |
| 450 the current task are disabled if the hWnd parameter is NULL. Use | |
| 451 this flag when the calling application or library does not have a | |
| 452 window handle available but still needs to prevent input to other | |
| 453 windows in the current application without suspending other | |
| 454 applications. | |
| 455 | |
| 456 | |
| 457 In addition, you can specify the following flags: | |
| 458 | |
| 459 default-desktop-only | |
| 460 The desktop currently receiving input must be a default desktop; | |
| 461 otherwise, the function fails. A default desktop is one an | |
| 462 application runs on after the user has logged on. | |
| 463 help | |
| 464 Adds a Help button to the message box. Choosing the Help button or | |
| 465 pressing F1 generates a Help event. | |
| 466 right | |
| 467 The text is right-justified. | |
| 468 rtlreading | |
| 469 Displays message and caption text using right-to-left reading order | |
| 470 on Hebrew and Arabic systems. | |
| 471 setforeground | |
| 472 The message box becomes the foreground window. Internally, Windows | |
| 473 calls the SetForegroundWindow function for the message box. | |
| 474 topmost | |
| 475 The message box is created with the WS_EX_TOPMOST window style. | |
| 476 service-notification | |
| 477 Windows NT only: The caller is a service notifying the user of an | |
| 478 event. The function displays a message box on the current active | |
| 479 desktop, even if there is no user logged on to the computer. If | |
| 480 this flag is set, the hWnd parameter must be NULL. This is so the | |
| 481 message box can appear on a desktop other than the desktop | |
| 482 corresponding to the hWnd. | |
| 483 | |
| 484 | |
| 485 The return value is one of the following menu-item values returned by | |
| 486 the dialog box: | |
| 487 | |
| 488 abort | |
| 489 Abort button was selected. | |
| 490 cancel | |
| 491 Cancel button was selected. | |
| 492 ignore | |
| 493 Ignore button was selected. | |
| 494 no | |
| 495 No button was selected. | |
| 496 ok | |
| 497 OK button was selected. | |
| 498 retry | |
| 499 Retry button was selected. | |
| 500 yes | |
| 501 Yes button was selected. | |
| 502 | |
| 503 If a message box has a Cancel button, the function returns the | |
| 504 `cancel' value if either the ESC key is pressed or the Cancel button | |
| 505 is selected. If the message box has no Cancel button, pressing ESC has | |
| 506 no effect." | |
|
5567
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
507 (labels |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
508 ((dialog-box-modal-loop (thunk) |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
509 (let* ((frames (frame-list)) |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
510 (result |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
511 ;; ok, this is extremely tricky. normally a modal dialog |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
512 ;; will pop itself down using (dialog-box-finish) or |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
513 ;; (dialog-box-cancel), which throws back to this catch. |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
514 ;; but question dialog boxes pop down themselves |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
515 ;; regardless, so a badly written question dialog box that |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
516 ;; does not use (dialog-box-finish) could seriously wedge |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
517 ;; us. furthermore, we disable all other frames in order |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
518 ;; to implement modality; we need to restore them before |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
519 ;; the dialog box is destroyed, because otherwise windows |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
520 ;; at least will notice that no top- level window can have |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
521 ;; the focus and will shift the focus to a different app, |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
522 ;; raising it and obscuring us. so we create |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
523 ;; `delete-dialog-box-hook', which is called right *before* |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
524 ;; the dialog box gets destroyed. here, we put a hook on |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
525 ;; it, and when it's our dialog box and not someone else's |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
526 ;; that's being destroyed, we reenable all the frames and |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
527 ;; remove the hook. BUT ... we still have to deal with |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
528 ;; exiting the modal loop in case it doesn't happen before |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
529 ;; us. we can't do this until after the callbacks for this |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
530 ;; dialog box get executed, and that doesn't happen until |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
531 ;; after the dialog box is destroyed. so to keep things |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
532 ;; synchronous, we enqueue an eval event, which goes into |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
533 ;; the same queue as the misc-user events encapsulating the |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
534 ;; dialog callbacks and will go after it (because |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
535 ;; destroying the dialog box happens after processing its |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
536 ;; selection). if the dialog boxes are written properly, |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
537 ;; we don't see this eval event, because we've already |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
538 ;; exited our modal loop. (Thus, we make sure the function |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
539 ;; given in this eval event is actually defined and does |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
540 ;; nothing.) If we do see it, though, we know that we |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
541 ;; encountered a badly written dialog box and need to exit |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
542 ;; now. Currently we just return nil, but maybe we should |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
543 ;; signal an error or issue a warning. |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
544 (catch 'internal-dialog-box-finish |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
545 (let ((id (eval thunk)) |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
546 (sym (gensym))) |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
547 (fset sym |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
548 `(lambda (did) |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
549 (when (eq ',id did) |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
550 (mapc 'enable-frame ',frames) |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
551 (enqueue-eval-event |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
552 'internal-make-dialog-box-exit did) |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
553 (remove-hook 'delete-dialog-box-hook |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
554 ',sym)))) |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
555 (if (framep id) |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
556 (add-hook 'delete-frame-hook sym) |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
557 (add-hook 'delete-dialog-box-hook sym)) |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
558 (mapc 'disable-frame frames) |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
559 (block nil |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
560 (while t |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
561 (let ((event (next-event))) |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
562 (if (and (eval-event-p event) |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
563 (eq (event-function event) |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
564 'internal-make-dialog-box-exit) |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
565 (eq (event-object event) id)) |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
566 (return '(nil)) |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
567 (dispatch-event event))))))))) |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
568 (if (listp result) |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
569 (car result) |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
570 (signal 'quit nil))))) |
| 442 | 571 (case type |
| 572 (general | |
|
5567
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
573 (labels |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
574 ((create-dialog-box-frame () |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
575 (let* ((ftop (frame-property parent 'top)) |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
576 (fleft (frame-property parent 'left)) |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
577 (fwidth (frame-pixel-width parent)) |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
578 (fheight (frame-pixel-height parent)) |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
579 (fonth (font-height (face-font 'default))) |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
580 (fontw (font-width (face-font 'default))) |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
581 (properties (append properties |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
582 dialog-frame-plist)) |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
583 (dfheight (plist-get properties 'height)) |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
584 (dfwidth (plist-get properties 'width)) |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
585 (unmapped (plist-get properties |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
586 'initially-unmapped)) |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
587 (gutter-spec spec) |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
588 (name (or (plist-get properties 'name) "XEmacs")) |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
589 (frame nil)) |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
590 (plist-remprop properties 'initially-unmapped) |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
591 ;; allow the user to just provide a glyph |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
592 (or (glyphp spec) (setq spec (make-glyph spec))) |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
593 (setq gutter-spec (copy-sequence "\n")) |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
594 (set-extent-begin-glyph (make-extent 0 1 gutter-spec) |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
595 spec) |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
596 ;; under FVWM at least, if I don't specify the |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
597 ;; initial position, it ends up always at (0, 0). |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
598 ;; xwininfo doesn't tell me that there are any |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
599 ;; program-specified position hints, so it must be |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
600 ;; an FVWM bug. So just be smashing and position in |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
601 ;; the center of the selected frame. |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
602 (setq frame |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
603 (make-frame |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
604 (append properties |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
605 `(popup |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
606 ,parent initially-unmapped t |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
607 menubar-visible-p nil |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
608 has-modeline-p nil |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
609 default-toolbar-visible-p nil |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
610 top-gutter-visible-p t |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
611 top-gutter-height ,(* dfheight fonth) |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
612 top-gutter ,gutter-spec |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
613 minibuffer none |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
614 name ,name |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
615 modeline-shadow-thickness 0 |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
616 vertical-scrollbar-visible-p nil |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
617 horizontal-scrollbar-visible-p nil |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
618 unsplittable t |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
619 internal-border-width 8 |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
620 left ,(+ fleft (- (/ fwidth 2) |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
621 (/ (* dfwidth |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
622 fontw) |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
623 2))) |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
624 top ,(+ ftop (- (/ fheight 2) |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
625 (/ (* dfheight |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
626 fonth) |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
627 2))))))) |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
628 (set-face-foreground 'modeline [default foreground] frame) |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
629 (set-face-background 'modeline [default background] frame) |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
630 ;; resize before mapping |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
631 (when autosize |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
632 (set-frame-displayable-pixel-size |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
633 frame |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
634 (image-instance-width |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
635 (glyph-image-instance spec |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
636 (frame-selected-window frame))) |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
637 (image-instance-height |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
638 (glyph-image-instance spec |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
639 (frame-selected-window frame))))) |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
640 ;; somehow, even though the resizing is supposed |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
641 ;; to be while the frame is not visible, a |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
642 ;; visible resize is perceptible |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
643 (unless unmapped (make-frame-visible frame)) |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
644 (let ((newbuf (generate-new-buffer " *dialog box*"))) |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
645 (set-buffer-dedicated-frame newbuf frame) |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
646 (set-frame-property frame 'dialog-box-buffer newbuf) |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
647 (set-window-buffer (frame-root-window frame) newbuf) |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
648 (with-current-buffer newbuf |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
649 (set (make-local-variable 'frame-title-format) |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
650 title) |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
651 (add-local-hook 'delete-frame-hook |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
652 #'(lambda (frame) |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
653 (kill-buffer |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
654 (frame-property |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
655 frame |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
656 'dialog-box-buffer)))))) |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
657 frame))) |
|
5330
fbafdc1bb4d2
Use defun*, not cl-parsing-keywords, #'make-dialog-box, #'display-completion-list
Aidan Kehoe <kehoea@parhasard.net>
parents:
2730
diff
changeset
|
658 (if modal |
|
5567
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5455
diff
changeset
|
659 (dialog-box-modal-loop (list #'create-dialog-box-frame)) |
|
5330
fbafdc1bb4d2
Use defun*, not cl-parsing-keywords, #'make-dialog-box, #'display-completion-list
Aidan Kehoe <kehoea@parhasard.net>
parents:
2730
diff
changeset
|
660 (create-dialog-box-frame)))) |
| 442 | 661 (question |
|
5330
fbafdc1bb4d2
Use defun*, not cl-parsing-keywords, #'make-dialog-box, #'display-completion-list
Aidan Kehoe <kehoea@parhasard.net>
parents:
2730
diff
changeset
|
662 (remf rest :modal) |
|
fbafdc1bb4d2
Use defun*, not cl-parsing-keywords, #'make-dialog-box, #'display-completion-list
Aidan Kehoe <kehoea@parhasard.net>
parents:
2730
diff
changeset
|
663 (if modal |
|
fbafdc1bb4d2
Use defun*, not cl-parsing-keywords, #'make-dialog-box, #'display-completion-list
Aidan Kehoe <kehoea@parhasard.net>
parents:
2730
diff
changeset
|
664 (dialog-box-modal-loop `(make-dialog-box-internal ',type ',rest)) |
|
5333
aa2705c83c24
Correct a misplaced parenthesis in #'make-dialog-box, thank you Mats!
Aidan Kehoe <kehoea@parhasard.net>
parents:
5330
diff
changeset
|
665 (make-dialog-box-internal type rest))) |
|
aa2705c83c24
Correct a misplaced parenthesis in #'make-dialog-box, thank you Mats!
Aidan Kehoe <kehoea@parhasard.net>
parents:
5330
diff
changeset
|
666 (t |
|
aa2705c83c24
Correct a misplaced parenthesis in #'make-dialog-box, thank you Mats!
Aidan Kehoe <kehoea@parhasard.net>
parents:
5330
diff
changeset
|
667 (make-dialog-box-internal type rest))))) |
| 442 | 668 |
| 669 (defun dialog-box-finish (result) | |
| 670 "Exit a modal dialog box, returning RESULT. | |
| 671 This is meant to be executed from a dialog box callback function." | |
| 672 (throw 'internal-dialog-box-finish (list result))) | |
| 673 | |
| 674 (defun dialog-box-cancel () | |
| 675 "Cancel a modal dialog box. | |
| 676 This is meant to be executed from a dialog box callback function." | |
| 677 (throw 'internal-dialog-box-finish 'cancel)) | |
| 678 | |
| 679 ;; an eval event, used as a trigger inside of the dialog modal loop. | |
| 680 (defun internal-make-dialog-box-exit (did) | |
| 681 nil) | |
| 682 | |
| 683 (make-obsolete 'popup-dialog-box 'make-dialog-box) | |
| 684 (defun popup-dialog-box (desc) | |
| 685 "Obsolete equivalent of (make-dialog-box 'question ...). | |
| 686 | |
| 687 \(popup-dialog-box (QUESTION BUTTONS ...) | |
| 688 | |
| 689 is equivalent to | |
| 690 | |
| 691 \(make-dialog-box 'question :question QUESTION :buttons BUTTONS)" | |
| 692 (check-argument-type 'stringp (car desc)) | |
| 693 (or (consp (cdr desc)) | |
| 694 (error 'syntax-error | |
| 695 "Dialog descriptor must supply at least one button" | |
| 696 desc)) | |
| 697 (make-dialog-box 'question :question (car desc) :buttons (cdr desc))) | |
| 698 | |
| 209 | 699 ;;; dialog.el ends here |