xemacs-beta: lisp/files.el comparison

comparison lisp/files.el @ 280:7df0dd720c89 r21-0b38

Import from CVS: tag r21-0b38

author	cvs
date	Mon, 13 Aug 2007 10:32:22 +0200
parents	6330739388db
children	c42ec1d1cded

comparison

equal deleted inserted replaced

-:c20b2fb5bb0a
+:7df0dd720c89
 ;; 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, Inc. 59 Temple Place - Suite 330, Boston, MA
 ;; 02111-1307, USA.
-;;; Synched up with: FSF 19.34 [Partial].
+;;; Synched up with: FSF 20.3 (but diverging)
 ;;; Warning: Merging this file is tough.  Beware.
 ;;; Commentary:
 ;; This file is dumped with XEmacs.
 ;; XEmacs change block
 ; We have this in C and use the realpath() system call.
 ;(defun file-truename (filename &optional counter prev-dirs)
-;  "Return the truename of FILENAME, which should be absolute.
+; [... lots of code snipped ...]
-;The truename of a file name is found by chasing symbolic links
-;both at the level of the file and at the level of the directories
-;containing it, until no links are left at any level.
-;
-;The arguments COUNTER and PREV-DIRS are used only in recursive calls.
-;Do not specify them in other calls."
-;  ;; COUNTER can be a cons cell whose car is the count of how many more links
-;  ;; to chase before getting an error.
-;  ;; PREV-DIRS can be a cons cell whose car is an alist
-;  ;; of truenames we've just recently computed.
-;  ;; The last test looks dubious, maybe `+' is meant here?  --simon.
-;  (if (or (string= filename "") (string= filename "~")
-;	  (and (string= (substring filename 0 1) "~")
-;	       (string-match "~[^/]*" filename)))
-;      (progn
-;	(setq filename (expand-file-name filename))
-;	(if (string= filename "")
-;	    (setq filename "/"))))
-;  (or counter (setq counter (list 100)))
-;  (let (done
-;	;; For speed, remove the ange-ftp completion handler from the list.
-;	;; We know it's not needed here.
-;	;; For even more speed, do this only on the outermost call.
-;	(file-name-handler-alist
-;	 (if prev-dirs file-name-handler-alist
-;	   (let ((tem (copy-sequence file-name-handler-alist)))
-;	     (delq (rassq 'ange-ftp-completion-hook-function tem) tem)))))
-;    (or prev-dirs (setq prev-dirs (list nil)))
-;    ;; If this file directly leads to a link, process that iteratively
-;    ;; so that we don't use lots of stack.
-;    (while (not done)
-;      (setcar counter (1- (car counter)))
-;      (if (< (car counter) 0)
-;	  (error "Apparent cycle of symbolic links for %s" filename))
-;      (let ((handler (find-file-name-handler filename 'file-truename)))
-;	;; For file name that has a special handler, call handler.
-;	;; This is so that ange-ftp can save time by doing a no-op.
-;	(if handler
-;	    (setq filename (funcall handler 'file-truename filename)
-;		  done t)
-;	  (let ((dir (or (file-name-directory filename) default-directory))
-;		target dirfile)
-;	    ;; Get the truename of the directory.
-;	    (setq dirfile (directory-file-name dir))
-;	    ;; If these are equal, we have the (or a) root directory.
-;	    (or (string= dir dirfile)
-;		;; If this is the same dir we last got the truename for,
-;		;; save time--don't recalculate.
-;		(if (assoc dir (car prev-dirs))
-;		    (setq dir (cdr (assoc dir (car prev-dirs))))
-;		  (let ((old dir)
-;			(new (file-name-as-directory (file-truename dirfile counter prev-dirs))))
-;		    (setcar prev-dirs (cons (cons old new) (car prev-dirs)))
-;		    (setq dir new))))
-;	    (if (equal ".." (file-name-nondirectory filename))
-;		(setq filename
-;		      (directory-file-name (file-name-directory (directory-file-name dir)))
-;		      done t)
-;	      (if (equal "." (file-name-nondirectory filename))
-;		  (setq filename (directory-file-name dir)
-;			done t)
-;		;; Put it back on the file name.
-;		(setq filename (concat dir (file-name-nondirectory filename)))
-;		;; Is the file name the name of a link?
-;		(setq target (file-symlink-p filename))
-;		(if target
-;		    ;; Yes => chase that link, then start all over
-;		    ;; since the link may point to a directory name that uses links.
-;		    ;; We can't safely use expand-file-name here
-;		    ;; since target might look like foo/../bar where foo
-;		    ;; is itself a link.  Instead, we handle . and .. above.
-;		    (setq filename
-;			  (if (file-name-absolute-p target)
-;			      target
-;			    (concat dir target))
-;			  done nil)
-;		  ;; No, we are done!
-;		  (setq done t))))))))
 ;    filename))
 ;; XEmacs addition.  Called from `insert-file-contents-internal'
 ;; at the appropriate time.
 (defun compute-buffer-file-truename (&optional buffer)
 "Chase links in FILENAME until a name that is not a link.
 Does not examine containing directories for links,
 unlike `file-truename'."
 (let (tem (count 100) (newname filename))
 (while (setq tem (file-symlink-p newname))
-(if (= count 0)
+(save-match-data
-	  (error "Apparent cycle of symbolic links for %s" filename))
+	(if (= count 0)
-;; In the context of a link, `//' doesn't mean what XEmacs thinks.
+	    (error "Apparent cycle of symbolic links for %s" filename))
-(while (string-match "//+" tem)
+	;; In the context of a link, `//' doesn't mean what XEmacs thinks.
-	(setq tem (concat (substring tem 0 (1+ (match-beginning 0)))
+	(while (string-match "//+" tem)
-			  (substring tem (match-end 0)))))
+	  (setq tem (concat (substring tem 0 (1+ (match-beginning 0)))
-;; Handle `..' by hand, since it needs to work in the
+			    (substring tem (match-end 0)))))
-;; target of any directory symlink.
+	;; Handle `..' by hand, since it needs to work in the
-;; This code is not quite complete; it does not handle
+	;; target of any directory symlink.
-;; embedded .. in some cases such as ./../foo and foo/bar/../../../lose.
+	;; This code is not quite complete; it does not handle
-(while (string-match "\\`\\.\\./" tem) ;#### Unix specific
+	;; embedded .. in some cases such as ./../foo and foo/bar/../../../lose.
-	(setq tem (substring tem 3))
+	(while (string-match "\\`\\.\\./" tem) ;#### Unix specific
-	(setq newname (file-name-as-directory
+	  (setq tem (substring tem 3))
-		       ;; Do the .. by hand.
+	  (setq newname (file-name-as-directory
-		       (directory-file-name
+			 ;; Do the .. by hand.
-			(file-name-directory
+			 (directory-file-name
-			 ;; Chase links in the default dir of the symlink.
+			  (file-name-directory
-			 (file-chase-links
+			   ;; Chase links in the default dir of the symlink.
-			  (directory-file-name
+			   (file-chase-links
-			   (file-name-directory newname))))))))
+			    (directory-file-name
-(setq newname (expand-file-name tem (file-name-directory newname)))
+			     (file-name-directory newname))))))))
-(setq count (1- count)))
+	(setq newname (expand-file-name tem (file-name-directory newname)))
+	(setq count (1- count))))
 newname))
 (defun switch-to-other-buffer (arg)
 "Switch to the previous buffer.  With a numeric arg, n, switch to the nth
 most recent buffer.  With an arg of 0, buries the current buffer at the
 :type '(repeat (string :tag "Name"))
 :group 'find-file)
 ;; This function is needed by FSF vc.el.  I hope somebody can make it
 ;; work for XEmacs.  -sb.
+;; #### In what way does it not work?  --hniksic
 (defun find-buffer-visiting (filename)
 "Return the buffer visiting file FILENAME (a string).
 This is like `get-file-buffer', except that it checks for any buffer
 visiting the same file, possibly under a different name.
 If there is no such live buffer, return nil."
 (defun find-file-noselect (filename &optional nowarn rawfile)
 "Read file FILENAME into a buffer and return the buffer.
 If a buffer exists visiting FILENAME, return that one, but
 verify that the file has not changed since visited or saved.
 The buffer is not selected, just returned to the caller.
-If NOWARN is non-nil, warning messages about several potential
+If NOWARN is non-nil, warning messages will be suppressed.
-problems will be suppressed."
+If RAWFILE is non-nil, the file is read literally."
 (setq filename (abbreviate-file-name (expand-file-name filename)))
 (if (file-directory-p filename)
 (if (and (fboundp 'dired-noselect) find-file-run-dired)
 	  (dired-noselect (if find-file-use-truenames
 			      (abbreviate-file-name (file-truename filename))
 			    filename))
-	(error "%s is a directory." filename))
+	(error "%s is a directory" filename))
 (let* ((buf (get-file-buffer filename))
 	   (truename (abbreviate-file-name (file-truename filename)))
-	   (number (nthcdr 10 (file-attributes (file-truename filename))))
+	   (number (nthcdr 10 (file-attributes truename)))
-;	   (number (and buffer-file-truename
-;			(nthcdr 10 (file-attributes buffer-file-truename))))
 ;	   ;; Find any buffer for a file which has same truename.
 ;	   (other (and (not buf) (find-buffer-visiting filename)))
 (error nil))
 ;     ;; Let user know if there is a buffer with the same truename.
 	      (cond ((not (file-exists-p filename))
 		     (error "File %s no longer exists!" filename))
 		    ;; Certain files should be reverted automatically
 		    ;; if they have changed on disk and not in the buffer.
 		    ((and (not (buffer-modified-p buf))
-			  (let (found)
+			  (dolist (rx revert-without-query nil)
-			    (dolist (rx revert-without-query found)
+			    (when (string-match rx filename)
-			      (when (string-match rx filename)
+			      (return t))))
-				(setq found t)))))
 		     (with-current-buffer buf
 		       (message "Reverting file %s..." filename)
 		       (revert-buffer t t)
 		       (message "Reverting file %s... done" filename)))
 		    ((yes-or-no-p
 			 (if (buffer-modified-p buf)
 (gettext "File %s changed on disk.  Discard your edits in %s? ")
 (gettext "File %s changed on disk.  Reread from disk into %s? "))
 			 (file-name-nondirectory filename)
 			 (buffer-name buf))))
-		     (save-excursion
+		     (with-current-buffer buf
-		       (set-buffer buf)
 		       (revert-buffer t t)))))
 	;; Else: we must create a new buffer for filename
 	(save-excursion
 ;;; The truename stuff makes this obsolete.
 ;;;	  (let* ((link-name (car (file-attributes filename)))
 	  (erase-buffer)
 	  (if rawfile
 	      (condition-case ()
 		  (insert-file-contents-literally filename t)
 		(file-error
+		 (when (and (file-exists-p filename)
+			    (not (file-readable-p filename)))
+		   (kill-buffer buf)
+		   (signal 'file-error (list "File is not readable" filename)))
 		 ;; Unconditionally set error
 		 (setq error t)))
-	    (condition-case e
+	    (condition-case ()
 		(insert-file-contents filename t)
 	      (file-error
+	       (when (and (file-exists-p filename)
+			  (not (file-readable-p filename)))
+		 (kill-buffer buf)
+		 (signal 'file-error (list "File is not readable" filename)))
 	       ;; Run find-file-not-found-hooks until one returns non-nil.
 	       (or (run-hook-with-args-until-success 'find-file-not-found-hooks)
 		   ;; If they fail too, set error.
-		   (setq error e)))))
+		   (setq error t)))))
 	  ;; Find the file's truename, and maybe use that as visited name.
 	  ;; automatically computed in XEmacs, unless jka-compr was used!
 	  (unless buffer-file-truename
 	    (setq buffer-file-truename truename))
 	  (setq buffer-file-number number)
 		 (if (string-match ":" (file-name-directory filename))
 		     (setq logical (substring (file-name-directory filename)
 					      0 (match-beginning 0))))
 		 (not (member logical find-file-not-true-dirname-list)))
 	       (setq buffer-file-name buffer-file-truename))
-;	  (if find-file-visit-truename
-;	      (setq buffer-file-name
-;		    (setq filename
-;			  (expand-file-name buffer-file-truename))))
 	  (and find-file-use-truenames
 	       ;; This should be in C.  Put pathname abbreviations that have
 	       ;; been explicitly requested back into the pathname.  Most
 	       ;; importantly, strip out automounter /tmp_mnt directories so
 	       ;; that auto-save will work
 	  (and (not (funcall backup-enable-predicate buffer-file-name))
 	       (progn
 		 (make-local-variable 'backup-inhibited)
 		 (setq backup-inhibited t)))
 	  (if rawfile
+	      ;; #### FSF 20.3 sets buffer-file-coding-system to
+	      ;; `no-conversion' here.  Should we copy?  It also makes
+	      ;; `find-file-literally' a local variable and sets it to t.
 	      nil
 	    (after-find-file error (not nowarn))
 	    (setq buf (current-buffer)))))
 buf)))
+;; FSF has `insert-file-literally' and `find-file-literally' here.
 (defvar after-find-file-from-revert-buffer nil)
 (defun after-find-file (&optional error warn noauto
 				  after-find-file-from-revert-buffer
 				  nomodes)
 (error (message "File mode specification error: %s"
 (prin1-to-string err))
 nil))
 (condition-case err
 (hack-local-variables (not find-file))
-(error (message "File local-variables error: %s"
+(error (lwarn 'local-variables 'warning
-(prin1-to-string err))))))
+		  "File local-variables error: %s"
+		  (error-message-string err))))))
 (defvar auto-mode-alist
 '(("\\.te?xt\\'" . text-mode)
 ("\\.[ch]\\'" . c-mode)
 ("\\.el\\'" . emacs-lisp-mode)
 If the element has the form (REGEXP FUNCTION NON-NIL), then after
 calling FUNCTION (if it's not nil), we delete the suffix that matched
 REGEXP and search the list again for another match.")
-(defconst interpreter-mode-alist
+(defvar interpreter-mode-alist
 '(("^#!.*csh"	  . sh-mode)
 ("^#!.*sh\\b" . sh-mode)
 ("^#!.*\\b\\(scope\\|wish\\|tcl\\|expect\\)" . tcl-mode)
 ("perl"   . perl-mode)
 ("python" . python-mode)
 Each alist element looks like (INTERPRETER . MODE).
 The car of each element is a regular expression which is compared
 with the name of the interpreter specified in the first line.
 If it matches, mode MODE is selected.")
-(defconst inhibit-first-line-modes-regexps (purecopy '("\\.tar\\'"))
+(defvar inhibit-first-line-modes-regexps (purecopy '("\\.tar\\'" "\\.tgz\\'"))
 "List of regexps; if one matches a file name, don't look for `-*-'.")
-(defconst inhibit-first-line-modes-suffixes nil
+(defvar inhibit-first-line-modes-suffixes nil
 "List of regexps for what to ignore, for `inhibit-first-line-modes-regexps'.
 When checking `inhibit-first-line-modes-regexps', we first discard
 from the end of the file name anything that matches one of these regexps.")
 (defvar user-init-file
 "" ; set by command-line
 "File name including directory of user's initialization file.")
-(defun set-auto-mode ()
+(defun set-auto-mode (&optional just-from-file-name)
 "Select major mode appropriate for current buffer.
 This checks for a -*- mode tag in the buffer's text,
 compares the filename against the entries in `auto-mode-alist',
 or checks the interpreter that runs this file against
 `interpreter-mode-alist'.
 It does not check for the `mode:' local variable in the
 Local Variables section of the file; for that, use `hack-local-variables'.
 If `enable-local-variables' is nil, this function does not check for a
--*- mode tag."
+-*- mode tag.
+If the optional argument JUST-FROM-FILE-NAME is non-nil,
+then we do not set anything but the major mode,
+and we don't even do that unless it would come from the file name."
 (save-excursion
 ;; Look for -*-MODENAME-*- or -*- ... mode: MODENAME; ... -*-
 ;; Do this by calling the hack-local-variables helper to avoid redundancy.
 ;; We bind enable-local-variables to nil this time because we're going to
 ;; call hack-local-variables-prop-line again later, "for real."  Note that
 				  name (substring name 0 (match-beginning 0))
 				  keep-going t))
 			(setq mode (cdr (car alist))
 			      keep-going nil)))
 		  (setq alist (cdr alist))))
-;; If we can't deduce a mode from the file name,
+	      (unless just-from-file-name
-;; look for an interpreter specified in the first line.
+		;; If we can't deduce a mode from the file name,
-	      (if (and (null mode)
+		;; look for an interpreter specified in the first line.
-		       (save-excursion ; XEmacs
+		(if (and (null mode)
-			 (goto-char (point-min))
+			 (save-excursion ; XEmacs
-			 (looking-at "#!")))
+			   (goto-char (point-min))
-(let ((firstline
+			   (looking-at "#!")))
-(buffer-substring
+		    (let ((firstline
-(point-min)
+			   (buffer-substring
-(save-excursion
+			    (point-min)
-(goto-char (point-min)) (end-of-line) (point)))))
+			    (save-excursion
-(setq alist interpreter-mode-alist)
+			      (goto-char (point-min)) (end-of-line) (point)))))
-(while alist
+		      (setq alist interpreter-mode-alist)
-(if (string-match (car (car alist)) firstline)
+		      (while alist
-(progn
+			(if (string-match (car (car alist)) firstline)
-(setq mode (cdr (car alist)))
+			    (progn
-(setq alist nil))
+			      (setq mode (cdr (car alist)))
-(setq alist (cdr alist))))))
+			      (setq alist nil))
+			  (setq alist (cdr alist)))))))
 (if mode
 		  (if (not (fboundp mode))
 		      (progn
 			(if (or (not (boundp 'package-get-base))
 				(not package-get-base))
 			  (if name
 			      (message "Mode %s is not installed.  Download package %s" mode name)
 			    (message "Mode %s either doesn't exist or is not a known package" mode))
 			  (sit-for 2)
 			  (error "%s" mode)))
-		    (funcall mode)))
+		    (unless (and just-from-file-name
-))))))
+				 (or
+				  ;; Don't reinvoke major mode.
+				  (eq mode major-mode)
+				  ;; Don't lose on minor modes.
+				  (assq mode minor-mode-alist)))
+		      (funcall mode))))))))))
 (defvar hack-local-variables-hook nil
 "Normal hook run after processing a file's local variables specs.
 Major modes can use this to examine user-specified local variables
 in order to initialize other data structure based on them.
 	   (message "Ignoring `eval:' in file's local variables")))
 	;; Ordinary variable, really set it.
 	(t (make-local-variable var)
 	   (set var val))))
