xemacs-beta: lisp/minibuf.el comparison

comparison lisp/minibuf.el @ 272:c5d627a313b1 r21-0b34

Import from CVS: tag r21-0b34

author	cvs
date	Mon, 13 Aug 2007 10:28:48 +0200
parents	966663fcf606
children	7df0dd720c89

comparison

equal deleted inserted replaced

-:c7b7086b0a39
+:c5d627a313b1
 ;;; minibuf.el --- Minibuffer functions for XEmacs
 ;; Copyright (C) 1992, 1993, 1994, 1997 Free Software Foundation, Inc.
 ;; Copyright (C) 1995 Tinker Systems
 ;; Copyright (C) 1995, 1996 Ben Wing
 ;; Author: Richard Mlynarik
 ;; Created: 2-Oct-92
 ;; Maintainer: XEmacs Development Team
 ;; Keywords: internal, dumped
 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 ;; General Public License for more details.
 ;; You should have received a copy of the GNU General Public License
 ;; along with XEmacs; see the file COPYING.  If not, write to the
 ;; Free Software Foundation, 59 Temple Place - Suite 330,
 ;; Boston, MA 02111-1307, USA.
 ;;; Synched up with: all the minibuffer history stuff is synched with
 ;;; 19.30.  Not sure about the rest.
 (define-key minibuffer-local-map "\M-p" 'previous-history-element)
 (define-key minibuffer-local-map '[next]  "\M-n")
 (define-key minibuffer-local-map '[prior] "\M-p")
 (define-key minibuffer-local-map "\M-r" 'previous-matching-history-element)
 (define-key minibuffer-local-map "\M-s" 'next-matching-history-element)
 (define-key minibuffer-local-must-match-map [next]
 'next-complete-history-element)
 (define-key minibuffer-local-must-match-map [prior]
 'previous-complete-history-element)
 ;; This is an experiment--make up and down arrows do history.
 (buffer (if (eq (minibuffer-depth) 0)
 (window-buffer window)
 		   (get-buffer-create (format " *Minibuf-%d"
 					      (minibuffer-depth)))))
 (frame (window-frame window))
 (mconfig (if (eq frame (selected-frame))
 nil (current-window-configuration frame)))
 (oconfig (current-window-configuration))
 	 ;; dynamic scope sucks sucks sucks sucks sucks sucks.
 	 ;; `M-x doctor' makes history a local variable, and thus
 	 ;; our binding above is buffer-local and doesn't apply
 ;;
 ;; This routine also offers to edit .emacs for you to get rid of this
 ;; complaint, like `disabled' commands do, since it's likely that non-novice
 ;; users will be annoyed by this change, so we give them an easy way to get
 ;; rid of it forever.
 ;;
 (beep t 'minibuffer-limit-exceeded)
 (message
 "Minibuffer already active: abort it with `^]', enable new one with `n': ")
 (let ((char (let ((cursor-in-echo-area t)) ; #### doesn't always work??
 		(read-char))))
 	(save-excursion
 	  (set-buffer
 	   (find-file-noselect
 	    (substitute-in-file-name custom-file)))
 	  (goto-char (point-min))
 	  (if (re-search-forward
 	       "^(setq minibuffer-max-depth \\([0-9]+\\|'?nil\\|'?()\\))\n"
 	       nil t)
 	      (delete-region (match-beginning 0 ) (match-end 0))
 	    ;; Must have been disabled by default.
 	    (goto-char (point-max)))
 (message nil)
 (insert m))
 (let ((inhibit-quit t))
 (sit-for 2)
 (delete-region savemax (point-max))
 ;;  If the user types a ^G while we're in sit-for, then quit-flag
 ;;  gets set. In this case, we want that ^G to be interpreted
 ;;  as a normal character, and act just like typeahead.
 (if (and quit-flag (not unread-command-event))
 (setq unread-command-event (character-to-event (quit-char))
 quit-flag nil)))))
 )
 ;; 0 'none                 no possible completion
 ;; 1 'unique               was already an exact and unique completion
 ;; 3 'exact                was already an exact (but nonunique) completion
 ;; NOT USED 'completed-exact-unique completed to an exact and completion
 ;; 4 'completed-exact      completed to an exact (but nonunique) completion
 ;; 5 'completed            some completion happened
 ;; 6 'uncompleted          no completion happened
 (defun minibuffer-do-completion-1 (buffer-string completion)
 (cond ((not completion)
 (and (not (eq char ?\ ))
 (funcall foo " "))
 (and (not (eq char ?\-))
 (funcall foo "-"))
 (progn
 (if completion-auto-help
 (minibuffer-completion-help)
 ;; New message, only in this new Lisp code
 			    ;; rewritten for I18N3 snarfing
 			    (if (eq status 'exact)
 				(temp-minibuffer-message
 	     elt)))
 	;; FSF has point-min here.
 	(goto-char (point-max))))))
 (defun previous-history-element (n)
-"Inserts the previous element of the minibuffer history into the minibuffer."
+"Insert the previous element of the minibuffer history into the minibuffer."
 (interactive "p")
 (next-history-element (- n)))
 (defun next-complete-history-element (n)
 "Get next element of history which is a completion of minibuffer contents."
 (defun read-buffer (prompt &optional default require-match)
 "Read the name of a buffer and return as a string.
 Prompts with PROMPT.  Optional second arg DEFAULT is value to return if user
 enters an empty line.  If optional third arg REQUIRE-MATCH is non-nil,
 only existing buffer names are allowed."
 (let ((prompt (if default
 (format "%s(default %s) "
 (gettext prompt) (if (bufferp default)
 						 (buffer-name default)
 					       default))
 prompt))
 (if (bufferp result)
 (buffer-name result)
 result)))
 (defun read-number (prompt &optional integers-only)
-"Reads a number from the minibuffer."
+"Read a number from the minibuffer."
 (let ((pred (if integers-only 'integerp 'numberp))
 	num)
 (while (not (funcall pred num))
 (setq num (condition-case ()
 		    (let ((minibuffer-completion-table nil))
 (setq o (1+ o) n (1+ n))
 (if (eq ch ?$)
 ;; already aset by make-string initial-value
 (setq n (1+ n))))
 new))))
 (defun read-file-name-2 (history prompt dir default
 				 must-match initial-contents
 				 completer)
 (if (not dir)
 (setq dir default-directory))
 (setq dir (abbreviate-file-name dir t))
 	 :user-data dir-p
 	 :reference-buffer minibuf
 	 :activate-callback 'read-file-name-activate-callback)
 	(goto-char (point-min) completion-buf)))))
 (defun read-file-name-1 (history prompt dir default
 				 must-match initial-contents
 				 completer)
 (if (should-use-dialog-box-p)
 ;; this calls read-file-name-2
 (mouse-read-file-name-1 history prompt dir default must-match
 Non-nil and non-t means also require confirmation after completion.
 Fifth arg INITIAL-CONTENTS specifies text to start with.
 Sixth arg HISTORY specifies the history list to use.  Default is
 `file-name-history'.
 DIR defaults to current buffer's directory default."
 (read-file-name-1
 (or history 'file-name-history)
 prompt dir (or default default-directory) must-match initial-contents
 'read-directory-name-internal))
 	    string))
 ;; Not doing environment-variable completion hack
 (let* ((orig (if (equal string "") nil string))
 (sstring (if orig (substitute-in-file-name string) string))
 (specdir (if orig (file-name-directory sstring) nil)))
 (funcall completer
 action
 orig
 sstring
 specdir
 (if specdir (expand-file-name specdir dir) dir)
 (if orig (file-name-nondirectory sstring) string)))
 ;; An odd number of trailing $'s
 (let* ((start (match-beginning 3))
 (env (substring string
 (cond ((= start (length string))
 ;; "...$"
 start)
 ((= (aref string start) ?{)
 ;; "...${..."
 (alist #'(lambda ()
 (mapcar #'(lambda (x)
 (cons (substring x 0 (string-match "=" x))
 'nil))
 process-environment))))
 	(cond ((eq action 'lambda)
 nil)
 ((eq action 't)
 ;; all completions
 (mapcar #'(lambda (p)
 (un-substitute-in-file-name (getenv env))))
 (t nil))))))))
 (defun read-file-name-internal (string dir action)
 (read-file-name-internal-1
 string dir action
 #'(lambda (action orig string specdir dir name)
 (cond ((eq action 'lambda)
 (if (not orig)
 nil
 (let ((sstring (condition-case nil
 (expand-file-name string)
 (error nil))))
 (if (not sstring)
 ;; Some pathname syntax error in string
 nil
 ;; substitute-in-file-name did something
 tem
 val)))))))))
 (defun read-directory-name-internal (string dir action)
 (read-file-name-internal-1
 string dir action
 #'(lambda (action orig string specdir dir name)
 (let* ((dirs #'(lambda (fn)
 		       (let ((l (if (equal name "")
 				    (directory-files
 				     ""
 				     nil
 				     'directories)
 				  (directory-files
 				   dir
 				   nil
 				   (concat "\\`" (regexp-quote name))
 				   nil
 				   'directories))))
 			 (mapcar fn
 				 (cond ((eq system-type 'vax-vms)
 nil
 		 (file-directory-p string)))
 ((eq action 't)
 ;; all completions
 (funcall dirs #'(lambda (n)
 				 (un-substitute-in-file-name
 				  (file-name-as-directory n)))))
 (t
 ;; complete
 (let ((val (try-completion
 name
 			 tem
 		       val))))))))))
 (defun append-expand-filename (file-string string)
 "Append STRING to FILE-STRING differently depending on whether STRING
 is a username (~string), an environment variable ($string),
 or a filename (/string).  The resultant string is returned with the
 environment variable or username expanded and resolved to indicate
 whether it is a file(/result) or a directory (/result/)."
 (let ((file
 	 (cond ((string-match "\\([~$]\\)\\([^~$/]*\\)$" file-string)
 		(cond ((string= (substring file-string
 					   (match-beginning 1)
 					   (match-end 1)) "~")
 		       (concat (substring file-string 0 (match-end 1))
 			       string))
 		      (t (substitute-in-file-name
 			  (concat (substring file-string 0 (match-end 1))
 				  string)))))
 	       (t (concat (file-name-directory
 			   (substitute-in-file-name file-string)) string))))
 	result)
 (cond ((stringp (setq result (and (file-exists-p (expand-file-name file))
 				      (read-file-name-internal
 				       (condition-case nil
 					   (expand-file-name file)
 					 (error file))
 				       "" nil))))
 	   result)
 	  (t file))))
 (defun mouse-file-display-completion-list (window dir minibuf user-data)
 (let ((standard-output (window-buffer window)))
 (condition-case nil
 	(display-completion-list
 	 (directory-files dir nil nil nil t)
 	 :window-width (* 2 (window-width window))
 	 :activate-callback
 	 'mouse-read-file-name-activate-callback
 	 :user-data user-data
 	(reset-buffer dirbuff)
 	(mouse-directory-display-completion-list dirwin full minibuf
 						 user-data)))))
 ;; this is rather cheesified but gets the job done.
 (defun mouse-read-file-name-1 (history prompt dir default
 				 must-match initial-contents
 				 completer)
 (let* ((file-p (eq 'read-file-name-internal completer))
 	 (filebuf (get-buffer-create "*Completions*"))
 	 (dirbuff (and file-p (generate-new-buffer " *mouse-read-file*")))
 	  (when dir
 	    (setq default-directory dir))
 	  (when (featurep 'scrollbar)
 	    (set-specifier scrollbar-width 0 butbuff))
 	  (insert "                 ")
 	  (insert-gui-button (make-gui-button "OK"
 					      (lambda (foo)
 						(exit-minibuffer))))
 	  (insert "                 ")
 	  (insert-gui-button (make-gui-button "Cancel"
 					      (lambda (foo)
 		     (setq truncate-lines t)))))
 	    (unwind-protect
 		(progn
 		  (add-hook 'minibuffer-setup-hook rfhookfun)
 		  (add-hook 'completion-setup-hook rfcshookfun)
 		  (read-file-name-2 history prompt dir default
 				    must-match initial-contents
 				    completer))
 	      (remove-hook 'minibuffer-setup-hook rfhookfun)
 	      (remove-hook 'completion-setup-hook rfcshookfun))))
 (delete-frame frame)
 ;; obsolete, and `read-color-completion-table' conses (mapcar #'list
 ;; (color-list)), optionally caching the results.
 ;; Ben wanted all of the possibilities from the `configure' script used
 ;; here, but I think this is way too many.  I already trimmed the R4 variants
 ;; and a few obvious losers from the list.  --Stig
 (defvar x-library-search-path '("/usr/X11R6/lib/X11/"
 				"/usr/X11R5/lib/X11/"
 				"/usr/lib/X11R6/X11/"
 				"/usr/lib/X11R5/X11/"
 				"/usr/local/X11R6/lib/X11/"

Mercurial > hg > xemacs-beta

comparison lisp/minibuf.el @ 272:c5d627a313b1 r21-0b34