xemacs-beta: lisp/minibuf.el comparison

comparison lisp/minibuf.el @ 442:abe6d1db359e r21-2-36

Import from CVS: tag r21-2-36

author	cvs
date	Mon, 13 Aug 2007 11:35:02 +0200
parents	8de8e3f6228a
children	576fb035e263

comparison

equal deleted inserted replaced

-:72a7cfa4a488
+:abe6d1db359e
 ;;; minibuf.el --- Minibuffer functions for XEmacs
 ;; Copyright (C) 1992, 1993, 1994, 1997 Free Software Foundation, Inc.
-;; Copyright (C) 1995 Tinker Systems
+;; Copyright (C) 1995 Tinker Systems.
-;; Copyright (C) 1995, 1996 Ben Wing
+;; Copyright (C) 1995, 1996, 2000 Ben Wing.
 ;; Author: Richard Mlynarik
 ;; Created: 2-Oct-92
 ;; Maintainer: XEmacs Development Team
 ;; Keywords: internal, dumped
 :type 'boolean
 :group 'minibuffer)
 (defcustom minibuffer-history-uniquify t
 "*Non-nil means when adding an item to a minibuffer history, remove
-previous occurances of the same item from the history list first,
+previous occurrences of the same item from the history list first,
 rather than just consing the new element onto the front of the list."
 :type 'boolean
 :group 'minibuffer)
 (defvar minibuffer-completion-table nil
 ;; Moved to C.  The minibuffer prompt must be setup before this is run
 ;; and that can only be done from the C side.
 ;(defvar minibuffer-setup-hook nil
 ;  "Normal hook run just after entry to minibuffer.")
+;; see comment at list-mode-hook.
+(put 'minibuffer-setup-hook 'permanent-local t)
 (defvar minibuffer-exit-hook nil
 "Normal hook run just after exit from minibuffer.")
+(put 'minibuffer-exit-hook 'permanent-local t)
 (defvar minibuffer-help-form nil
 "Value that `help-form' takes on inside the minibuffer.")
 (defvar minibuffer-default nil
 ;;;; Guts of minibuffer completion
 ;; Used by minibuffer-do-completion
-(defvar last-exact-completion)
+(defvar last-exact-completion nil)
 (defun temp-minibuffer-message (m)
 (let ((savemax (point-max)))
 (save-excursion
 (goto-char (point-max))
 	      initial-minibuffer-history-position)
 (setq current-minibuffer-contents (buffer-string)
 	    current-minibuffer-point (point)))
 (let ((narg (- minibuffer-history-position n))
 	  (minimum (if minibuffer-default -1 0)))
+;; a weird special case here; when in repeat-complex-command, we're
+;; trying to edit the top command, and minibuffer-history-position
+;; points to 1, the next-to-top command.  in this case, the top
+;; command in the history is suppressed in favor of the one being
+;; edited, and there is no more command below it, except maybe the
+;; default.
+(if (and (zerop narg) (eq minibuffer-history-position
+				initial-minibuffer-history-position))
+	  (setq minimum (1+ minimum)))
 (cond ((< narg minimum)
 	     (error (if minibuffer-default
 			"No following item in %s"
 		      "No following item in %s; no default available")
 		    minibuffer-history-variable))
 (setq minibuffer-history-position narg)
 (if (eq narg initial-minibuffer-history-position)
 	  (progn
 	    (insert current-minibuffer-contents)
 	    (goto-char current-minibuffer-point))
-	(let ((elt (if (>= narg 0)
+	(let ((elt (if (> narg 0)
 		       (nth (1- minibuffer-history-position)
 			    (symbol-value minibuffer-history-variable))
 		     minibuffer-default)))
 	  (insert
 	   (if (not (stringp elt))
 (defun read-variable (prompt &optional default-value)
 "Read the name of a user variable and return it as a symbol.
 Prompts with PROMPT.  By default, return DEFAULT-VALUE.
 A user variable is one whose documentation starts with a `*' character."
 (intern (completing-read prompt obarray 'user-variable-p t nil
-			   'variable-history default-value)))
+			   'variable-history
+			   (if (symbolp default-value)
+			       (symbol-name default-value)
+			     default-value))))
 (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,
 	(setq o (1+ o) n (1+ n))
 	(if (eq ch ?$)
 	    ;; already aset by make-string initial-value
 	    (setq n (1+ n))))
 new)))
+;; Wrapper for `directory-files' for use in generating completion lists.
+;; Generates output in the same format as `file-name-all-completions'.
+;;
+;; The EFS replacement for `directory-files' doesn't support the FILES-ONLY
+;; option, so it has to be faked.  The listing cache will hopefully
+;; improve the performance of this operation.
+(defun minibuf-directory-files (dir &optional match-regexp files-only)
+(let ((want-file (or (eq files-only nil) (eq files-only t)))
+(want-dirs (or (eq files-only nil) (not (eq files-only t)))))
+(delete nil
+(mapcar (function (lambda (f)
+(if (file-directory-p (expand-file-name f dir))
+(and want-dirs (file-name-as-directory f))
+(and want-file f))))
+(delete "." (directory-files dir nil match-regexp))))))
 (defun read-file-name-2 (history prompt dir default
 				 must-match initial-contents
 				 completer)
 (if (not dir)
 (insert-string (file-name-as-directory
 		      (abbreviate-file-name full t)) minibuf)
 (reset-buffer completion-buf)
 (let ((standard-output completion-buf))
 	(display-completion-list
-	 (delete "." (directory-files full nil nil nil (if dir-p 'directory)))
+(minibuf-directory-files full nil (if dir-p 'directory))
 	 :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
+(condition-case nil
-(mouse-read-file-name-1 history prompt dir default must-match
+	  (let ((file
-			      initial-contents completer)
+		 (apply #'make-dialog-box
-(let ((rfhookfun
+			'file `(:title ,(capitalize-string-as-title
-	   (lambda ()
+					 ;; Kludge: Delete ": " off the end.
-	     ;; #### SCREAM!  Create a `file-system-ignore-case'
+					 (replace-in-string prompt ": $" ""))
-	     ;; function, so this kind of stuff is generalized!
+				       ,@(and dir (list :initial-directory
-	     (and (eq system-type 'windows-nt)
+							dir))
-		  (set (make-local-variable 'completion-ignore-case) t))
+				       :file-must-exist ,must-match
-	     (set
+				       ,@(and initial-contents
-	      (make-local-variable
+					      (list :initial-filename
-	       'completion-display-completion-list-function)
+						    initial-contents))))))
-	      #'(lambda (completions)
+	    ;; hack -- until we implement reading a directory properly,
-		  (display-completion-list
+	    ;; allow a file as indicating the directory it's in
-		   completions
+	    (if (and (eq completer 'read-directory-name-internal)
-		   :user-data (not (eq completer 'read-file-name-internal))
+		     (not (file-directory-p file)))
-		   :activate-callback
+		(file-name-directory file)
-		   'read-file-name-activate-callback)))
+	      file))
-	     ;; kludge!
+	(unimplemented
-	     (remove-hook 'minibuffer-setup-hook rfhookfun)
+	 ;; this calls read-file-name-2
-	     )))
+	 (mouse-read-file-name-1 history prompt dir default must-match
-(unwind-protect
+				 initial-contents completer)
-	  (progn
+	 ))
-	    (add-hook 'minibuffer-setup-hook rfhookfun)
+(add-one-shot-hook
-	    (read-file-name-2 history prompt dir default must-match
+'minibuffer-setup-hook
-			      initial-contents completer))
+(lambda ()
-	(remove-hook 'minibuffer-setup-hook rfhookfun)))))
+;; #### SCREAM!  Create a `file-system-ignore-case'
+;; function, so this kind of stuff is generalized!
+(and (eq system-type 'windows-nt)
+	    (set (make-local-variable 'completion-ignore-case) t))
+(set
+	(make-local-variable
+	 'completion-display-completion-list-function)
+	#'(lambda (completions)
+	    (display-completion-list
+	     completions
+	     :user-data (not (eq completer 'read-file-name-internal))
+	     :activate-callback
+	     'read-file-name-activate-callback)))))
+(read-file-name-2 history prompt dir default must-match
+		      initial-contents completer)))
 (defun read-file-name (prompt
 &optional dir default must-match initial-contents
 		       history)
 "Read file name, prompting with PROMPT and completing in directory DIR.
 nil
 (file-exists-p sstring)))))
 ((eq action 't)
 ;; all completions
 (mapcar #'un-substitute-in-file-name
-(file-name-all-completions name dir)))
+(if (string= name "")
+(delete "./" (file-name-all-completions "" dir))
+(file-name-all-completions name dir))))
 (t;; nil
 ;; complete
 (let* ((d (or dir default-directory))
 		    (val (file-name-completion name d)))
 (if (and (eq val 't)
 (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
+				    (minibuf-directory-files
 				     dir
-				     nil
 				     ""
-				     nil
 				     'directories)
-				  (directory-files
+				  (minibuf-directory-files
 				   dir
-				   nil
 				   (concat "\\`" (regexp-quote name))
-				   nil
 				   'directories))))
 			 (mapcar fn
 				 ;; Wretched unix
 				 (delete "." l))))))
 (cond ((eq action 'lambda)
 					 (error file))
 				       "" nil))))
 	   result)
 	  (t file))))
+(defun mouse-rfn-setup-vars (prompt)
+;; a specifier would be nice.
+(set (make-local-variable 'frame-title-format)
+(capitalize-string-as-title
+	;; Kludge: Delete ": " off the end.
+	(replace-in-string prompt ": $" "")))
+;; ensure that killing the frame works right,
+;; instead of leaving us in the minibuffer.
+(add-local-hook 'delete-frame-hook
+		  #'(lambda (frame)
+		      (abort-recursive-edit))))
 (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)
+	 (minibuf-directory-files dir nil t)
-	 :window-width (* 2 (window-width window))
+	 :window-width (window-width window)
+	 :window-height (window-text-area-height window)
+	 :completion-string ""
 	 :activate-callback
 	 'mouse-read-file-name-activate-callback
 	 :user-data user-data
 	 :reference-buffer minibuf
 	 :help-string "")
-(t nil))))
+(t nil))
+))
 (defun mouse-directory-display-completion-list (window dir minibuf user-data)
 (let ((standard-output (window-buffer window)))
 (condition-case nil
 	(display-completion-list
-	 (delete "." (directory-files dir nil nil nil 1))
+	 (minibuf-directory-files dir nil 1)
 	 :window-width (window-width window)
+	 :window-height (window-text-area-height window)
+	 :completion-string ""
 	 :activate-callback
 	 'mouse-read-file-name-activate-callback
 	 :user-data user-data
 	 :reference-buffer minibuf
 	 :help-string "")
-(t nil))))
+(t nil))
+))
 (defun mouse-read-file-name-activate-callback (event extent user-data)
 (let* ((file (extent-string extent))
 	 (minibuf (symbol-value-in-buffer 'completion-reference-buffer
 					  (extent-object extent)))
-	 (in-dir (buffer-substring nil nil minibuf))
+	 (ministring (buffer-substring nil nil minibuf))
+	 (in-dir (file-name-directory ministring))
 	 (full (expand-file-name file in-dir))
 	 (filebuf (nth 0 user-data))
-	 (dirbuff (nth 1 user-data))
+	 (dirbuf (nth 1 user-data))
 	 (filewin (nth 2 user-data))
 	 (dirwin (nth 3 user-data)))
 (if (file-regular-p full)
 	(default-choose-completion event extent minibuf)
 (erase-buffer minibuf)
 (insert-string (file-name-as-directory
 		      (abbreviate-file-name full t)) minibuf)
 (reset-buffer filebuf)
-(if (not dirbuff)
+(if (not dirbuf)
 	  (mouse-directory-display-completion-list filewin full minibuf
 						   user-data)
 	(mouse-file-display-completion-list filewin full minibuf user-data)
-	(reset-buffer dirbuff)
+	(reset-buffer dirbuf)
 	(mouse-directory-display-completion-list dirwin full minibuf
 						 user-data)))))
-;; this is rather cheesified but gets the job done.
+;; our cheesy but god-awful time consuming file dialog box implementation.
+;; this will be replaced with use of the native file dialog box (when
+;; available).
 (defun mouse-read-file-name-1 (history prompt dir default
-				 must-match initial-contents
+				       must-match initial-contents
-				 completer)
+				       completer)
+;; file-p is t if we're reading files, nil if directories.
 (let* ((file-p (eq 'read-file-name-internal completer))
 	 (filebuf (get-buffer-create "*Completions*"))
-	 (dirbuff (and file-p (generate-new-buffer " *mouse-read-file*")))
+	 (dirbuf (and file-p (generate-new-buffer " *mouse-read-file*")))
-	 (butbuff (generate-new-buffer " *mouse-read-file*"))
+	 (butbuf (generate-new-buffer " *mouse-read-file*"))
 	 (frame (make-dialog-frame))
 	 filewin dirwin
 	 user-data)
 (unwind-protect
 	(progn
 	  (reset-buffer filebuf)
-	  (select-frame frame)
+	  ;; set up the frame.
+	  (focus-frame frame)
 	  (let ((window-min-height 1))
 	    ;; #### should be 2 not 3, but that causes
 	    ;; "window too small to split" errors for some
 	    ;; people (but not for me ...) There's a more
 	    ;; fundamental bug somewhere.
 	      (progn
 		(split-window-horizontally 16)
 		(setq filewin (frame-rightmost-window frame)
 		      dirwin (frame-leftmost-window frame))
 		(set-window-buffer filewin filebuf)
-		(set-window-buffer dirwin dirbuff))
+		(set-window-buffer dirwin dirbuf))
 	    (setq filewin (frame-highest-window frame))
 	    (set-window-buffer filewin filebuf))
-	  (setq user-data (list filebuf dirbuff filewin dirwin))
+	  (setq user-data (list filebuf dirbuf filewin dirwin))
-	  (set-window-buffer (frame-lowest-window frame) butbuff)
+	  (set-window-buffer (frame-lowest-window frame) butbuf)
-	  (set-buffer butbuff)
+	  ;; set up completion buffers.
+	  (let ((rfcshookfun
+		 ;; kludge!
+		 ;; #### I really need to flesh out the object
+		 ;; hierarchy better to avoid these kludges.
+		 ;; (?? I wrote this comment above some time ago,
+		 ;; and I don't understand what I'm referring to
+		 ;; any more. --ben
+		 (lambda ()
+		   (mouse-rfn-setup-vars prompt)
+		   (when (featurep 'scrollbar)
+		     (set-specifier scrollbar-width 0 (current-buffer)))
+		   (setq truncate-lines t))))
+	    (set-buffer filebuf)
+	    (add-local-hook 'completion-setup-hook rfcshookfun)
+	    (when file-p
+	      (set-buffer dirbuf)
+	      (add-local-hook 'completion-setup-hook rfcshookfun)))
+	  ;; set up minibuffer.
+	  (add-one-shot-hook
+	   'minibuffer-setup-hook
+	   (lambda ()
+	     (if (not file-p)
+		 (mouse-directory-display-completion-list
+		  filewin dir (current-buffer) user-data)
+	       (mouse-file-display-completion-list
+		filewin dir (current-buffer) user-data)
+	       (mouse-directory-display-completion-list
+		dirwin dir (current-buffer) user-data))
+	     (set
+	      (make-local-variable
+	       'completion-display-completion-list-function)
+	      (lambda (completions)
+		(display-completion-list
+		 completions
+		 :help-string ""
+		 :window-width (window-width filewin)
+		 :window-height (window-text-area-height filewin)
+		 :completion-string ""
+		 :activate-callback
+		 'mouse-read-file-name-activate-callback
+		 :user-data user-data)))
+	     (mouse-rfn-setup-vars prompt)
+	     (save-selected-window
+	       ;; kludge to ensure the frame title is correct.
+	       ;; the minibuffer leaves the frame title the way
+	       ;; it was before (i.e. of the selected window before
+	       ;; the dialog box was opened), so to get it correct
+	       ;; we have to be tricky.
+	       (select-window filewin)
+	       (redisplay-frame nil t)
+	       ;; #### another kludge.  sometimes the focus ends up
+	       ;; back in the main window, not the dialog box.  it
+	       ;; occurs randomly and it's not possible to reliably
+	       ;; reproduce.  We try to fix it by draining non-user
+	       ;; events and then setting the focus back on the frame.
+	       (sit-for 0 t)
+	       (focus-frame frame))))
+	  ;; set up button buffer.
+	  (set-buffer butbuf)
+	  (mouse-rfn-setup-vars prompt)
 	  (when dir
 	    (setq default-directory dir))
 	  (when (featurep 'scrollbar)
-	    (set-specifier scrollbar-width 0 butbuff))
+	    (set-specifier scrollbar-width 0 butbuf))
 	  (insert "                 ")
 	  (insert-gui-button (make-gui-button "OK"
 					      (lambda (foo)
 						(exit-minibuffer))))
 	  (insert "                 ")
 	  (insert-gui-button (make-gui-button "Cancel"
 					      (lambda (foo)
 						(abort-recursive-edit))))
-	  (let ((rfhookfun
-		 (lambda ()
+	  ;; now start reading filename.
-		   (if (not file-p)
+	  (read-file-name-2 history prompt dir default
-		       (mouse-directory-display-completion-list
+			    must-match initial-contents
-			filewin dir (current-buffer) user-data)
+			    completer))
-		     (mouse-file-display-completion-list filewin dir
-							 (current-buffer)
+;; always clean up.
-							 user-data)
+;; get rid of our hook that calls abort-recursive-edit -- not a good
-		     (mouse-directory-display-completion-list dirwin dir
+;; idea here.
-							      (current-buffer)
+(kill-local-variable 'delete-frame-hook)
-							      user-data))
-		   (set
-		    (make-local-variable
-		     'completion-display-completion-list-function)
-		    #'(lambda (completions)
-			(display-completion-list
-			 completions
-			 :help-string ""
-			 :activate-callback
-			 'mouse-read-file-name-activate-callback
-			 :user-data user-data)))
-		   ;; kludge!
-		   (remove-hook 'minibuffer-setup-hook rfhookfun)
-		   ))
-		(rfcshookfun
-		 ;; kludge!
-		 ;; #### I really need to flesh out the object
-		 ;; hierarchy better to avoid these kludges.
-		 (lambda ()
-		   (save-excursion
-		     (set-buffer standard-output)
-		     (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)
 (kill-buffer filebuf)
-(kill-buffer butbuff)
+(kill-buffer butbuf)
-(and dirbuff (kill-buffer dirbuff)))))
+(and dirbuf (kill-buffer dirbuf)))))
 (defun read-face (prompt &optional must-match)
 "Read the name of a face from the minibuffer and return it as a symbol."
 (intern (completing-read prompt obarray 'find-face must-match)))

Mercurial > hg > xemacs-beta

comparison lisp/minibuf.el @ 442:abe6d1db359e r21-2-36