Mercurial > hg > xemacs-beta

comparison lisp/files.el @ 464:5aa1854ad537 r21-2-47

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-47
author cvs
date Mon, 13 Aug 2007 11:45:51 +0200
parents 576fb035e263
children 7039e6323819
comparison
equal deleted inserted replaced
463:a158004111cd 464:5aa1854ad537
369 ; inhibit-file-name-handlers))) 369 ; inhibit-file-name-handlers)))
370 ; (inhibit-file-name-operation op)) 370 ; (inhibit-file-name-operation op))
371 ; (apply op args)) 371 ; (apply op args))
372 372
373 (defun convert-standard-filename (filename) 373 (defun convert-standard-filename (filename)
374 "Convert a standard file's name to something suitable for the current OS. 374 "Convert a standard file's name to something suitable for the current OS."
375 This function's standard definition is trivial; it just returns the argument. 375 (if (eq system-type 'windows-nt)
376 However, on some systems, the function is redefined 376 (let ((name (copy-sequence filename))
377 with a definition that really does change some file names." 377 (start 0))
378 filename) 378 ;; leave ':' if part of drive specifier
379 (if (eq (aref name 1) ?:)
380 (setq start 2))
381 ;; destructively replace invalid filename characters with !
382 (while (string-match "[?*:<>|\"\000-\037]" name start)
383 (aset name (match-beginning 0) ?!)
384 (setq start (match-end 0)))
385 ;; FSF: [convert directory separators to Windows format ...]
386 ;; unneeded in XEmacs.
387 name)
388 filename))
389
379 390
380 (defun pwd () 391 (defun pwd ()
381 "Show the current default directory." 392 "Show the current default directory."
382 (interactive nil) 393 (interactive nil)
383 (message "Directory %s" default-directory)) 394 (message "Directory %s" default-directory))
1925 ;; rename-file should delete old backup. 1936 ;; rename-file should delete old backup.
1926 (rename-file real-file-name backupname t) 1937 (rename-file real-file-name backupname t)
1927 (setq setmodes (file-modes backupname))) 1938 (setq setmodes (file-modes backupname)))
1928 (file-error 1939 (file-error
1929 ;; If trouble writing the backup, write it in ~. 1940 ;; If trouble writing the backup, write it in ~.
1930 (setq backupname (expand-file-name "~/%backup%~")) 1941 (setq backupname
1942 (expand-file-name
1943 (convert-standard-filename "~/%backup%~")))
1931 (message "Cannot write backup file; backing up in ~/%%backup%%~") 1944 (message "Cannot write backup file; backing up in ~/%%backup%%~")
1932 (sleep-for 1) 1945 (sleep-for 1)
1933 (condition-case () 1946 (condition-case ()
1934 (copy-file real-file-name backupname t t) 1947 (copy-file real-file-name backupname t t)
1935 (file-error 1948 (file-error
2011 ""))))) 2024 "")))))
2012 2025
2013 (defun make-backup-file-name (file) 2026 (defun make-backup-file-name (file)
2014 "Create the non-numeric backup file name for FILE. 2027 "Create the non-numeric backup file name for FILE.
2015 This is a separate function so you can redefine it for customization." 2028 This is a separate function so you can redefine it for customization."
2029 ;; FSF has code here for MS-DOS short filenames, not supported in XEmacs.
2016 (concat file "~")) 2030 (concat file "~"))
2017 2031
2018 (defun backup-file-name-p (file) 2032 (defun backup-file-name-p (file)
2019 "Return non-nil if FILE is a backup file name (numeric or not). 2033 "Return non-nil if FILE is a backup file name (numeric or not).
2020 This is a separate function so you can redefine it for customization. 2034 This is a separate function so you can redefine it for customization.
2038 (defun find-backup-file-name (fn) 2052 (defun find-backup-file-name (fn)
2039 "Find a file name for a backup file, and suggestions for deletions. 2053 "Find a file name for a backup file, and suggestions for deletions.
2040 Value is a list whose car is the name for the backup file 2054 Value is a list whose car is the name for the backup file
2041 and whose cdr is a list of old versions to consider deleting now. 2055 and whose cdr is a list of old versions to consider deleting now.
2042 If the value is nil, don't make a backup." 2056 If the value is nil, don't make a backup."
2057 (declare (special bv-length))
2043 (let ((handler (find-file-name-handler fn 'find-backup-file-name))) 2058 (let ((handler (find-file-name-handler fn 'find-backup-file-name)))
2044 ;; Run a handler for this function so that ange-ftp can refuse to do it. 2059 ;; Run a handler for this function so that ange-ftp can refuse to do it.
2045 (if handler 2060 (if handler
2046 (funcall handler 'find-backup-file-name fn) 2061 (funcall handler 'find-backup-file-name fn)
2047 (if (eq version-control 'never) 2062 (if (eq version-control 'never)
2759 (let ((buffer-file-name file)) 2774 (let ((buffer-file-name file))
2760 (make-auto-save-file-name)) 2775 (make-auto-save-file-name))
2761 'recover-file)))) 2776 'recover-file))))
2762 (if handler 2777 (if handler
2763 (funcall handler 'recover-file file) 2778 (funcall handler 'recover-file file)
2764 (if (auto-save-file-name-p file) 2779 (if (auto-save-file-name-p (file-name-nondirectory file))
2765 (error "%s is an auto-save file" file)) 2780 (error "%s is an auto-save file" file))
2766 (let ((file-name (let ((buffer-file-name file)) 2781 (let ((file-name (let ((buffer-file-name file))
2767 (make-auto-save-file-name)))) 2782 (make-auto-save-file-name))))
2768 (cond ((if (file-exists-p file) 2783 (cond ((if (file-exists-p file)
2769 (not (file-newer-than-file-p file-name file)) 2784 (not (file-newer-than-file-p file-name file))
2770 (not (file-exists-p file-name))) 2785 (not (file-exists-p file-name)))
2771 (error "Auto-save file %s not current" file-name)) 2786 (error "Auto-save file %s not current" file-name))
2772 ((save-window-excursion 2787 ((save-window-excursion
2773 (if (not (eq system-type 'windows-nt)) 2788 ;; XEmacs change: use insert-directory instead of
2774 (with-output-to-temp-buffer "*Directory*" 2789 ;; calling ls directly.
2775 (buffer-disable-undo standard-output) 2790 (with-output-to-temp-buffer "*Directory*"
2776 (call-process "ls" nil standard-output nil 2791 (buffer-disable-undo standard-output)
2777 (if (file-symlink-p file) "-lL" "-l") 2792 (save-excursion
2778 file file-name))) 2793 (set-buffer "*Directory*")
2794 (setq default-directory (file-name-directory file))
2795 (insert-directory file
2796 (if (file-symlink-p file) "-lL" "-l"))
2797 (setq default-directory (file-name-directory file-name))
2798 (insert-directory file-name "-l")))
2779 (yes-or-no-p (format "Recover auto save file %s? " file-name))) 2799 (yes-or-no-p (format "Recover auto save file %s? " file-name)))
2780 (switch-to-buffer (find-file-noselect file t)) 2800 (switch-to-buffer (find-file-noselect file t))
2781 (let ((buffer-read-only nil)) 2801 (let ((buffer-read-only nil))
2782 (erase-buffer) 2802 (erase-buffer)
2783 (insert-file-contents file-name nil)) 2803 (insert-file-contents file-name nil))
2939 (not (string= buffer-auto-save-file-name osave)) 2959 (not (string= buffer-auto-save-file-name osave))
2940 (file-exists-p osave) 2960 (file-exists-p osave)
2941 (recent-auto-save-p)) 2961 (recent-auto-save-p))
2942 (rename-file osave buffer-auto-save-file-name t)))) 2962 (rename-file osave buffer-auto-save-file-name t))))
2943 2963
2944 ;; see also ../packages/auto-save.el 2964 ;; make-auto-save-file-name and auto-save-file-name-p are now only in
2945 (defun make-auto-save-file-name (&optional filename) 2965 ;; auto-save.el.
2946 "Return file name to use for auto-saves of current buffer. 2966
2947 Does not consider `auto-save-visited-file-name' as that variable is checked
2948 before calling this function. You can redefine this for customization.
2949 See also `auto-save-file-name-p'."
2950 (let ((fname (or filename buffer-file-name))
2951 name)
2952 (setq name
2953 (if fname
2954 (concat (file-name-directory fname)
2955 "#"
2956 (file-name-nondirectory fname)
2957 "#")
2958
2959 ;; Deal with buffers that don't have any associated files. (Mail
2960 ;; mode tends to create a good number of these.)
2961
2962 (let ((buffer-name (buffer-name))
2963 (limit 0))
2964 ;; Use technique from Sebastian Kremer's auto-save
2965 ;; package to turn slashes into \\!. This ensures that
2966 ;; the auto-save buffer name is unique.
2967
2968 ;; #### - yuck! yuck! yuck! move this functionality
2969 ;; somewhere else and make the name translation customizable.
2970 ;; Using "\!" as part of a filename on a UNIX filesystem is nearly
2971 ;; IMPOSSIBLE to get past a shell parser. -stig
2972
2973 (while (string-match "[/\\]" buffer-name limit)
2974 (setq buffer-name
2975 (concat (substring buffer-name 0 (match-beginning 0))
2976 (if (string= (substring buffer-name
2977 (match-beginning 0)
2978 (match-end 0))
2979 "/")
2980 "\\!"
2981 "\\\\")
2982 (substring buffer-name (match-end 0))))
2983 (setq limit (1+ (match-end 0))))
2984
2985 ;; (expand-file-name (format "#%s#%s#" (buffer-name) (make-temp-name "")))
2986
2987 ;; jwz: putting the emacs PID in the auto-save file name
2988 ;; is bad news, because that defeats auto-save-recovery of
2989 ;; *mail* buffers -- the (sensible) code in sendmail.el
2990 ;; calls (make-auto-save-file-name) to determine whether
2991 ;; there is unsent, auto-saved mail to recover. If that
2992 ;; mail came from a previous emacs process (far and away
2993 ;; the most likely case) then this can never succeed as
2994 ;; the pid differs.
2995
2996 (expand-file-name (format "#%s#" buffer-name)))
2997 ))
2998 ;; don't try to write auto-save files in unwritable places. Unless
2999 ;; there's already an autosave file here, put ours somewhere safe. --Stig
3000 (if (or (file-writable-p name)
3001 (file-exists-p name))
3002 name
3003 (expand-file-name (concat "~/" (file-name-nondirectory name))))))
3004
3005 (defun auto-save-file-name-p (filename)
3006 "Return non-nil if FILENAME can be yielded by `make-auto-save-file-name'.
3007 FILENAME should lack slashes.
3008 You can redefine this for customization."
3009 (string-match "\\`#.*#\\'" filename))
3010 2967
3011 (defun wildcard-to-regexp (wildcard) 2968 (defun wildcard-to-regexp (wildcard)
3012 "Given a shell file name pattern WILDCARD, return an equivalent regexp. 2969 "Given a shell file name pattern WILDCARD, return an equivalent regexp.
3013 The generated regexp will match a filename iff the filename 2970 The generated regexp will match a filename iff the filename
3014 matches that wildcard according to shell rules. Only wildcards known 2971 matches that wildcard according to shell rules. Only wildcards known
3148 'insert-directory))) 3105 'insert-directory)))
3149 (if handler 3106 (if handler
3150 (funcall handler 'insert-directory file switches 3107 (funcall handler 'insert-directory file switches
3151 wildcard full-directory-p) 3108 wildcard full-directory-p)
3152 (cond 3109 (cond
3153 ;; #### mswindows-insert-directory should be called 3110 ;; [mswindows-insert-directory should be called
3154 ;; nt-insert-directory - kkm. 3111 ;; nt-insert-directory - kkm]. not true any more according to
3112 ;; my new naming scheme. --ben
3155 ((and (fboundp 'mswindows-insert-directory) 3113 ((and (fboundp 'mswindows-insert-directory)
3156 (eq system-type 'windows-nt)) 3114 (eq system-type 'windows-nt))
3157 (mswindows-insert-directory file switches wildcard full-directory-p)) 3115 (mswindows-insert-directory file switches wildcard full-directory-p))
3158 (t 3116 (t
3159 (if wildcard 3117 (if wildcard