Mercurial > hg > xemacs-beta

comparison lisp/minibuf.el @ 404:2f8bb876ab1d r21-2-32

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-32
author cvs
date Mon, 13 Aug 2007 11:16:07 +0200
parents 74fd4e045ea6
children 501cfd01ee6d
comparison
equal deleted inserted replaced
403:9f011ab08d48 404:2f8bb876ab1d
1 ;;; minibuf.el --- Minibuffer functions for XEmacs 1 ;;; minibuf.el --- Minibuffer functions for XEmacs
2 2
3 ;; Copyright (C) 1992, 1993, 1994, 1997 Free Software Foundation, Inc. 3 ;; Copyright (C) 1992, 1993, 1994, 1997 Free Software Foundation, Inc.
4 ;; Copyright (C) 1995 Tinker Systems 4 ;; Copyright (C) 1995 Tinker Systems.
5 ;; Copyright (C) 1995, 1996 Ben Wing 5 ;; Copyright (C) 1995, 1996, 2000 Ben Wing.
6 6
7 ;; Author: Richard Mlynarik 7 ;; Author: Richard Mlynarik
8 ;; Created: 2-Oct-92 8 ;; Created: 2-Oct-92
9 ;; Maintainer: XEmacs Development Team 9 ;; Maintainer: XEmacs Development Team
10 ;; Keywords: internal, dumped 10 ;; Keywords: internal, dumped
109 ;; Moved to C. The minibuffer prompt must be setup before this is run 109 ;; Moved to C. The minibuffer prompt must be setup before this is run
110 ;; and that can only be done from the C side. 110 ;; and that can only be done from the C side.
111 ;(defvar minibuffer-setup-hook nil 111 ;(defvar minibuffer-setup-hook nil
112 ; "Normal hook run just after entry to minibuffer.") 112 ; "Normal hook run just after entry to minibuffer.")
113 113
114 ;; see comment at list-mode-hook.
115 (put 'minibuffer-setup-hook 'permanent-local t)
116
114 (defvar minibuffer-exit-hook nil 117 (defvar minibuffer-exit-hook nil
115 "Normal hook run just after exit from minibuffer.") 118 "Normal hook run just after exit from minibuffer.")
119 (put 'minibuffer-exit-hook 'permanent-local t)
116 120
117 (defvar minibuffer-help-form nil 121 (defvar minibuffer-help-form nil
118 "Value that `help-form' takes on inside the minibuffer.") 122 "Value that `help-form' takes on inside the minibuffer.")
119 123
120 (defvar minibuffer-default nil 124 (defvar minibuffer-default nil
606 610
607 ;;;; Guts of minibuffer completion 611 ;;;; Guts of minibuffer completion
608 612
609 613
610 ;; Used by minibuffer-do-completion 614 ;; Used by minibuffer-do-completion
611 (defvar last-exact-completion) 615 (defvar last-exact-completion nil)
612 616
613 (defun temp-minibuffer-message (m) 617 (defun temp-minibuffer-message (m)
614 (let ((savemax (point-max))) 618 (let ((savemax (point-max)))
615 (save-excursion 619 (save-excursion
616 (goto-char (point-max)) 620 (goto-char (point-max))
1444 (defun read-variable (prompt &optional default-value) 1448 (defun read-variable (prompt &optional default-value)
1445 "Read the name of a user variable and return it as a symbol. 1449 "Read the name of a user variable and return it as a symbol.
1446 Prompts with PROMPT. By default, return DEFAULT-VALUE. 1450 Prompts with PROMPT. By default, return DEFAULT-VALUE.
1447 A user variable is one whose documentation starts with a `*' character." 1451 A user variable is one whose documentation starts with a `*' character."
1448 (intern (completing-read prompt obarray 'user-variable-p t nil 1452 (intern (completing-read prompt obarray 'user-variable-p t nil
1449 'variable-history default-value))) 1453 'variable-history
1454 (if (symbolp default-value)
1455 (symbol-name default-value)
1456 default-value))))
1450 1457
1451 (defun read-buffer (prompt &optional default require-match) 1458 (defun read-buffer (prompt &optional default require-match)
1452 "Read the name of a buffer and return as a string. 1459 "Read the name of a buffer and return as a string.
1453 Prompts with PROMPT. Optional second arg DEFAULT is value to return if user 1460 Prompts with PROMPT. Optional second arg DEFAULT is value to return if user
1454 enters an empty line. If optional third arg REQUIRE-MATCH is non-nil, 1461 enters an empty line. If optional third arg REQUIRE-MATCH is non-nil,
1636 completer) 1643 completer)
1637 (if (should-use-dialog-box-p) 1644 (if (should-use-dialog-box-p)
1638 ;; this calls read-file-name-2 1645 ;; this calls read-file-name-2
1639 (mouse-read-file-name-1 history prompt dir default must-match 1646 (mouse-read-file-name-1 history prompt dir default must-match
1640 initial-contents completer) 1647 initial-contents completer)
1641 (let ((rfhookfun 1648 (add-one-shot-hook
1642 (lambda () 1649 'minibuffer-setup-hook
1643 ;; #### SCREAM! Create a `file-system-ignore-case' 1650 (lambda ()
1644 ;; function, so this kind of stuff is generalized! 1651 ;; #### SCREAM! Create a `file-system-ignore-case'
1645 (and (eq system-type 'windows-nt) 1652 ;; function, so this kind of stuff is generalized!
1646 (set (make-local-variable 'completion-ignore-case) t)) 1653 (and (eq system-type 'windows-nt)
1647 (set 1654 (set (make-local-variable 'completion-ignore-case) t))
1648 (make-local-variable 1655 (set
1649 'completion-display-completion-list-function) 1656 (make-local-variable
1650 #'(lambda (completions) 1657 'completion-display-completion-list-function)
1651 (display-completion-list 1658 #'(lambda (completions)
1652 completions 1659 (display-completion-list
1653 :user-data (not (eq completer 'read-file-name-internal)) 1660 completions
1654 :activate-callback 1661 :user-data (not (eq completer 'read-file-name-internal))
1655 'read-file-name-activate-callback))) 1662 :activate-callback
1656 ;; kludge! 1663 'read-file-name-activate-callback)))))
1657 (remove-hook 'minibuffer-setup-hook rfhookfun) 1664 (read-file-name-2 history prompt dir default must-match
1658 ))) 1665 initial-contents completer)))
1659 (unwind-protect
1660 (progn
1661 (add-hook 'minibuffer-setup-hook rfhookfun)
1662 (read-file-name-2 history prompt dir default must-match
1663 initial-contents completer))
1664 (remove-hook 'minibuffer-setup-hook rfhookfun)))))
1665 1666
1666 (defun read-file-name (prompt 1667 (defun read-file-name (prompt
1667 &optional dir default must-match initial-contents 1668 &optional dir default must-match initial-contents
1668 history) 1669 history)
1669 "Read file name, prompting with PROMPT and completing in directory DIR. 1670 "Read file name, prompting with PROMPT and completing in directory DIR.
1923 (error file)) 1924 (error file))
1924 "" nil)))) 1925 "" nil))))
1925 result) 1926 result)
1926 (t file)))) 1927 (t file))))
1927 1928
1929 (defun mouse-rfn-setup-vars (prompt)
1930 ;; a specifier would be nice.
1931 (set (make-local-variable 'frame-title-format)
1932 (capitalize-string-as-title
1933 ;; Delete ": " off the end. There must be an easier way!
1934 (let ((end-pos (length prompt)))
1935 (if (and (> end-pos 0) (eq (aref prompt (1- end-pos)) ? ))
1936 (setq end-pos (1- end-pos)))
1937 (if (and (> end-pos 0) (eq (aref prompt (1- end-pos)) ?:))
1938 (setq end-pos (1- end-pos)))
1939 (substring prompt 0 end-pos))))
1940 ;; ensure that killing the frame works right,
1941 ;; instead of leaving us in the minibuffer.
1942 (add-local-hook 'delete-frame-hook
1943 #'(lambda (frame)
1944 (abort-recursive-edit))))
1945
1928 (defun mouse-file-display-completion-list (window dir minibuf user-data) 1946 (defun mouse-file-display-completion-list (window dir minibuf user-data)
1929 (let ((standard-output (window-buffer window))) 1947 (let ((standard-output (window-buffer window)))
1930 (condition-case nil 1948 (condition-case nil
1931 (display-completion-list 1949 (display-completion-list
1932 (directory-files dir nil nil nil t) 1950 (directory-files dir nil nil nil t)
1933 :window-width (* 2 (window-width window)) 1951 :window-width (window-width window)
1952 :window-height (window-text-area-height window)
1953 :completion-string ""
1934 :activate-callback 1954 :activate-callback
1935 'mouse-read-file-name-activate-callback 1955 'mouse-read-file-name-activate-callback
1936 :user-data user-data 1956 :user-data user-data
1937 :reference-buffer minibuf 1957 :reference-buffer minibuf
1938 :help-string "") 1958 :help-string "")
1939 (t nil)))) 1959 (t nil))
1960 ))
1940 1961
1941 (defun mouse-directory-display-completion-list (window dir minibuf user-data) 1962 (defun mouse-directory-display-completion-list (window dir minibuf user-data)
1942 (let ((standard-output (window-buffer window))) 1963 (let ((standard-output (window-buffer window)))
1943 (condition-case nil 1964 (condition-case nil
1944 (display-completion-list 1965 (display-completion-list
1945 (delete "." (directory-files dir nil nil nil 1)) 1966 (delete "." (directory-files dir nil nil nil 1))
1946 :window-width (window-width window) 1967 :window-width (window-width window)
1968 :window-height (window-text-area-height window)
1969 :completion-string ""
1947 :activate-callback 1970 :activate-callback
1948 'mouse-read-file-name-activate-callback 1971 'mouse-read-file-name-activate-callback
1949 :user-data user-data 1972 :user-data user-data
1950 :reference-buffer minibuf 1973 :reference-buffer minibuf
1951 :help-string "") 1974 :help-string "")
1952 (t nil)))) 1975 (t nil))
1976 ))
1953 1977
1954 (defun mouse-read-file-name-activate-callback (event extent user-data) 1978 (defun mouse-read-file-name-activate-callback (event extent user-data)
1955 (let* ((file (extent-string extent)) 1979 (let* ((file (extent-string extent))
1956 (minibuf (symbol-value-in-buffer 'completion-reference-buffer 1980 (minibuf (symbol-value-in-buffer 'completion-reference-buffer
1957 (extent-object extent))) 1981 (extent-object extent)))
1958 (in-dir (buffer-substring nil nil minibuf)) 1982 (ministring (buffer-substring nil nil minibuf))
1983 (in-dir (file-name-directory ministring))
1959 (full (expand-file-name file in-dir)) 1984 (full (expand-file-name file in-dir))
1960 (filebuf (nth 0 user-data)) 1985 (filebuf (nth 0 user-data))
1961 (dirbuff (nth 1 user-data)) 1986 (dirbuf (nth 1 user-data))
1962 (filewin (nth 2 user-data)) 1987 (filewin (nth 2 user-data))
1963 (dirwin (nth 3 user-data))) 1988 (dirwin (nth 3 user-data)))
1964 (if (file-regular-p full) 1989 (if (file-regular-p full)
1965 (default-choose-completion event extent minibuf) 1990 (default-choose-completion event extent minibuf)
1966 (erase-buffer minibuf) 1991 (erase-buffer minibuf)
1967 (insert-string (file-name-as-directory 1992 (insert-string (file-name-as-directory
1968 (abbreviate-file-name full t)) minibuf) 1993 (abbreviate-file-name full t)) minibuf)
1969 (reset-buffer filebuf) 1994 (reset-buffer filebuf)
1970 (if (not dirbuff) 1995 (if (not dirbuf)
1971 (mouse-directory-display-completion-list filewin full minibuf 1996 (mouse-directory-display-completion-list filewin full minibuf
1972 user-data) 1997 user-data)
1973 (mouse-file-display-completion-list filewin full minibuf user-data) 1998 (mouse-file-display-completion-list filewin full minibuf user-data)
1974 (reset-buffer dirbuff) 1999 (reset-buffer dirbuf)
1975 (mouse-directory-display-completion-list dirwin full minibuf 2000 (mouse-directory-display-completion-list dirwin full minibuf
1976 user-data))))) 2001 user-data)))))
1977 2002
1978 ;; this is rather cheesified but gets the job done. 2003 ;; our cheesy but god-awful time consuming file dialog box implementation.
2004 ;; this will be replaced with use of the native file dialog box (when
2005 ;; available).
1979 (defun mouse-read-file-name-1 (history prompt dir default 2006 (defun mouse-read-file-name-1 (history prompt dir default
1980 must-match initial-contents 2007 must-match initial-contents
1981 completer) 2008 completer)
2009 ;; file-p is t if we're reading files, nil if directories.
1982 (let* ((file-p (eq 'read-file-name-internal completer)) 2010 (let* ((file-p (eq 'read-file-name-internal completer))
1983 (filebuf (get-buffer-create "*Completions*")) 2011 (filebuf (get-buffer-create "*Completions*"))
1984 (dirbuff (and file-p (generate-new-buffer " *mouse-read-file*"))) 2012 (dirbuf (and file-p (generate-new-buffer " *mouse-read-file*")))
1985 (butbuff (generate-new-buffer " *mouse-read-file*")) 2013 (butbuf (generate-new-buffer " *mouse-read-file*"))
1986 (frame (make-dialog-frame)) 2014 (frame (make-dialog-frame))
1987 filewin dirwin 2015 filewin dirwin
1988 user-data) 2016 user-data)
1989 (unwind-protect 2017 (unwind-protect
1990 (progn 2018 (progn
1991 (reset-buffer filebuf) 2019 (reset-buffer filebuf)
1992 (select-frame frame) 2020
2021 ;; set up the frame.
2022 (focus-frame frame)
1993 (let ((window-min-height 1)) 2023 (let ((window-min-height 1))
1994 ;; #### should be 2 not 3, but that causes 2024 ;; #### should be 2 not 3, but that causes
1995 ;; "window too small to split" errors for some 2025 ;; "window too small to split" errors for some
1996 ;; people (but not for me ...) There's a more 2026 ;; people (but not for me ...) There's a more
1997 ;; fundamental bug somewhere. 2027 ;; fundamental bug somewhere.
2000 (progn 2030 (progn
2001 (split-window-horizontally 16) 2031 (split-window-horizontally 16)
2002 (setq filewin (frame-rightmost-window frame) 2032 (setq filewin (frame-rightmost-window frame)
2003 dirwin (frame-leftmost-window frame)) 2033 dirwin (frame-leftmost-window frame))
2004 (set-window-buffer filewin filebuf) 2034 (set-window-buffer filewin filebuf)
2005 (set-window-buffer dirwin dirbuff)) 2035 (set-window-buffer dirwin dirbuf))
2006 (setq filewin (frame-highest-window frame)) 2036 (setq filewin (frame-highest-window frame))
2007 (set-window-buffer filewin filebuf)) 2037 (set-window-buffer filewin filebuf))
2008 (setq user-data (list filebuf dirbuff filewin dirwin)) 2038 (setq user-data (list filebuf dirbuf filewin dirwin))
2009 (set-window-buffer (frame-lowest-window frame) butbuff) 2039 (set-window-buffer (frame-lowest-window frame) butbuf)
2010 (set-buffer butbuff) 2040
2041 ;; set up completion buffers.
2042 (let ((rfcshookfun
2043 ;; kludge!
2044 ;; #### I really need to flesh out the object
2045 ;; hierarchy better to avoid these kludges.
2046 ;; (?? I wrote this comment above some time ago,
2047 ;; and I don't understand what I'm referring to
2048 ;; any more. --ben
2049 (lambda ()
2050 (mouse-rfn-setup-vars prompt)
2051 (when (featurep 'scrollbar)
2052 (set-specifier scrollbar-width 0 (current-buffer)))
2053 (setq truncate-lines t))))
2054
2055 (set-buffer filebuf)
2056 (add-local-hook 'completion-setup-hook rfcshookfun)
2057 (when file-p
2058 (set-buffer dirbuf)
2059 (add-local-hook 'completion-setup-hook rfcshookfun)))
2060
2061 ;; set up minibuffer.
2062 (add-one-shot-hook
2063 'minibuffer-setup-hook
2064 (lambda ()
2065 (if (not file-p)
2066 (mouse-directory-display-completion-list
2067 filewin dir (current-buffer) user-data)
2068 (mouse-file-display-completion-list
2069 filewin dir (current-buffer) user-data)
2070 (mouse-directory-display-completion-list
2071 dirwin dir (current-buffer) user-data))
2072 (set
2073 (make-local-variable
2074 'completion-display-completion-list-function)
2075 (lambda (completions)
2076 (display-completion-list
2077 completions
2078 :help-string ""
2079 :window-width (window-width filewin)
2080 :window-height (window-text-area-height filewin)
2081 :completion-string ""
2082 :activate-callback
2083 'mouse-read-file-name-activate-callback
2084 :user-data user-data)))
2085 (mouse-rfn-setup-vars prompt)
2086 (save-selected-window
2087 ;; kludge to ensure the frame title is correct.
2088 ;; the minibuffer leaves the frame title the way
2089 ;; it was before (i.e. of the selected window before
2090 ;; the dialog box was opened), so to get it correct
2091 ;; we have to be tricky.
2092 (select-window filewin)
2093 (redisplay-frame nil t)
2094 ;; #### another kludge. sometimes the focus ends up
2095 ;; back in the main window, not the dialog box. it
2096 ;; occurs randomly and it's not possible to reliably
2097 ;; reproduce. We try to fix it by draining non-user
2098 ;; events and then setting the focus back on the frame.
2099 (sit-for 0 t)
2100 (focus-frame frame))))
2101
2102 ;; set up button buffer.
2103 (set-buffer butbuf)
2104 (mouse-rfn-setup-vars prompt)
2011 (when dir 2105 (when dir
2012 (setq default-directory dir)) 2106 (setq default-directory dir))
2013 (when (featurep 'scrollbar) 2107 (when (featurep 'scrollbar)
2014 (set-specifier scrollbar-width 0 butbuff)) 2108 (set-specifier scrollbar-width 0 butbuf))
2015 (insert " ") 2109 (insert " ")
2016 (insert-gui-button (make-gui-button "OK" 2110 (insert-gui-button (make-gui-button "OK"
2017 (lambda (foo) 2111 (lambda (foo)
2018 (exit-minibuffer)))) 2112 (exit-minibuffer))))
2019 (insert " ") 2113 (insert " ")
2020 (insert-gui-button (make-gui-button "Cancel" 2114 (insert-gui-button (make-gui-button "Cancel"
2021 (lambda (foo) 2115 (lambda (foo)
2022 (abort-recursive-edit)))) 2116 (abort-recursive-edit))))
2023 (let ((rfhookfun 2117
2024 (lambda () 2118 ;; now start reading filename.
2025 (if (not file-p) 2119 (read-file-name-2 history prompt dir default
2026 (mouse-directory-display-completion-list 2120 must-match initial-contents
2027 filewin dir (current-buffer) user-data) 2121 completer))
2028 (mouse-file-display-completion-list filewin dir 2122
2029 (current-buffer) 2123 ;; always clean up.
2030 user-data) 2124 ;; get rid of our hook that calls abort-recursive-edit -- not a good
2031 (mouse-directory-display-completion-list dirwin dir 2125 ;; idea here.
2032 (current-buffer) 2126 (kill-local-variable 'delete-frame-hook)
2033 user-data))
2034 (set
2035 (make-local-variable
2036 'completion-display-completion-list-function)
2037 #'(lambda (completions)
2038 (display-completion-list
2039 completions
2040 :help-string ""
2041 :activate-callback
2042 'mouse-read-file-name-activate-callback
2043 :user-data user-data)))
2044 ;; kludge!
2045 (remove-hook 'minibuffer-setup-hook rfhookfun)
2046 ))
2047 (rfcshookfun
2048 ;; kludge!
2049 ;; #### I really need to flesh out the object
2050 ;; hierarchy better to avoid these kludges.
2051 (lambda ()
2052 (save-excursion
2053 (set-buffer standard-output)
2054 (setq truncate-lines t)))))
2055 (unwind-protect
2056 (progn
2057 (add-hook 'minibuffer-setup-hook rfhookfun)
2058 (add-hook 'completion-setup-hook rfcshookfun)
2059 (read-file-name-2 history prompt dir default
2060 must-match initial-contents
2061 completer))
2062 (remove-hook 'minibuffer-setup-hook rfhookfun)
2063 (remove-hook 'completion-setup-hook rfcshookfun))))
2064 (delete-frame frame) 2127 (delete-frame frame)
2065 (kill-buffer filebuf) 2128 (kill-buffer filebuf)
2066 (kill-buffer butbuff) 2129 (kill-buffer butbuf)
2067 (and dirbuff (kill-buffer dirbuff))))) 2130 (and dirbuf (kill-buffer dirbuf)))))
2068 2131
2069 (defun read-face (prompt &optional must-match) 2132 (defun read-face (prompt &optional must-match)
2070 "Read the name of a face from the minibuffer and return it as a symbol." 2133 "Read the name of a face from the minibuffer and return it as a symbol."
2071 (intern (completing-read prompt obarray 'find-face must-match))) 2134 (intern (completing-read prompt obarray 'find-face must-match)))
2072 2135