Mercurial > hg > xemacs-beta

comparison lisp/minibuf.el @ 5118:e0db3c197671 ben-lisp-object

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
merge up to latest default branch, doesn't compile yet
author Ben Wing <ben@xemacs.org>
date Sat, 26 Dec 2009 21:18:49 -0600
parents 74a5eaa67982
children fd36a980d701
comparison
equal deleted inserted replaced
5117:3742ea8250b5 5118:e0db3c197671
37 37
38 ;; 06/11/1997 - Use char-(after|before) instead of 38 ;; 06/11/1997 - Use char-(after|before) instead of
39 ;; (following|preceding)-char. -slb 39 ;; (following|preceding)-char. -slb
40 40
41 ;;; Code: 41 ;;; Code:
42
43 (require 'cl)
42 44
43 (defgroup minibuffer nil 45 (defgroup minibuffer nil
44 "Controling the behavior of the minibuffer." 46 "Controling the behavior of the minibuffer."
45 :group 'environment) 47 :group 'environment)
46 48
403 )) 405 ))
404 (let* ((dir default-directory) 406 (let* ((dir default-directory)
405 (owindow (selected-window)) 407 (owindow (selected-window))
406 (oframe (selected-frame)) 408 (oframe (selected-frame))
407 (window (minibuffer-window)) 409 (window (minibuffer-window))
408 (buffer (if (eq (minibuffer-depth) 0) 410 (buffer (get-buffer-create (format " *Minibuf-%d*"
409 (window-buffer window) 411 (minibuffer-depth))))
410 (get-buffer-create (format " *Minibuf-%d"
411 (minibuffer-depth)))))
412 (frame (window-frame window)) 412 (frame (window-frame window))
413 (mconfig (if (eq frame (selected-frame)) 413 (mconfig (if (eq frame (selected-frame))
414 nil (current-window-configuration frame))) 414 nil (current-window-configuration frame)))
415 (oconfig (current-window-configuration)) 415 (oconfig (current-window-configuration))
416 ;; dynamic scope sucks sucks sucks sucks sucks sucks. 416 ;; dynamic scope sucks sucks sucks sucks sucks sucks.
1467 'variable-history 1467 'variable-history
1468 (if (symbolp default-value) 1468 (if (symbolp default-value)
1469 (symbol-name default-value) 1469 (symbol-name default-value)
1470 default-value)))) 1470 default-value))))
1471 1471
1472 (defun read-buffer (prompt &optional default require-match) 1472 (defun read-buffer (prompt &optional default require-match exclude)
1473 "Read the name of a buffer and return as a string. 1473 "Read the name of a buffer and return as a string.
1474 Prompts with PROMPT. Optional second arg DEFAULT is value to return if user 1474 Prompts with PROMPT. Optional second arg DEFAULT is value to return if user
1475 enters an empty line. If optional third arg REQUIRE-MATCH is non-nil, 1475 enters an empty line. If optional third arg REQUIRE-MATCH is non-nil,
1476 only existing buffer names are allowed." 1476 only existing buffer names are allowed. Optional fourth argument EXCLUDE is
1477 a buffer or a list of buffers to exclude from the completion list."
1478 (when (bufferp exclude)
1479 (setq exclude (list exclude)))
1477 (let ((prompt (if default 1480 (let ((prompt (if default
1478 (format "%s(default %s) " 1481 (format "%s(default %s) "
1479 (gettext prompt) (if (bufferp default) 1482 (gettext prompt) (if (bufferp default)
1480 (buffer-name default) 1483 (buffer-name default)
1481 default)) 1484 default))
1482 prompt)) 1485 prompt))
1483 (alist (mapcar #'(lambda (b) (cons (buffer-name b) b)) 1486 (alist (mapcar #'(lambda (b) (cons (buffer-name b) b))
1484 (buffer-list))) 1487 (remove-if (lambda (elt) (member elt exclude))
1485 result) 1488 (buffer-list))))
1489 result)
1486 (while (progn 1490 (while (progn
1487 (setq result (completing-read prompt alist nil require-match 1491 (setq result (completing-read prompt alist nil require-match
1488 nil 'buffer-history 1492 nil 'buffer-history
1489 (if (bufferp default) 1493 (if (bufferp default)
1490 (buffer-name default) 1494 (buffer-name default)
1698 initial-contents completer) 1702 initial-contents completer)
1699 )) 1703 ))
1700 (add-one-shot-hook 1704 (add-one-shot-hook
1701 'minibuffer-setup-hook 1705 'minibuffer-setup-hook
1702 (lambda () 1706 (lambda ()
1703 ;; #### SCREAM! Create a `file-system-ignore-case' 1707 (and (file-system-ignore-case-p (or dir default-directory))
1704 ;; function, so this kind of stuff is generalized!
1705 (and (eq system-type 'windows-nt)
1706 (set (make-local-variable 'completion-ignore-case) t)) 1708 (set (make-local-variable 'completion-ignore-case) t))
1707 (set 1709 (set
1708 (make-local-variable 1710 (make-local-variable
1709 'completion-display-completion-list-function) 1711 'completion-display-completion-list-function)
1710 #'(lambda (completions) 1712 #'(lambda (completions)
1777 (if (not (string-match 1779 (if (not (string-match
1778 "\\([^$]\\|\\`\\)\\(\\$\\$\\)*\\$\\([A-Za-z0-9_]*\\|{[^}]*\\)\\'" 1780 "\\([^$]\\|\\`\\)\\(\\$\\$\\)*\\$\\([A-Za-z0-9_]*\\|{[^}]*\\)\\'"
1779 string)) 1781 string))
1780 ;; Not doing environment-variable completion hack 1782 ;; Not doing environment-variable completion hack
1781 (let* ((orig (if (equal string "") nil string)) 1783 (let* ((orig (if (equal string "") nil string))
1784 (completion-ignore-case (file-system-ignore-case-p
1785 (or dir default-directory)))
1782 (sstring (if orig (substitute-in-file-name string) string)) 1786 (sstring (if orig (substitute-in-file-name string) string))
1783 (specdir (if orig (file-name-directory sstring) nil)) 1787 (specdir (if orig (file-name-directory sstring) nil))
1784 (name (if orig (file-name-nondirectory sstring) string)) 1788 (name (if orig (file-name-nondirectory sstring) string))
1785 (direct (if specdir (expand-file-name specdir dir) dir))) 1789 (direct (if specdir (expand-file-name specdir dir) dir)))
1786 ;; ~username completion 1790 ;; ~username completion
1814 specdir 1818 specdir
1815 direct 1819 direct
1816 name))) 1820 name)))
1817 ;; An odd number of trailing $'s 1821 ;; An odd number of trailing $'s
1818 (let* ((start (match-beginning 3)) 1822 (let* ((start (match-beginning 3))
1823 (completion-ignore-case (file-system-ignore-case-p
1824 (or dir default-directory)))
1819 (env (substring string 1825 (env (substring string
1820 (cond ((= start (length string)) 1826 (cond ((= start (length string))
1821 ;; "...$" 1827 ;; "...$"
1822 start) 1828 start)
1823 ((= (aref string start) ?{) 1829 ((= (aref string start) ?{)
2055 completer) 2061 completer)
2056 ;; file-p is t if we're reading files, nil if directories. 2062 ;; file-p is t if we're reading files, nil if directories.
2057 (let* ((file-p (eq 'read-file-name-internal completer)) 2063 (let* ((file-p (eq 'read-file-name-internal completer))
2058 (filebuf (get-buffer-create "*Completions*")) 2064 (filebuf (get-buffer-create "*Completions*"))
2059 (dirbuf (and file-p (generate-new-buffer " *mouse-read-file*"))) 2065 (dirbuf (and file-p (generate-new-buffer " *mouse-read-file*")))
2060 (butbuf (generate-new-buffer " *mouse-read-file*")) 2066 (butbuf (generate-new-buffer " *mouse-read-file-buttons*"))
2061 (frame (make-dialog-frame)) 2067 (frame (make-dialog-frame))
2062 filewin dirwin 2068 filewin dirwin
2063 user-data) 2069 user-data
2070 (window-min-height 1)) ; allow button window to be height 2
2064 (unwind-protect 2071 (unwind-protect
2065 (progn 2072 (progn
2066 (reset-buffer filebuf) 2073 (reset-buffer filebuf)
2067 2074
2068 ;; set up the frame. 2075 ;; set up the frame.
2069 (focus-frame frame) 2076 (focus-frame frame)
2070 (let ((window-min-height 1)) 2077 (split-window nil (- (window-height) 2))
2071 ;; #### should be 2 not 3, but that causes
2072 ;; "window too small to split" errors for some
2073 ;; people (but not for me ...) There's a more
2074 ;; fundamental bug somewhere.
2075 (split-window nil (- (frame-height frame) 3)))
2076 (if file-p 2078 (if file-p
2077 (progn 2079 (progn
2078 (split-window-horizontally 16) 2080 (split-window-horizontally 16)
2079 (setq filewin (frame-rightmost-window frame) 2081 (setq filewin (frame-rightmost-window frame)
2080 dirwin (frame-leftmost-window frame)) 2082 dirwin (frame-leftmost-window frame))
2093 ;; (?? I wrote this comment above some time ago, 2095 ;; (?? I wrote this comment above some time ago,
2094 ;; and I don't understand what I'm referring to 2096 ;; and I don't understand what I'm referring to
2095 ;; any more. --ben 2097 ;; any more. --ben
2096 (lambda () 2098 (lambda ()
2097 (mouse-rfn-setup-vars prompt) 2099 (mouse-rfn-setup-vars prompt)
2098 (when (featurep 'scrollbar) 2100 (when-boundp #'scrollbar-width
2099 (set-specifier scrollbar-width 0 (current-buffer))) 2101 (set-specifier scrollbar-width 0 (current-buffer)))
2100 (setq truncate-lines t)))) 2102 (setq truncate-lines t))))
2101 2103
2102 (set-buffer filebuf) 2104 (set-buffer filebuf)
2103 (add-local-hook 'completion-setup-hook rfcshookfun) 2105 (add-local-hook 'completion-setup-hook rfcshookfun)