comparison lisp/prim/files.el @ 8:4b173ad71786 r19-15b5

Import from CVS: tag r19-15b5
author cvs
date Mon, 13 Aug 2007 08:47:35 +0200
parents 27bc7f280385
children 0293115a14e9
comparison
equal deleted inserted replaced
7:c153ca296910 8:4b173ad71786
687 687
688 (defun create-file-buffer (filename) 688 (defun create-file-buffer (filename)
689 "Create a suitably named buffer for visiting FILENAME, and return it. 689 "Create a suitably named buffer for visiting FILENAME, and return it.
690 FILENAME (sans directory) is used unchanged if that name is free; 690 FILENAME (sans directory) is used unchanged if that name is free;
691 otherwise a string <2> or <3> or ... is appended to get an unused name." 691 otherwise a string <2> or <3> or ... is appended to get an unused name."
692 (let ((lastname (file-name-nondirectory filename))) 692 (let ((handler (find-file-name-handler filename 'create-file-buffer)))
693 (if (string= lastname "") 693 (if handler
694 (setq lastname filename)) 694 (funcall handler 'create-file-buffer filename)
695 (generate-new-buffer lastname))) 695 (let ((lastname (file-name-nondirectory filename)))
696 (if (string= lastname "")
697 (setq lastname filename))
698 (generate-new-buffer lastname)))))
696 699
697 (defun generate-new-buffer (name) 700 (defun generate-new-buffer (name)
698 "Create and return a buffer with a name based on NAME. 701 "Create and return a buffer with a name based on NAME.
699 Choose the buffer's name using `generate-new-buffer-name'." 702 Choose the buffer's name using `generate-new-buffer-name'."
700 (get-buffer-create (generate-new-buffer-name name))) 703 (get-buffer-create (generate-new-buffer-name name)))
709 (defun abbreviate-file-name (filename &optional hack-homedir) 712 (defun abbreviate-file-name (filename &optional hack-homedir)
710 "Return a version of FILENAME shortened using `directory-abbrev-alist'. 713 "Return a version of FILENAME shortened using `directory-abbrev-alist'.
711 See documentation of variable `directory-abbrev-alist' for more information. 714 See documentation of variable `directory-abbrev-alist' for more information.
712 If optional argument HACK-HOMEDIR is non-nil, then this also substitutes 715 If optional argument HACK-HOMEDIR is non-nil, then this also substitutes
713 \"~\" for the user's home directory." 716 \"~\" for the user's home directory."
714 ;; Get rid of the prefixes added by the automounter. 717 (let ((handler (find-file-name-handler filename 'abbreviate-file-name)))
715 ;(if (and (string-match automount-dir-prefix filename) 718 (if handler
716 ; (file-exists-p (file-name-directory 719 (funcall handler 'abbreviate-file-name filename hack-homedir)
717 ; (substring filename (1- (match-end 0)))))) 720 ;; Get rid of the prefixes added by the automounter.
718 ; (setq filename (substring filename (1- (match-end 0))))) 721 ;;(if (and (string-match automount-dir-prefix filename)
719 (let ((tail directory-abbrev-alist)) 722 ;; (file-exists-p (file-name-directory
720 ;; If any elt of directory-abbrev-alist matches this name, 723 ;; (substring filename (1- (match-end 0))))))
721 ;; abbreviate accordingly. 724 ;; (setq filename (substring filename (1- (match-end 0)))))
722 (while tail 725 (let ((tail directory-abbrev-alist))
723 (if (string-match (car (car tail)) filename) 726 ;; If any elt of directory-abbrev-alist matches this name,
724 (setq filename 727 ;; abbreviate accordingly.
725 (concat (cdr (car tail)) (substring filename (match-end 0))))) 728 (while tail
726 (setq tail (cdr tail)))) 729 (if (string-match (car (car tail)) filename)
727 (if hack-homedir 730 (setq filename
728 (progn 731 (concat (cdr (car tail)) (substring filename (match-end 0)))))
729 ;; Compute and save the abbreviated homedir name. 732 (setq tail (cdr tail))))
730 ;; We defer computing this until the first time it's needed, to 733 (if hack-homedir
731 ;; give time for directory-abbrev-alist to be set properly. 734 (progn
732 ;; We include a slash at the end, to avoid spurious matches 735 ;; Compute and save the abbreviated homedir name.
733 ;; such as `/usr/foobar' when the home dir is `/usr/foo'. 736 ;; We defer computing this until the first time it's needed, to
734 (or abbreviated-home-dir 737 ;; give time for directory-abbrev-alist to be set properly.
735 (setq abbreviated-home-dir 738 ;; We include a slash at the end, to avoid spurious matches
736 (let ((abbreviated-home-dir "$foo")) 739 ;; such as `/usr/foobar' when the home dir is `/usr/foo'.
737 (concat "\\`" (regexp-quote (abbreviate-file-name 740 (or abbreviated-home-dir
738 (expand-file-name "~"))) 741 (setq abbreviated-home-dir
739 "\\(/\\|\\'\\)")))) 742 (let ((abbreviated-home-dir "$foo"))
740 ;; If FILENAME starts with the abbreviated homedir, 743 (concat "\\`" (regexp-quote (abbreviate-file-name
741 ;; make it start with `~' instead. 744 (expand-file-name "~")))
742 (if (and (string-match abbreviated-home-dir filename) 745 "\\(/\\|\\'\\)"))))
743 ;; If the home dir is just /, don't change it. 746 ;; If FILENAME starts with the abbreviated homedir,
744 (not (and (= (match-end 0) 1) ;#### unix-specific 747 ;; make it start with `~' instead.
745 (= (aref filename 0) ?/))) 748 (if (and (string-match abbreviated-home-dir filename)
746 ;; MS-DOS root directories can come with a drive letter; 749 ;; If the home dir is just /, don't change it.
747 ;; Novell Netware allows drive letters beyond `Z:'. 750 (not (and (= (match-end 0) 1) ;#### unix-specific
748 (not (and (or (eq system-type 'ms-dos) 751 (= (aref filename 0) ?/)))
749 (eq system-type 'windows-nt)) 752 ;; MS-DOS root directories can come with a drive letter;
750 (save-match-data 753 ;; Novell Netware allows drive letters beyond `Z:'.
751 (string-match "^[a-zA-Z-`]:/$" filename))))) 754 (not (and (or (eq system-type 'ms-dos)
752 (setq filename 755 (eq system-type 'windows-nt))
753 (concat "~" 756 (save-match-data
754 (substring filename 757 (string-match "^[a-zA-Z-`]:/$" filename)))))
755 (match-beginning 1) (match-end 1)) 758 (setq filename
756 (substring filename (match-end 0))))))) 759 (concat "~"
757 filename) 760 (substring filename
761 (match-beginning 1) (match-end 1))
762 (substring filename (match-end 0)))))))
763 filename)))
758 764
759 (defvar find-file-not-true-dirname-list nil 765 (defvar find-file-not-true-dirname-list nil
760 "*List of logical names for which visiting shouldn't save the true dirname. 766 "*List of logical names for which visiting shouldn't save the true dirname.
761 On VMS, when you visit a file using a logical name that searches a path, 767 On VMS, when you visit a file using a logical name that searches a path,
762 you may or may not want the visited file name to record the specific 768 you may or may not want the visited file name to record the specific
1664 "Make a backup of the disk file visited by the current buffer, if appropriate. 1670 "Make a backup of the disk file visited by the current buffer, if appropriate.
1665 This is normally done before saving the buffer the first time. 1671 This is normally done before saving the buffer the first time.
1666 If the value is non-nil, it is the result of `file-modes' on the original 1672 If the value is non-nil, it is the result of `file-modes' on the original
1667 file; this means that the caller, after saving the buffer, should change 1673 file; this means that the caller, after saving the buffer, should change
1668 the modes of the new file to agree with the old modes." 1674 the modes of the new file to agree with the old modes."
1669 (if (and make-backup-files (not backup-inhibited) 1675 (if buffer-file-name
1670 (not buffer-backed-up) 1676 (let ((handler (find-file-name-handler buffer-file-name 'backup-buffer)))
1671 (file-exists-p buffer-file-name) 1677 (if handler
1672 (memq (aref (elt (file-attributes buffer-file-name) 8) 0) 1678 (funcall handler 'backup-buffer)
1673 '(?- ?l))) 1679 (if (and make-backup-files (not backup-inhibited)
1674 (let ((real-file-name buffer-file-name) 1680 (not buffer-backed-up)
1675 backup-info backupname targets setmodes) 1681 (file-exists-p buffer-file-name)
1676 ;; If specified name is a symbolic link, chase it to the target. 1682 (memq (aref (elt (file-attributes buffer-file-name) 8) 0)
1677 ;; Thus we make the backups in the directory where the real file is. 1683 '(?- ?l)))
1678 (setq real-file-name (file-chase-links real-file-name)) 1684 (let ((real-file-name buffer-file-name)
1679 (setq backup-info (find-backup-file-name real-file-name) 1685 backup-info backupname targets setmodes)
1680 backupname (car backup-info) 1686 ;; If specified name is a symbolic link, chase it to the target.
1681 targets (cdr backup-info)) 1687 ;; Thus we make the backups in the directory where the real file is.
1688 (setq real-file-name (file-chase-links real-file-name))
1689 (setq backup-info (find-backup-file-name real-file-name)
1690 backupname (car backup-info)
1691 targets (cdr backup-info))
1682 ;;; (if (file-directory-p buffer-file-name) 1692 ;;; (if (file-directory-p buffer-file-name)
1683 ;;; (error "Cannot save buffer in directory %s" buffer-file-name)) 1693 ;;; (error "Cannot save buffer in directory %s" buffer-file-name))
1684 (if backup-info 1694 (if backup-info
1685 (condition-case () 1695 (condition-case ()
1686 (let ((delete-old-versions 1696 (let ((delete-old-versions
1687 ;; If have old versions to maybe delete, 1697 ;; If have old versions to maybe delete,
1688 ;; ask the user to confirm now, before doing anything. 1698 ;; ask the user to confirm now, before doing anything.
1689 ;; But don't actually delete til later. 1699 ;; But don't actually delete til later.
1690 (and targets 1700 (and targets
1691 (or (eq delete-old-versions t) 1701 (or (eq delete-old-versions t)
1692 (eq delete-old-versions nil)) 1702 (eq delete-old-versions nil))
1693 (or delete-old-versions 1703 (or delete-old-versions
1694 (y-or-n-p (format "Delete excess backup versions of %s? " 1704 (y-or-n-p (format "Delete excess backup versions of %s? "
1695 real-file-name)))))) 1705 real-file-name))))))
1696 ;; Actually write the back up file. 1706 ;; Actually write the back up file.
1697 (condition-case ()
1698 (if (or file-precious-flag
1699 ; (file-symlink-p buffer-file-name)
1700 backup-by-copying
1701 (and backup-by-copying-when-linked
1702 (> (file-nlinks real-file-name) 1))
1703 (and backup-by-copying-when-mismatch
1704 (let ((attr (file-attributes real-file-name)))
1705 (or (nth 9 attr)
1706 (not (file-ownership-preserved-p real-file-name))))))
1707 (condition-case () 1707 (condition-case ()
1708 (copy-file real-file-name backupname t t) 1708 (if (or file-precious-flag
1709 ; (file-symlink-p buffer-file-name)
1710 backup-by-copying
1711 (and backup-by-copying-when-linked
1712 (> (file-nlinks real-file-name) 1))
1713 (and backup-by-copying-when-mismatch
1714 (let ((attr (file-attributes real-file-name)))
1715 (or (nth 9 attr)
1716 (not (file-ownership-preserved-p real-file-name))))))
1717 (condition-case ()
1718 (copy-file real-file-name backupname t t)
1719 (file-error
1720 ;; If copying fails because file BACKUPNAME
1721 ;; is not writable, delete that file and try again.
1722 (if (and (file-exists-p backupname)
1723 (not (file-writable-p backupname)))
1724 (delete-file backupname))
1725 (copy-file real-file-name backupname t t)))
1726 ;; rename-file should delete old backup.
1727 (rename-file real-file-name backupname t)
1728 (setq setmodes (file-modes backupname)))
1709 (file-error 1729 (file-error
1710 ;; If copying fails because file BACKUPNAME 1730 ;; If trouble writing the backup, write it in ~.
1711 ;; is not writable, delete that file and try again. 1731 (setq backupname (expand-file-name
1712 (if (and (file-exists-p backupname) 1732 (convert-standard-filename
1713 (not (file-writable-p backupname))) 1733 "~/%backup%~")))
1714 (delete-file backupname)) 1734 (message "Cannot write backup file; backing up in %s"
1715 (copy-file real-file-name backupname t t))) 1735 (file-name-nondirectory backupname))
1716 ;; rename-file should delete old backup. 1736 (sleep-for 1)
1717 (rename-file real-file-name backupname t) 1737 (condition-case ()
1718 (setq setmodes (file-modes backupname))) 1738 (copy-file real-file-name backupname t t)
1719 (file-error 1739 (file-error
1720 ;; If trouble writing the backup, write it in ~. 1740 ;; If copying fails because file BACKUPNAME
1721 (setq backupname (expand-file-name 1741 ;; is not writable, delete that file and try again.
1722 (convert-standard-filename 1742 (if (and (file-exists-p backupname)
1723 "~/%backup%~"))) 1743 (not (file-writable-p backupname)))
1724 (message "Cannot write backup file; backing up in %s" 1744 (delete-file backupname))
1725 (file-name-nondirectory backupname)) 1745 (copy-file real-file-name backupname t t)))))
1726 (sleep-for 1) 1746 (setq buffer-backed-up t)
1727 (condition-case () 1747 ;; Now delete the old versions, if desired.
1728 (copy-file real-file-name backupname t t) 1748 (if delete-old-versions
1729 (file-error 1749 (while targets
1730 ;; If copying fails because file BACKUPNAME 1750 (condition-case ()
1731 ;; is not writable, delete that file and try again. 1751 (delete-file (car targets))
1732 (if (and (file-exists-p backupname) 1752 (file-error nil))
1733 (not (file-writable-p backupname))) 1753 (setq targets (cdr targets))))
1734 (delete-file backupname)) 1754 setmodes)
1735 (copy-file real-file-name backupname t t))))) 1755 (file-error nil)))))))))
1736 (setq buffer-backed-up t)
1737 ;; Now delete the old versions, if desired.
1738 (if delete-old-versions
1739 (while targets
1740 (condition-case ()
1741 (delete-file (car targets))
1742 (file-error nil))
1743 (setq targets (cdr targets))))
1744 setmodes)
1745 (file-error nil))))))
1746 1756
1747 (defun file-name-sans-versions (name &optional keep-backup-version) 1757 (defun file-name-sans-versions (name &optional keep-backup-version)
1748 "Return FILENAME sans backup versions or strings. 1758 "Return FILENAME sans backup versions or strings.
1749 This is a separate procedure so your site-init or startup file can 1759 This is a separate procedure so your site-init or startup file can
1750 redefine it. 1760 redefine it.
2489 ;; Actually putting the file name in the minibuffer should be used 2499 ;; Actually putting the file name in the minibuffer should be used
2490 ;; only rarely. 2500 ;; only rarely.
2491 ;; Not just because users often use the default. 2501 ;; Not just because users often use the default.
2492 (interactive "FRecover file: ") 2502 (interactive "FRecover file: ")
2493 (setq file (expand-file-name file)) 2503 (setq file (expand-file-name file))
2494 (if (auto-save-file-name-p (file-name-nondirectory file)) 2504 (let ((handler (or (find-file-name-handler file 'recover-file)
2495 (error "%s is an auto-save file" file)) 2505 (find-file-name-handler
2496 (let ((file-name (let ((buffer-file-name file)) 2506 (let ((buffer-file-name file))
2497 (make-auto-save-file-name)))) 2507 (make-auto-save-file-name))
2498 (cond ((if (file-exists-p file) 2508 'recover-file))))
2499 (not (file-newer-than-file-p file-name file)) 2509 (if handler
2500 (not (file-exists-p file-name))) 2510 (funcall handler 'recover-file file)
2501 (error "Auto-save file %s not current" file-name)) 2511 (if (auto-save-file-name-p (file-name-nondirectory file))
2502 ((save-window-excursion 2512 (error "%s is an auto-save file" file))
2503 (if (not (eq system-type 'vax-vms)) 2513 (let ((file-name (let ((buffer-file-name file))
2504 (with-output-to-temp-buffer "*Directory*" 2514 (make-auto-save-file-name))))
2505 (buffer-disable-undo standard-output) 2515 (cond ((if (file-exists-p file)
2506 (call-process "ls" nil standard-output nil 2516 (not (file-newer-than-file-p file-name file))
2507 (if (file-symlink-p file) "-lL" "-l") 2517 (not (file-exists-p file-name)))
2508 file file-name))) 2518 (error "Auto-save file %s not current" file-name))
2509 (yes-or-no-p (format "Recover auto save file %s? " file-name))) 2519 ((save-window-excursion
2510 (switch-to-buffer (find-file-noselect file t)) 2520 (if (not (eq system-type 'vax-vms))
2511 (let ((buffer-read-only nil)) 2521 (with-output-to-temp-buffer "*Directory*"
2512 (erase-buffer) 2522 (buffer-disable-undo standard-output)
2513 (insert-file-contents file-name nil)) 2523 (call-process "ls" nil standard-output nil
2514 (after-find-file nil nil t)) 2524 (if (file-symlink-p file) "-lL" "-l")
2515 (t (error "Recover-file cancelled."))))) 2525 file file-name)))
2526 (yes-or-no-p (format "Recover auto save file %s? " file-name)))
2527 (switch-to-buffer (find-file-noselect file t))
2528 (let ((buffer-read-only nil))
2529 (erase-buffer)
2530 (insert-file-contents file-name nil))
2531 (after-find-file nil nil t))
2532 (t (error "Recover-file cancelled.")))))))
2516 2533
2517 (defun recover-session () 2534 (defun recover-session ()
2518 "Recover auto save files from a previous Emacs session. 2535 "Recover auto save files from a previous Emacs session.
2519 This command first displays a Dired buffer showing you the 2536 This command first displays a Dired buffer showing you the
2520 previous sessions that you could recover from. 2537 previous sessions that you could recover from.