-(defun set-visited-file-name (filename)
+(defcustom change-major-mode-with-file-name t
+"*Non-nil means \\[write-file] should set the major mode from the file name.
+However, the mode will not be changed if
+\(1) a local variables list or the `-*-' line specifies a major mode, or
+\(2) the current major mode is a \"special\" mode,
+\    not suitable for ordinary files, or
+\(3) the new file name does not particularly specify any mode."
+:type 'boolean
+:group 'editing-basics)
+(defun set-visited-file-name (filename &optional no-query along-with-file)
 "Change name of file visited in current buffer to FILENAME.
 The next time the buffer is saved it will go in the newly specified file.
 nil or empty string as argument means make buffer not be visiting any file.
 Remember to delete the initial contents of the minibuffer
-if you wish to pass an empty string as the argument."
+if you wish to pass an empty string as the argument.
+The optional second argument NO-QUERY, if non-nil, inhibits asking for
+confirmation in the case where another buffer is already visiting FILENAME.
+The optional third argument ALONG-WITH-FILE, if non-nil, means that
+the old visited file has been renamed to the new name FILENAME."
 (interactive "FSet visited file name: ")
 (if (buffer-base-buffer)
 (error "An indirect buffer cannot visit a file"))
 (let (truename)
 (if filename
 	(progn
 	  (setq truename (file-truename filename))
 	  ;; #### Do we need to check if truename is non-nil?
 	  (if find-file-use-truenames
 	      (setq filename truename))))
+(let ((buffer (and filename (find-buffer-visiting filename))))
+(and buffer (not (eq buffer (current-buffer)))
+	   (not no-query)
+	   (not (y-or-n-p (message "A buffer is visiting %s; proceed? "
+				   filename)))
+	   (error "Aborted")))
 (or (equal filename buffer-file-name)
 	(progn
 	  (and filename (lock-buffer filename))
 	  (unlock-buffer)))
 (setq buffer-file-name filename)
 	      (setq new-name (downcase new-name)))
 	  (setq default-directory (file-name-directory buffer-file-name))
 	  (or (string= new-name (buffer-name))
 	      (rename-buffer new-name t))))
 (setq buffer-backed-up nil)
-(clear-visited-file-modtime)
+(or along-with-file
+	(clear-visited-file-modtime))
 (compute-buffer-file-truename) ; insert-file-contents does this too.
 ;    ;; Abbreviate the file names of the buffer.
 ;    (if truename
 ;	 (progn
 ;	   (setq buffer-file-truename (abbreviate-file-name truename))
 (kill-local-variable 'write-file-data-hooks)
 (kill-local-variable 'revert-buffer-function)
 (kill-local-variable 'backup-inhibited)
 ;; If buffer was read-only because of version control,
 ;; that reason is gone now, so make it writable.
-(if (and (boundp 'vc-mode) vc-mode)
+(when (boundp 'vc-mode)
-(setq buffer-read-only nil))
+(if vc-mode
-(kill-local-variable 'vc-mode)
+	(setq buffer-read-only nil))
+(kill-local-variable 'vc-mode))
 ;; Turn off backup files for certain file names.
 ;; Since this is a permanent local, the major mode won't eliminate it.
-(and (not (funcall backup-enable-predicate buffer-file-name))
+(and buffer-file-name
+(not (funcall backup-enable-predicate buffer-file-name))
 (progn
 	 (make-local-variable 'backup-inhibited)
 	 (setq backup-inhibited t)))
 (let ((oauto buffer-auto-save-file-name))
 ;; If auto-save was not already on, turn it on if appropriate.
 ;; Rename the old auto save file if any.
 (and oauto buffer-auto-save-file-name
 	 (file-exists-p oauto)
 	 (rename-file oauto buffer-auto-save-file-name t)))
 (if buffer-file-name
+(not along-with-file)
 (set-buffer-modified-p t))
+;; Update the major mode, if the file name determines it.
+(condition-case nil
+;; Don't change the mode if it is special.
+(or (not change-major-mode-with-file-name)
+	  (get major-mode 'mode-class)
+	  ;; Don't change the mode if the local variable list specifies it.
+	  (hack-local-variables t)
+	  (set-auto-mode t))
+(error nil))
 ;; #### ??
 (run-hooks 'after-set-visited-file-name-hooks))
 (defun write-file (filename &optional confirm codesys)
 "Write current buffer into file FILENAME.
 	      (expand-file-name (substring file 0 (match-beginning 0))
 				directory)
 	    (substring file 0 (match-beginning 0)))
 	filename))))
+(defun file-name-extension (filename &optional period)
+"Return FILENAME's final \"extension\".
+The extension, in a file name, is the part that follows the last `.'.
+Return nil for extensionless file names such as `foo'.
+Return the empty string for file names such as `foo.'.
+If PERIOD is non-nil, then the returned value includes the period
+that delimits the extension, and if FILENAME has no extension,
+the value is \"\"."
+(save-match-data
+(let ((file (file-name-sans-versions (file-name-nondirectory filename))))
+(if (string-match "\\.[^.]*\\'" file)
+(substring file (+ (match-beginning 0) (if period 0 1)))
+(if period
+"")))))
 (defun make-backup-file-name (file)
 "Create the non-numeric backup file name for FILE.
 This is a separate function so you can redefine it for customization."
 (if (eq system-type 'ms-dos)
 (let ((fn (file-name-nondirectory file)))
 (defun file-nlinks (filename)
 "Return number of names file FILENAME has."
 (car (cdr (file-attributes filename))))
 (defun file-relative-name (filename &optional directory)
-"Convert FILENAME to be relative to DIRECTORY (default: default-directory)."
+"Convert FILENAME to be relative to DIRECTORY (default: default-directory).1
-(setq filename (expand-file-name filename)
+This function returns a relative file name which is equivalent to FILENAME
-	directory (file-name-as-directory (expand-file-name
+when used with that default directory as the default.
-					   (or directory default-directory))))
+If this is impossible (which can happen on MSDOS and Windows
-(let ((ancestor ""))
+when the file name and directory use different drive names)
-(while (not (string-match (concat "^" (regexp-quote directory)) filename))
+then it returns FILENAME."
-(setq directory (file-name-directory (substring directory 0 -1))
+(save-match-data
-	    ancestor (concat "../" ancestor)))
+(let ((fname (expand-file-name filename)))
-(concat ancestor (substring filename (match-end 0)))))
+(setq directory (file-name-as-directory
+		       (expand-file-name (or directory default-directory))))
+;; On Microsoft OSes, if FILENAME and DIRECTORY have different
+;; drive names, they can't be relative, so return the absolute name.
+(if (and (or (eq system-type 'ms-dos)
+		   (eq system-type 'windows-nt))
+	       (not (string-equal (substring fname  0 2)
+				  (substring directory 0 2))))
+	  filename
+	(let ((ancestor ".")
+	      (fname-dir (file-name-as-directory fname)))
+	  (while (and (not (string-match (concat "^" (regexp-quote directory)) fname-dir))
+		      (not (string-match (concat "^" (regexp-quote directory)) fname)))
+	    (setq directory (file-name-directory (substring directory 0 -1))
+		  ancestor (if (equal ancestor ".")
+			       ".."
+			     (concat "../" ancestor))))
+	  ;; Now ancestor is empty, or .., or ../.., etc.
+	  (if (string-match (concat "^" (regexp-quote directory)) fname)
+	      ;; We matched within FNAME's directory part.
+	      ;; Add the rest of FNAME onto ANCESTOR.
+	      (let ((rest (substring fname (match-end 0))))
+		(if (and (equal ancestor ".")
+			 (not (equal rest "")))
+		    ;; But don't bother with ANCESTOR if it would give us `./'.
+		    rest
+		  (concat (file-name-as-directory ancestor) rest)))
+	    ;; We matched FNAME's directory equivalent.
+	    ancestor))))))
 (defun save-buffer (&optional args)
 "Save current buffer in visited file if modified.  Versions described below.
 By default, makes the previous version into a backup file
 	      ;;"save only this buffer" "save no more buffers")
 	      ;; this is rather bogus. --ben
 	      ;; (it makes the dialog box too big, and you get an error
 	      ;; "wrong type argument: framep, nil" when you hit q after
 	      ;; choosing the option from the dialog box)
-;	    (list (list ?\C-r (lambda (buf)
-;				(view-buffer buf)
+	      ;; We should fix the dialog box rather than disabling
-;				(setq view-exit-action
+	      ;; this!  --hniksic
-;				      '(lambda (ignore)
+	    (list (list ?\C-r (lambda (buf)
-;					 (exit-recursive-edit)))
+				;; FSF has an EXIT-ACTION argument to
-;				(recursive-edit)
+				;; `view-buffer'.
-;				;; Return nil to ask about BUF again.
+				(view-buffer buf)
-;				nil)
+				(setq view-exit-action
-;			"display the current buffer"))
+				      (lambda (ignore)
-	      ))
+					(exit-recursive-edit)))
+				(recursive-edit)
+				;; Return nil to ask about BUF again.
+				nil)
+			"display the current buffer"))))
 	    (abbrevs-done
 	     (and save-abbrevs abbrevs-changed
 		  (progn
 		    (if (or arg
 			    (y-or-n-p (format "Save abbrevs in %s? " abbrev-file-name)))
 \(Its calling sequence is different; see its documentation)."
 (interactive "*fInsert file: \nZCoding system: ")
 (if (file-directory-p filename)
 (signal 'file-error (list "Opening input file" "file is a directory"
 				filename)))
-(let* (format-alist ; format.el only confuses people in this context
+(let ((tem
-	 (tem
 	 (if codesys
 	     (let ((coding-system-for-read
 		    (get-coding-system codesys)))
 	       (insert-file-contents filename))
 	   (insert-file-contents filename))))
 Optional third argument PRESERVE-MODES non-nil means don't alter
 the files modes.  Normally we reinitialize them using `normal-mode'.
 If the value of `revert-buffer-function' is non-nil, it is called to
-do the work.
+do all the work for this command.  Otherwise, the hooks
+`before-revert-hook' and `after-revert-hook' are run at the beginning
-The default revert function runs the hook `before-revert-hook' at the
+and the end, and if `revert-buffer-insert-file-contents-function' is
-beginning and `after-revert-hook' at the end."
+non-nil, it is called instead of rereading visited file contents."
 ;; I admit it's odd to reverse the sense of the prefix argument, but
 ;; there is a lot of code out there which assumes that the first
 ;; argument should be t to avoid consulting the auto-save file, and
 ;; there's no straightforward way to encourage authors to notice a
 ;; reversal of the argument sense.  So I'm just changing the user
 To choose one, move point to the proper line and then type C-c C-c.
 Then you'll be asked about a number of files to recover."
 (interactive)
 (unless (fboundp 'dired)
 (error "recover-session requires dired"))
+(if (null auto-save-list-file-prefix)
+(error
+"You set `auto-save-list-file-prefix' to disable making session files"))
 (dired (concat auto-save-list-file-prefix "*"))
 (goto-char (point-min))
 (or (looking-at "Move to the session you want to recover,")
 (let ((inhibit-read-only t))
 	(insert "Move to the session you want to recover,\n"
 			     files
 			     '("file" "files" "recover"))
 	    (message "No files can be recovered from this session now")))
 (kill-buffer buffer))))
-(defun kill-some-buffers ()
+(defun kill-some-buffers (&optional list)
-"For each buffer, ask whether to kill it."
+"For each buffer in LIST, ask whether to kill it.
+LIST defaults to all existing live buffers."
 (interactive)
-(let ((list (buffer-list)))
+(if (null list)
-(while list
+(setq list (buffer-list)))
-(let* ((buffer (car list))
+(while list
-	     (name (buffer-name buffer)))
+(let* ((buffer (car list))
-	(and (not (string-equal name ""))
+	   (name (buffer-name buffer)))
-	     (/= (aref name 0) ? )
+(and (not (string-equal name ""))
-	     (yes-or-no-p
+	   (/= (aref name 0) ?\ )
-	      (format
+	   (yes-or-no-p
-	       (if (buffer-modified-p buffer)
+	    (format
-		   (gettext "Buffer %s HAS BEEN EDITED.  Kill? ")
+	     (if (buffer-modified-p buffer)
-		   (gettext "Buffer %s is unmodified.  Kill? "))
+		 (gettext "Buffer %s HAS BEEN EDITED.  Kill? ")
-		      name))
+	       (gettext "Buffer %s is unmodified.  Kill? "))
-	     (kill-buffer buffer)))
+	     name))
-(setq list (cdr list)))))
+	   (kill-buffer buffer)))
+(setq list (cdr list))))
 (defun auto-save-mode (arg)
 "Toggle auto-saving of contents of current buffer.
 With prefix argument ARG, turn auto-saving on if positive, else off."
 (interactive "P")
 (cond ((not allow-remote-paths) nil)
 	((featurep 'ange-ftp) (ange-ftp-ftp-path file-name))
 	((fboundp 'efs-ftp-path) (efs-ftp-path file-name))
 	(t nil)))
+;; #### FSF has file-name-non-special here.
 ;;; files.el ends here

Mercurial > hg > xemacs-beta

comparison lisp/files.el @ 280:7df0dd720c89 r21-0b38