xemacs-beta: lisp/prim/files.el comparison

comparison lisp/prim/files.el @ 74:54cc21c15cbb r20-0b32

Import from CVS: tag r20-0b32

author	cvs
date	Mon, 13 Aug 2007 09:04:33 +0200
parents	b9518feda344
children	6a378aca36af

comparison

equal deleted inserted replaced

-:e2d7a37b7c8d
+:54cc21c15cbb
 (defun create-file-buffer (filename)
 "Create a suitably named buffer for visiting FILENAME, and return it.
 FILENAME (sans directory) is used unchanged if that name is free;
 otherwise a string <2> or <3> or ... is appended to get an unused name."
-(let ((lastname (file-name-nondirectory filename)))
+(let ((handler (find-file-name-handler filename 'create-file-buffer)))
-(if (string= lastname "")
+(if handler
-	(setq lastname filename))
+	  (funcall handler 'create-file-buffer filename)
-(generate-new-buffer lastname)))
+	(let ((lastname (file-name-nondirectory filename)))
+	  (if (string= lastname "")
+	      (setq lastname filename))
+	  (generate-new-buffer lastname)))))
 (defun generate-new-buffer (name)
 "Create and return a buffer with a name based on NAME.
 Choose the buffer's name using `generate-new-buffer-name'."
 (get-buffer-create (generate-new-buffer-name name)))
 (defun abbreviate-file-name (filename &optional hack-homedir)
 "Return a version of FILENAME shortened using `directory-abbrev-alist'.
 See documentation of variable `directory-abbrev-alist' for more information.
 If optional argument HACK-HOMEDIR is non-nil, then this also substitutes
 \"~\" for the user's home directory."
-;; Get rid of the prefixes added by the automounter.
+(let ((handler (find-file-name-handler filename 'abbreviate-file-name)))
-;(if (and (string-match automount-dir-prefix filename)
+(if handler
-;         (file-exists-p (file-name-directory
+	(funcall handler 'abbreviate-file-name filename hack-homedir)
-;                         (substring filename (1- (match-end 0))))))
+;; Get rid of the prefixes added by the automounter.
-;    (setq filename (substring filename (1- (match-end 0)))))
+;;(if (and (string-match automount-dir-prefix filename)
-(let ((tail directory-abbrev-alist))
+;;         (file-exists-p (file-name-directory
-;; If any elt of directory-abbrev-alist matches this name,
+;;                         (substring filename (1- (match-end 0))))))
-;; abbreviate accordingly.
+;;    (setq filename (substring filename (1- (match-end 0)))))
-(while tail
+(let ((tail directory-abbrev-alist))
-(if (string-match (car (car tail)) filename)
+	;; If any elt of directory-abbrev-alist matches this name,
-	  (setq filename
+	;; abbreviate accordingly.
-		(concat (cdr (car tail)) (substring filename (match-end 0)))))
+	(while tail
-(setq tail (cdr tail))))
+	  (if (string-match (car (car tail)) filename)
-(if hack-homedir
+	      (setq filename
-(progn
+		    (concat (cdr (car tail)) (substring filename (match-end 0)))))
-	;; Compute and save the abbreviated homedir name.
+	  (setq tail (cdr tail))))
-	;; We defer computing this until the first time it's needed, to
+(if hack-homedir
-	;; give time for directory-abbrev-alist to be set properly.
+	  (progn
-	;; We include a slash at the end, to avoid spurious matches
+	    ;; Compute and save the abbreviated homedir name.
-	;; such as `/usr/foobar' when the home dir is `/usr/foo'.
+	    ;; We defer computing this until the first time it's needed, to
-	(or abbreviated-home-dir
+	    ;; give time for directory-abbrev-alist to be set properly.
-	    (setq abbreviated-home-dir
+	    ;; We include a slash at the end, to avoid spurious matches
-		  (let ((abbreviated-home-dir "$foo"))
+	    ;; such as `/usr/foobar' when the home dir is `/usr/foo'.
-		    (concat "\\`" (regexp-quote (abbreviate-file-name
+	    (or abbreviated-home-dir
-						 (expand-file-name "~")))
+		(setq abbreviated-home-dir
-			    "\\(/\\|\\'\\)"))))
+		      (let ((abbreviated-home-dir "$foo"))
-;; If FILENAME starts with the abbreviated homedir,
+			(concat "\\`" (regexp-quote (abbreviate-file-name
-;; make it start with `~' instead.
+						     (expand-file-name "~")))
-	(if (and (string-match abbreviated-home-dir filename)
+				"\\(/\\|\\'\\)"))))
-;; If the home dir is just /, don't change it.
+	    ;; If FILENAME starts with the abbreviated homedir,
-(not (and (= (match-end 0) 1) ;#### unix-specific
+	    ;; make it start with `~' instead.
-			   (= (aref filename 0) ?/)))
+	    (if (and (string-match abbreviated-home-dir filename)
-		 (not (and (or (eq system-type 'ms-dos)
+		     ;; If the home dir is just /, don't change it.
-			       (eq system-type 'windows-nt))
+		     (not (and (= (match-end 0) 1) ;#### unix-specific
-			   (save-match-data
+			       (= (aref filename 0) ?/)))
-			     (string-match "^[a-zA-Z]:/$" filename)))))
+		     (not (and (or (eq system-type 'ms-dos)
-	    (setq filename
+				   (eq system-type 'windows-nt))
-		  (concat "~"
+			       (save-match-data
-			  (substring filename
+				 (string-match "^[a-zA-Z]:/$" filename)))))
-				     (match-beginning 1) (match-end 1))
+		(setq filename
-			  (substring filename (match-end 0)))))))
+		      (concat "~"
-filename)
+			      (substring filename
+					 (match-beginning 1) (match-end 1))
+			      (substring filename (match-end 0)))))))
+filename)))
 (defvar find-file-not-true-dirname-list nil
 "*List of logical names for which visiting shouldn't save the true dirname.
 On VMS, when you visit a file using a logical name that searches a path,
 you may or may not want the visited file name to record the specific
 			(setq mode (cdr (car alist))
 			      keep-going nil)))
 		  (setq alist (cdr alist))))
 ;; If we can't deduce a mode from the file name,
 ;; look for an interpreter specified in the first line.
-	      (if (null mode)
+	      (if (and (null mode)
+		       (save-excursion ; XEmacs
+			 (goto-char (point-min))
+			 (looking-at "#!")))
 (let ((firstline
 (buffer-substring
 (point-min)
 (save-excursion
 (goto-char (point-min)) (end-of-line) (point)))))
 		   (if (equal (downcase (symbol-name key)) "mode")
 		       (setq key 'mode))
 		   (setq result (cons (cons key val) result))
 		   (skip-chars-forward " \t;")))
 	       (setq result (nreverse result))))))
