Mercurial > hg > xemacs-beta

comparison lisp/dialog.el @ 5567:3bc58dc9d688

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Replace #'flet by #'labels where appropriate, core code. lisp/ChangeLog addition: 2011-09-07 Aidan Kehoe <kehoea@parhasard.net> * simple.el (transpose-subr): * specifier.el (let-specifier): * specifier.el (derive-device-type-from-tag-set): * test-harness.el (batch-test-emacs): * x-compose.el (alias-colon-to-doublequote): * mule/chinese.el (make-chinese-cns11643-charset): * mule/mule-cmds.el (set-locale-for-language-environment): * mule/mule-cmds.el (set-language-environment-coding-systems): * mule/mule-x-init.el (x-use-halfwidth-roman-font): * about.el (about-xemacs): * about.el (about-hackers): * diagnose.el (show-memory-usage): * diagnose.el (show-object-memory-usage-stats): * diagnose.el (show-mc-alloc-memory-usage): * diagnose.el (show-gc-stats): * dialog.el (make-dialog-box): * faces.el: * faces.el (Face-frob-property): * faces.el (set-face-stipple): * glyphs.el: * glyphs.el (init-glyphs): Removed. * help-macro.el (make-help-screen): * info.el (Info-construct-menu): * keymap.el (key-sequence-list-description): * lisp-mode.el (construct-lisp-mode-menu): * loadhist.el (unload-feature): * minibuf.el (get-user-response): * mouse.el (default-mouse-track-check-for-activation): * mouse.el (mouse-track-insert-1): Follow my own advice from the last commit and use #'labels instead of #'flet in core code.
author Aidan Kehoe <kehoea@parhasard.net>
date Wed, 07 Sep 2011 21:21:36 +0100
parents 7ebbe334061e
children
comparison
equal deleted inserted replaced
5566:4654c01af32b 5567:3bc58dc9d688
502 502
503 If a message box has a Cancel button, the function returns the 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 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 505 is selected. If the message box has no Cancel button, pressing ESC has
506 no effect." 506 no effect."
507 (flet ((dialog-box-modal-loop (thunk) 507 (labels
508 (let* ((frames (frame-list)) 508 ((dialog-box-modal-loop (thunk)
509 (result 509 (let* ((frames (frame-list))
510 ;; ok, this is extremely tricky. normally a modal 510 (result
511 ;; dialog will pop itself down using (dialog-box-finish) 511 ;; ok, this is extremely tricky. normally a modal dialog
512 ;; or (dialog-box-cancel), which throws back to this 512 ;; will pop itself down using (dialog-box-finish) or
513 ;; catch. but question dialog boxes pop down themselves 513 ;; (dialog-box-cancel), which throws back to this catch.
514 ;; regardless, so a badly written question dialog box 514 ;; but question dialog boxes pop down themselves
515 ;; that does not use (dialog-box-finish) could seriously 515 ;; regardless, so a badly written question dialog box that
516 ;; wedge us. furthermore, we disable all other frames 516 ;; does not use (dialog-box-finish) could seriously wedge
517 ;; in order to implement modality; we need to restore 517 ;; us. furthermore, we disable all other frames in order
518 ;; them before the dialog box is destroyed, because 518 ;; to implement modality; we need to restore them before
519 ;; otherwise windows at least will notice that no top- 519 ;; the dialog box is destroyed, because otherwise windows
520 ;; level window can have the focus and will shift the 520 ;; at least will notice that no top- level window can have
521 ;; focus to a different app, raising it and obscuring us. 521 ;; the focus and will shift the focus to a different app,
522 ;; so we create `delete-dialog-box-hook', which is 522 ;; raising it and obscuring us. so we create
523 ;; called right *before* the dialog box gets destroyed. 523 ;; `delete-dialog-box-hook', which is called right *before*
524 ;; here, we put a hook on it, and when it's our dialog 524 ;; the dialog box gets destroyed. here, we put a hook on
525 ;; box and not someone else's that's being destroyed, 525 ;; it, and when it's our dialog box and not someone else's
526 ;; we reenable all the frames and remove the hook. 526 ;; that's being destroyed, we reenable all the frames and
527 ;; BUT ... we still have to deal with exiting the 527 ;; remove the hook. BUT ... we still have to deal with
528 ;; modal loop in case it doesn't happen before us. 528 ;; exiting the modal loop in case it doesn't happen before
529 ;; we can't do this until after the callbacks for this 529 ;; us. we can't do this until after the callbacks for this
530 ;; dialog box get executed, and that doesn't happen until 530 ;; dialog box get executed, and that doesn't happen until
531 ;; after the dialog box is destroyed. so to keep things 531 ;; after the dialog box is destroyed. so to keep things
532 ;; synchronous, we enqueue an eval event, which goes into 532 ;; synchronous, we enqueue an eval event, which goes into
533 ;; the same queue as the misc-user events encapsulating 533 ;; the same queue as the misc-user events encapsulating the
534 ;; the dialog callbacks and will go after it (because 534 ;; dialog callbacks and will go after it (because
535 ;; destroying the dialog box happens after processing 535 ;; destroying the dialog box happens after processing its
536 ;; its selection). if the dialog boxes are written 536 ;; selection). if the dialog boxes are written properly,
537 ;; properly, we don't see this eval event, because we've 537 ;; we don't see this eval event, because we've already
538 ;; already exited our modal loop. (Thus, we make sure the 538 ;; exited our modal loop. (Thus, we make sure the function
539 ;; function given in this eval event is actually defined 539 ;; given in this eval event is actually defined and does
540 ;; and does nothing.) If we do see it, though, we know 540 ;; nothing.) If we do see it, though, we know that we
541 ;; that we encountered a badly written dialog box and 541 ;; encountered a badly written dialog box and need to exit
542 ;; need to exit now. Currently we just return nil, but 542 ;; now. Currently we just return nil, but maybe we should
543 ;; maybe we should signal an error or issue a warning. 543 ;; signal an error or issue a warning.
544 (catch 'internal-dialog-box-finish 544 (catch 'internal-dialog-box-finish
545 (let ((id (eval thunk)) 545 (let ((id (eval thunk))
546 (sym (gensym))) 546 (sym (gensym)))
547 (fset sym 547 (fset sym
548 `(lambda (did) 548 `(lambda (did)
549 (when (eq ',id did) 549 (when (eq ',id did)
550 (mapc 'enable-frame ',frames) 550 (mapc 'enable-frame ',frames)
551 (enqueue-eval-event 551 (enqueue-eval-event
552 'internal-make-dialog-box-exit did) 552 'internal-make-dialog-box-exit did)
553 (remove-hook 'delete-dialog-box-hook 553 (remove-hook 'delete-dialog-box-hook
554 ',sym)))) 554 ',sym))))
555 (if (framep id) 555 (if (framep id)
556 (add-hook 'delete-frame-hook sym) 556 (add-hook 'delete-frame-hook sym)
557 (add-hook 'delete-dialog-box-hook sym)) 557 (add-hook 'delete-dialog-box-hook sym))
558 (mapc 'disable-frame frames) 558 (mapc 'disable-frame frames)
559 (block nil 559 (block nil
560 (while t 560 (while t
561 (let ((event (next-event))) 561 (let ((event (next-event)))
562 (if (and (eval-event-p event) 562 (if (and (eval-event-p event)
563 (eq (event-function event) 563 (eq (event-function event)
564 'internal-make-dialog-box-exit) 564 'internal-make-dialog-box-exit)
565 (eq (event-object event) id)) 565 (eq (event-object event) id))
566 (return '(nil)) 566 (return '(nil))
567 (dispatch-event event))))))))) 567 (dispatch-event event)))))))))
568 (if (listp result) 568 (if (listp result)
569 (car result) 569 (car result)
570 (signal 'quit nil))))) 570 (signal 'quit nil)))))
571 (case type 571 (case type
572 (general 572 (general
573 (flet ((create-dialog-box-frame () 573 (labels
574 (let* ((ftop (frame-property parent 'top)) 574 ((create-dialog-box-frame ()
575 (fleft (frame-property parent 'left)) 575 (let* ((ftop (frame-property parent 'top))
576 (fwidth (frame-pixel-width parent)) 576 (fleft (frame-property parent 'left))
577 (fheight (frame-pixel-height parent)) 577 (fwidth (frame-pixel-width parent))
578 (fonth (font-height (face-font 'default))) 578 (fheight (frame-pixel-height parent))
579 (fontw (font-width (face-font 'default))) 579 (fonth (font-height (face-font 'default)))
580 (properties (append properties 580 (fontw (font-width (face-font 'default)))
581 dialog-frame-plist)) 581 (properties (append properties
582 (dfheight (plist-get properties 'height)) 582 dialog-frame-plist))
583 (dfwidth (plist-get properties 'width)) 583 (dfheight (plist-get properties 'height))
584 (unmapped (plist-get properties 584 (dfwidth (plist-get properties 'width))
585 'initially-unmapped)) 585 (unmapped (plist-get properties
586 (gutter-spec spec) 586 'initially-unmapped))
587 (name (or (plist-get properties 'name) "XEmacs")) 587 (gutter-spec spec)
588 (frame nil)) 588 (name (or (plist-get properties 'name) "XEmacs"))
589 (plist-remprop properties 'initially-unmapped) 589 (frame nil))
590 ;; allow the user to just provide a glyph 590 (plist-remprop properties 'initially-unmapped)
591 (or (glyphp spec) (setq spec (make-glyph spec))) 591 ;; allow the user to just provide a glyph
592 (setq gutter-spec (copy-sequence "\n")) 592 (or (glyphp spec) (setq spec (make-glyph spec)))
593 (set-extent-begin-glyph (make-extent 0 1 gutter-spec) 593 (setq gutter-spec (copy-sequence "\n"))
594 spec) 594 (set-extent-begin-glyph (make-extent 0 1 gutter-spec)
595 ;; under FVWM at least, if I don't specify the 595 spec)
596 ;; initial position, it ends up always at (0, 0). 596 ;; under FVWM at least, if I don't specify the
597 ;; xwininfo doesn't tell me that there are any 597 ;; initial position, it ends up always at (0, 0).
598 ;; program-specified position hints, so it must be 598 ;; xwininfo doesn't tell me that there are any
599 ;; an FVWM bug. So just be smashing and position in 599 ;; program-specified position hints, so it must be
600 ;; the center of the selected frame. 600 ;; an FVWM bug. So just be smashing and position in
601 (setq frame 601 ;; the center of the selected frame.
602 (make-frame 602 (setq frame
603 (append properties 603 (make-frame
604 `(popup 604 (append properties
605 ,parent initially-unmapped t 605 `(popup
606 menubar-visible-p nil 606 ,parent initially-unmapped t
607 has-modeline-p nil 607 menubar-visible-p nil
608 default-toolbar-visible-p nil 608 has-modeline-p nil
609 top-gutter-visible-p t 609 default-toolbar-visible-p nil
610 top-gutter-height ,(* dfheight fonth) 610 top-gutter-visible-p t
611 top-gutter ,gutter-spec 611 top-gutter-height ,(* dfheight fonth)
612 minibuffer none 612 top-gutter ,gutter-spec
613 name ,name 613 minibuffer none
614 modeline-shadow-thickness 0 614 name ,name
615 vertical-scrollbar-visible-p nil 615 modeline-shadow-thickness 0
616 horizontal-scrollbar-visible-p nil 616 vertical-scrollbar-visible-p nil
617 unsplittable t 617 horizontal-scrollbar-visible-p nil
618 internal-border-width 8 618 unsplittable t
619 left ,(+ fleft (- (/ fwidth 2) 619 internal-border-width 8
620 (/ (* dfwidth 620 left ,(+ fleft (- (/ fwidth 2)
621 fontw) 621 (/ (* dfwidth
622 2))) 622 fontw)
623 top ,(+ ftop (- (/ fheight 2) 623 2)))
624 (/ (* dfheight 624 top ,(+ ftop (- (/ fheight 2)
625 fonth) 625 (/ (* dfheight
626 2))))))) 626 fonth)
627 (set-face-foreground 'modeline [default foreground] frame) 627 2)))))))
628 (set-face-background 'modeline [default background] frame) 628 (set-face-foreground 'modeline [default foreground] frame)
629 ;; resize before mapping 629 (set-face-background 'modeline [default background] frame)
630 (when autosize 630 ;; resize before mapping
631 (set-frame-displayable-pixel-size 631 (when autosize
632 frame 632 (set-frame-displayable-pixel-size
633 (image-instance-width 633 frame
634 (glyph-image-instance spec 634 (image-instance-width
635 (frame-selected-window frame))) 635 (glyph-image-instance spec
636 (image-instance-height 636 (frame-selected-window frame)))
637 (glyph-image-instance spec 637 (image-instance-height
638 (frame-selected-window frame))))) 638 (glyph-image-instance spec
639 ;; somehow, even though the resizing is supposed 639 (frame-selected-window frame)))))
640 ;; to be while the frame is not visible, a 640 ;; somehow, even though the resizing is supposed
641 ;; visible resize is perceptible 641 ;; to be while the frame is not visible, a
642 (unless unmapped (make-frame-visible frame)) 642 ;; visible resize is perceptible
643 (let ((newbuf (generate-new-buffer " *dialog box*"))) 643 (unless unmapped (make-frame-visible frame))
644 (set-buffer-dedicated-frame newbuf frame) 644 (let ((newbuf (generate-new-buffer " *dialog box*")))
645 (set-frame-property frame 'dialog-box-buffer newbuf) 645 (set-buffer-dedicated-frame newbuf frame)
646 (set-window-buffer (frame-root-window frame) newbuf) 646 (set-frame-property frame 'dialog-box-buffer newbuf)
647 (with-current-buffer newbuf 647 (set-window-buffer (frame-root-window frame) newbuf)
648 (set (make-local-variable 'frame-title-format) 648 (with-current-buffer newbuf
649 title) 649 (set (make-local-variable 'frame-title-format)
650 (add-local-hook 'delete-frame-hook 650 title)
651 #'(lambda (frame) 651 (add-local-hook 'delete-frame-hook
652 (kill-buffer 652 #'(lambda (frame)
653 (frame-property 653 (kill-buffer
654 frame 654 (frame-property
655 'dialog-box-buffer)))))) 655 frame
656 frame))) 656 'dialog-box-buffer))))))
657 frame)))
657 (if modal 658 (if modal
658 (dialog-box-modal-loop '(create-dialog-box-frame)) 659 (dialog-box-modal-loop (list #'create-dialog-box-frame))
659 (create-dialog-box-frame)))) 660 (create-dialog-box-frame))))
660 (question 661 (question
661 (remf rest :modal) 662 (remf rest :modal)
662 (if modal 663 (if modal
663 (dialog-box-modal-loop `(make-dialog-box-internal ',type ',rest)) 664 (dialog-box-modal-loop `(make-dialog-box-internal ',type ',rest))