Mercurial > hg > xemacs-beta
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. |