-(let ((set-any-p (or force (hack-local-variables-p t)))
+(if result
-	  (mode-p nil))
+	(let ((set-any-p (or force (hack-local-variables-p t)))
-(while result
+	      (mode-p nil))
-	(let ((key (car (car result)))
+	  (while result
-	      (val (cdr (car result))))
+	    (let ((key (car (car result)))
-	  (cond ((eq key 'mode)
+		  (val (cdr (car result))))
-		 (setq mode-p t)
+	      (cond ((eq key 'mode)
-		 (funcall (intern (concat (downcase (symbol-name val))
+		     (setq mode-p t)
-					  "-mode"))))
+		     (funcall (intern (concat (downcase (symbol-name val))
-		(set-any-p
+					      "-mode"))))
-		 (hack-one-local-variable key val))
+		    (set-any-p
-		(t
+		     (hack-one-local-variable key val))
-		 nil)))
+		    (t
-	(setq result (cdr result)))
+		     nil)))
-mode-p)))
+	    (setq result (cdr result)))
+	  mode-p))))
 (defconst ignored-local-variables
 (list 'enable-local-eval)
 "Variables to be ignored in a file's local variable spec.")
 "Make a backup of the disk file visited by the current buffer, if appropriate.
 This is normally done before saving the buffer the first time.
 If the value is non-nil, it is the result of `file-modes' on the original file;
 this means that the caller, after saving the buffer, should change the modes
 of the new file to agree with the old modes."
-(if (and make-backup-files
+(if buffer-file-name
-(not backup-inhibited)
+(let ((handler (find-file-name-handler buffer-file-name 'backup-buffer)))
-	   (not buffer-backed-up)
+	(if handler
-	   (file-exists-p buffer-file-name)
+	    (funcall handler 'backup-buffer)
-	   (memq (aref (elt (file-attributes buffer-file-name) 8) 0)
+	  (if (and make-backup-files
-		 '(?- ?l)))
+		   (not backup-inhibited)
-(let ((real-file-name buffer-file-name)
+		   (not buffer-backed-up)
-	    backup-info backupname targets setmodes)
+		   (file-exists-p buffer-file-name)
-	;; If specified name is a symbolic link, chase it to the target.
+		   (memq (aref (elt (file-attributes buffer-file-name) 8) 0)
-	;; Thus we make the backups in the directory where the real file is.
+			 '(?- ?l)))
-	(setq real-file-name (file-chase-links real-file-name))
+	      (let ((real-file-name buffer-file-name)
-	(setq backup-info (find-backup-file-name real-file-name)
+		    backup-info backupname targets setmodes)
-	      backupname (car backup-info)
+		;; If specified name is a symbolic link, chase it to the target.
-	      targets (cdr backup-info))
+		;; Thus we make the backups in the directory where the real file is.
+		(setq real-file-name (file-chase-links real-file-name))
+		(setq backup-info (find-backup-file-name real-file-name)
+		      backupname (car backup-info)
+		      targets (cdr backup-info))
 ;;;     (if (file-directory-p buffer-file-name)
 ;;;         (error "Cannot save buffer in directory %s" buffer-file-name))
-	(if backup-info
+		(if backup-info
-	    (condition-case ()
+		    (condition-case ()
-		(let ((delete-old-versions
+			(let ((delete-old-versions
-		       ;; If have old versions to maybe delete,
+			       ;; If have old versions to maybe delete,
-		       ;; ask the user to confirm now, before doing anything.
+			       ;; ask the user to confirm now, before doing anything.
-		       ;; But don't actually delete til later.
+			       ;; But don't actually delete til later.
-		       (and targets
+			       (and targets
-			    (or (eq delete-old-versions t)
+				    (or (eq delete-old-versions t)
-				(eq delete-old-versions nil))
+					(eq delete-old-versions nil))
-			    (or delete-old-versions
+				    (or delete-old-versions
-				(y-or-n-p (format "Delete excess backup versions of %s? "
+					(y-or-n-p (format "Delete excess backup versions of %s? "
-						  real-file-name))))))
+							  real-file-name))))))
-		  ;; Actually write the back up file.
+			  ;; Actually write the back up file.
-		  (condition-case ()
-		      (if (or file-precious-flag
-;			  (file-symlink-p buffer-file-name)
-			      backup-by-copying
-			      (and backup-by-copying-when-linked
-				   (> (file-nlinks real-file-name) 1))
-			      (and backup-by-copying-when-mismatch
-				   (let ((attr (file-attributes real-file-name)))
-				     (or (nth 9 attr)
-					 (not (file-ownership-preserved-p real-file-name))))))
 			  (condition-case ()
-			      (copy-file real-file-name backupname t t)
+			      (if (or file-precious-flag
+					;			  (file-symlink-p buffer-file-name)
+				      backup-by-copying
+				      (and backup-by-copying-when-linked
+					   (> (file-nlinks real-file-name) 1))
+				      (and backup-by-copying-when-mismatch
+					   (let ((attr (file-attributes real-file-name)))
+					     (or (nth 9 attr)
+						 (not (file-ownership-preserved-p real-file-name))))))
+				  (condition-case ()
+				      (copy-file real-file-name backupname t t)
+				    (file-error
+				     ;; If copying fails because file BACKUPNAME
+				     ;; is not writable, delete that file and try again.
+				     (if (and (file-exists-p backupname)
+					      (not (file-writable-p backupname)))
+					 (delete-file backupname))
+				     (copy-file real-file-name backupname t t)))
+				;; rename-file should delete old backup.
+				(rename-file real-file-name backupname t)
+				(setq setmodes (file-modes backupname)))
 			    (file-error
-			     ;; If copying fails because file BACKUPNAME
+			     ;; If trouble writing the backup, write it in ~.
-			     ;; is not writable, delete that file and try again.
+			     (setq backupname (expand-file-name "~/%backup%~"))
-			     (if (and (file-exists-p backupname)
+			     (message "Cannot write backup file; backing up in ~/%%backup%%~")
-				      (not (file-writable-p backupname)))
+			     (sleep-for 1)
-				 (delete-file backupname))
+			     (condition-case ()
-			     (copy-file real-file-name backupname t t)))
+				 (copy-file real-file-name backupname t t)
-			;; rename-file should delete old backup.
+			       (file-error
-			(rename-file real-file-name backupname t)
+				;; If copying fails because file BACKUPNAME
-			(setq setmodes (file-modes backupname)))
+				;; is not writable, delete that file and try again.
-		    (file-error
+				(if (and (file-exists-p backupname)
-		     ;; If trouble writing the backup, write it in ~.
+					 (not (file-writable-p backupname)))
-		     (setq backupname (expand-file-name "~/%backup%~"))
+				    (delete-file backupname))
-		     (message "Cannot write backup file; backing up in ~/%%backup%%~")
+				(copy-file real-file-name backupname t t)))))
-		     (sleep-for 1)
+			  (setq buffer-backed-up t)
-		     (condition-case ()
+			  ;; Now delete the old versions, if desired.
-			 (copy-file real-file-name backupname t t)
+			  (if delete-old-versions
-		       (file-error
+			      (while targets
-			;; If copying fails because file BACKUPNAME
+				(condition-case ()
-			;; is not writable, delete that file and try again.
+				    (delete-file (car targets))
-			(if (and (file-exists-p backupname)
+				  (file-error nil))
-				 (not (file-writable-p backupname)))
+				(setq targets (cdr targets))))
-			    (delete-file backupname))
+			  setmodes)
-			(copy-file real-file-name backupname t t)))))
+		      (file-error nil)))))))))
-		  (setq buffer-backed-up t)
-		  ;; Now delete the old versions, if desired.
-		  (if delete-old-versions
-		      (while targets
-			(condition-case ()
-			    (delete-file (car targets))
-			  (file-error nil))
-			(setq targets (cdr targets))))
-		  setmodes)
-	    (file-error nil))))))
 (defun file-name-sans-versions (name &optional keep-backup-version)
 "Return FILENAME sans backup versions or strings.
 This is a separate procedure so your site-init or startup file can
 redefine it.
 ;; Actually putting the file name in the minibuffer should be used
 ;; only rarely.
 ;; Not just because users often use the default.
 (interactive "FRecover file: ")
 (setq file (expand-file-name file))
-(if (auto-save-file-name-p file)
+(let ((handler (or (find-file-name-handler file 'recover-file)
-(error "%s is an auto-save file" file))
+		    (find-file-name-handler
-(let ((file-name (let ((buffer-file-name file))
+		     (let ((buffer-file-name file))
-		     (make-auto-save-file-name))))
+		       (make-auto-save-file-name))
-(cond ((if (file-exists-p file)
+		     'recover-file))))
-	       (not (file-newer-than-file-p file-name file))
+(if handler
-	     (not (file-exists-p file-name)))
+	(funcall handler 'recover-file file)
-	   (error "Auto-save file %s not current" file-name))
+(if (auto-save-file-name-p file)
-	  ((save-window-excursion
+	  (error "%s is an auto-save file" file))
-	     (if (not (eq system-type 'vax-vms))
+(let ((file-name (let ((buffer-file-name file))
-		 (with-output-to-temp-buffer "*Directory*"
+			 (make-auto-save-file-name))))
-		   (buffer-disable-undo standard-output)
+	(cond ((if (file-exists-p file)
-		   (call-process "ls" nil standard-output nil
+		   (not (file-newer-than-file-p file-name file))
-				 (if (file-symlink-p file) "-lL" "-l")
+		 (not (file-exists-p file-name)))
-				 file file-name)))
+	       (error "Auto-save file %s not current" file-name))
-	     (yes-or-no-p (format "Recover auto save file %s? " file-name)))
+	      ((save-window-excursion
-	   (switch-to-buffer (find-file-noselect file t))
+		 (if (not (eq system-type 'vax-vms))
-	   (let ((buffer-read-only nil))
+		     (with-output-to-temp-buffer "*Directory*"
-	     (erase-buffer)
+		       (buffer-disable-undo standard-output)
-	     (insert-file-contents file-name nil))
+		       (call-process "ls" nil standard-output nil
-	   (after-find-file nil nil t))
+				     (if (file-symlink-p file) "-lL" "-l")
-	  (t (error "Recover-file cancelled.")))))
+				     file file-name)))
+		 (yes-or-no-p (format "Recover auto save file %s? " file-name)))
+	       (switch-to-buffer (find-file-noselect file t))
+	       (let ((buffer-read-only nil))
+		 (erase-buffer)
+		 (insert-file-contents file-name nil))
+	       (after-find-file nil nil t))
+	      (t (error "Recover-file cancelled.")))))))
 (defun recover-session ()
 "Recover auto save files from a previous Emacs session.
 This command first displays a Dired buffer showing you the
 previous sessions that you could recover from.

Mercurial > hg > xemacs-beta

comparison lisp/prim/files.el @ 74:54cc21c15cbb r20-0b32