Mercurial > hg > xemacs-beta

comparison lisp/dialog.el @ 5448:89331fa1c819

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Merged with trunk.
author Mats Lidell <matsl@xemacs.org>
date Thu, 06 Jan 2011 00:35:22 +0100
parents 308d34e9f07d fbafdc1bb4d2
children 7ebbe334061e
comparison
equal deleted inserted replaced
5447:4b08f375e2fb 5448:89331fa1c819
117 minibuffer contents show." 117 minibuffer contents show."
118 (if (should-use-dialog-box-p) 118 (if (should-use-dialog-box-p)
119 (apply 'message-box fmt args) 119 (apply 'message-box fmt args)
120 (apply 'message fmt args))) 120 (apply 'message fmt args)))
121 121
122 (defun make-dialog-box (type &rest cl-keys) 122 (defun* make-dialog-box (type &rest rest &key (title "XEmacs")
123 (parent (selected-frame)) modal properties autosize
124 spec &allow-other-keys)
123 "Pop up a dialog box. 125 "Pop up a dialog box.
124 TYPE is a symbol, the type of dialog box. Remaining arguments are 126 TYPE is a symbol, the type of dialog box. Remaining arguments are
125 keyword-value pairs, specifying the particular characteristics of the 127 keyword-value pairs, specifying the particular characteristics of the
126 dialog box. The allowed keywords are particular to each type, but 128 dialog box. The allowed keywords are particular to each type, but
127 some standard keywords are common to many types: 129 some standard keywords are common to many types:
566 (if (listp result) 568 (if (listp result)
567 (car result) 569 (car result)
568 (signal 'quit nil))))) 570 (signal 'quit nil)))))
569 (case type 571 (case type
570 (general 572 (general
571 (cl-parsing-keywords 573 (flet ((create-dialog-box-frame ()
572 ((:title "XEmacs") 574 (let* ((ftop (frame-property parent 'top))
573 (:parent (selected-frame)) 575 (fleft (frame-property parent 'left))
574 :modal 576 (fwidth (frame-pixel-width parent))
575 :properties 577 (fheight (frame-pixel-height parent))
576 :autosize 578 (fonth (font-height (face-font 'default)))
577 :spec) 579 (fontw (font-width (face-font 'default)))
578 () 580 (properties (append properties
579 (flet ((create-dialog-box-frame () 581 dialog-frame-plist))
580 (let* ((ftop (frame-property cl-parent 'top)) 582 (dfheight (plist-get properties 'height))
581 (fleft (frame-property cl-parent 'left)) 583 (dfwidth (plist-get properties 'width))
582 (fwidth (frame-pixel-width cl-parent)) 584 (unmapped (plist-get properties
583 (fheight (frame-pixel-height cl-parent)) 585 'initially-unmapped))
584 (fonth (font-height (face-font 'default))) 586 (gutter-spec spec)
585 (fontw (font-width (face-font 'default))) 587 (name (or (plist-get properties 'name) "XEmacs"))
586 (cl-properties (append cl-properties 588 (frame nil))
587 dialog-frame-plist)) 589 (plist-remprop properties 'initially-unmapped)
588 (dfheight (plist-get cl-properties 'height)) 590 ;; allow the user to just provide a glyph
589 (dfwidth (plist-get cl-properties 'width)) 591 (or (glyphp spec) (setq spec (make-glyph spec)))
590 (unmapped (plist-get cl-properties 592 (setq gutter-spec (copy-sequence "\n"))
591 'initially-unmapped)) 593 (set-extent-begin-glyph (make-extent 0 1 gutter-spec)
592 (gutter-spec cl-spec) 594 spec)
593 (name (or (plist-get cl-properties 'name) "XEmacs")) 595 ;; under FVWM at least, if I don't specify the
594 (frame nil)) 596 ;; initial position, it ends up always at (0, 0).
595 (plist-remprop cl-properties 'initially-unmapped) 597 ;; xwininfo doesn't tell me that there are any
596 ;; allow the user to just provide a glyph 598 ;; program-specified position hints, so it must be
597 (or (glyphp cl-spec) (setq cl-spec (make-glyph cl-spec))) 599 ;; an FVWM bug. So just be smashing and position in
598 (setq gutter-spec (copy-sequence "\n")) 600 ;; the center of the selected frame.
599 (set-extent-begin-glyph (make-extent 0 1 gutter-spec) 601 (setq frame
600 cl-spec) 602 (make-frame
601 ;; under FVWM at least, if I don't specify the 603 (append properties
602 ;; initial position, it ends up always at (0, 0). 604 `(popup
603 ;; xwininfo doesn't tell me that there are any 605 ,parent initially-unmapped t
604 ;; program-specified position hints, so it must be 606 menubar-visible-p nil
605 ;; an FVWM bug. So just be smashing and position in 607 has-modeline-p nil
606 ;; the center of the selected frame. 608 default-toolbar-visible-p nil
607 (setq frame 609 top-gutter-visible-p t
608 (make-frame 610 top-gutter-height ,(* dfheight fonth)
609 (append cl-properties 611 top-gutter ,gutter-spec
610 `(popup 612 minibuffer none
611 ,cl-parent initially-unmapped t 613 name ,name
612 menubar-visible-p nil 614 modeline-shadow-thickness 0
613 has-modeline-p nil 615 vertical-scrollbar-visible-p nil
614 default-toolbar-visible-p nil 616 horizontal-scrollbar-visible-p nil
615 top-gutter-visible-p t 617 unsplittable t
616 top-gutter-height ,(* dfheight fonth) 618 internal-border-width 8
617 top-gutter ,gutter-spec 619 left ,(+ fleft (- (/ fwidth 2)
618 minibuffer none 620 (/ (* dfwidth
619 name ,name 621 fontw)
620 modeline-shadow-thickness 0 622 2)))
621 vertical-scrollbar-visible-p nil 623 top ,(+ ftop (- (/ fheight 2)
622 horizontal-scrollbar-visible-p nil 624 (/ (* dfheight
623 unsplittable t 625 fonth)
624 internal-border-width 8 626 2)))))))
625 left ,(+ fleft (- (/ fwidth 2) 627 (set-face-foreground 'modeline [default foreground] frame)
626 (/ (* dfwidth 628 (set-face-background 'modeline [default background] frame)
627 fontw) 629 ;; resize before mapping
628 2))) 630 (when autosize
629 top ,(+ ftop (- (/ fheight 2) 631 (set-frame-displayable-pixel-size
630 (/ (* dfheight 632 frame
631 fonth) 633 (image-instance-width
632 2))))))) 634 (glyph-image-instance spec
633 (set-face-foreground 'modeline [default foreground] frame) 635 (frame-selected-window frame)))
634 (set-face-background 'modeline [default background] frame) 636 (image-instance-height
635 ;; resize before mapping 637 (glyph-image-instance spec
636 (when cl-autosize 638 (frame-selected-window frame)))))
637 (set-frame-displayable-pixel-size 639 ;; somehow, even though the resizing is supposed
638 frame 640 ;; to be while the frame is not visible, a
639 (image-instance-width 641 ;; visible resize is perceptible
640 (glyph-image-instance cl-spec 642 (unless unmapped (make-frame-visible frame))
641 (frame-selected-window frame))) 643 (let ((newbuf (generate-new-buffer " *dialog box*")))
642 (image-instance-height 644 (set-buffer-dedicated-frame newbuf frame)
643 (glyph-image-instance cl-spec 645 (set-frame-property frame 'dialog-box-buffer newbuf)
644 (frame-selected-window frame))))) 646 (set-window-buffer (frame-root-window frame) newbuf)
645 ;; somehow, even though the resizing is supposed 647 (with-current-buffer newbuf
646 ;; to be while the frame is not visible, a 648 (set (make-local-variable 'frame-title-format)
647 ;; visible resize is perceptible 649 title)
648 (unless unmapped (make-frame-visible frame)) 650 (add-local-hook 'delete-frame-hook
649 (let ((newbuf (generate-new-buffer " *dialog box*"))) 651 #'(lambda (frame)
650 (set-buffer-dedicated-frame newbuf frame) 652 (kill-buffer
651 (set-frame-property frame 'dialog-box-buffer newbuf) 653 (frame-property
652 (set-window-buffer (frame-root-window frame) newbuf) 654 frame
653 (with-current-buffer newbuf 655 'dialog-box-buffer))))))
654 (set (make-local-variable 'frame-title-format) 656 frame)))
655 cl-title) 657 (if modal
656 (add-local-hook 'delete-frame-hook 658 (dialog-box-modal-loop '(create-dialog-box-frame))
657 #'(lambda (frame) 659 (create-dialog-box-frame))))
658 (kill-buffer
659 (frame-property
660 frame
661 'dialog-box-buffer))))))
662 frame)))
663 (if cl-modal
664 (dialog-box-modal-loop '(create-dialog-box-frame))
665 (create-dialog-box-frame)))))
666 (question 660 (question
667 (cl-parsing-keywords 661 (remf rest :modal)
668 ((:modal nil)) 662 (if modal
669 t 663 (dialog-box-modal-loop `(make-dialog-box-internal ',type ',rest))
670 (remf cl-keys :modal) 664 (make-dialog-box-internal type rest))))
671 (if cl-modal 665 (t
672 (dialog-box-modal-loop `(make-dialog-box-internal ',type 666 (make-dialog-box-internal type rest))))
673 ',cl-keys))
674 (make-dialog-box-internal type cl-keys))))
675 (t
676 (make-dialog-box-internal type cl-keys)))))
677 667
678 (defun dialog-box-finish (result) 668 (defun dialog-box-finish (result)
679 "Exit a modal dialog box, returning RESULT. 669 "Exit a modal dialog box, returning RESULT.
680 This is meant to be executed from a dialog box callback function." 670 This is meant to be executed from a dialog box callback function."
681 (throw 'internal-dialog-box-finish (list result))) 671 (throw 'internal-dialog-box-finish (list result)))