Commit ffc0e1ca authored by André Spiegel's avatar André Spiegel
Browse files

Fix prev change.

parent 27371448
;;; files.el --- file input and output commands for Emacs
;; Copyright (C) 1985, 86, 87, 92, 93,
;; 94, 95, 96, 97, 98, 1998 Free Software Foundation, Inc.
;; 94, 95, 96, 97, 98, 99, 2000 Free Software Foundation, Inc.
;; Maintainer: FSF
......@@ -84,8 +84,9 @@ names that the old file had will now refer to the new (edited) file.
The file's owner and group are unchanged.
The choice of renaming or copying is controlled by the variables
`backup-by-copying', `backup-by-copying-when-linked' and
`backup-by-copying-when-mismatch'. See also `backup-inhibited'."
`backup-by-copying', `backup-by-copying-when-linked',
`backup-by-copying-when-mismatch' and
`backup-by-copying-when-privileged-mismatch'. See also `backup-inhibited'."
:type 'boolean
:group 'backup)
......@@ -120,16 +121,42 @@ This variable is relevant only if `backup-by-copying' is nil."
:type 'boolean
:group 'backup)
(defvar backup-enable-predicate
'(lambda (name)
(or (< (length name) 5)
(not (string-equal "/tmp/" (substring name 0 5)))))
(defcustom backup-by-copying-when-privileged-mismatch 200
"*Non-nil means create backups by copying to preserve a privileged owner.
Renaming may still be used (subject to control of other variables)
when it would not result in changing the owner of the file or if the owner
has a user id greater than the value of this variable. This is useful
when low-numbered uid's are used for special system users (such as root)
that must maintain ownership of certain files.
This variable is relevant only if `backup-by-copying' and
`backup-by-copying-when-mismatch' are nil."
:type '(choice (const nil) integer)
:group 'backup)
(defun normal-backup-enable-predicate (name)
"Default `backup-enable-predicate' function.
Checks for files in `temporary-file-directory' or
`small-temporary-file-directory'."
(not (or (let ((comp (compare-strings temporary-file-directory 0 nil
name 0 nil)))
;; Directory is under temporary-file-directory.
(and (not (eq comp t))
(< comp (- (length temporary-file-directory)))))
(if small-temporary-file-directory
(let ((comp (compare-strings small-temporary-file-directory
0 nil
name 0 nil)))
;; Directory is under small-temporary-file-directory.
(and (not (eq comp t))
(< comp (- (length small-temporary-file-directory)))))))))
(defvar backup-enable-predicate 'normal-backup-enable-predicate
"Predicate that looks at a file name and decides whether to make backups.
Called with an absolute file name as argument, it returns t to enable backup.")
(defcustom buffer-offer-save nil
"*Non-nil in a buffer means offer to save the buffer on exit
even if the buffer is not visiting a file.
"*Non-nil in a buffer means always offer to save buffer on exit.
Do so even if the buffer is not visiting a file.
Automatically local in all buffers."
:type 'boolean
:group 'backup)
......@@ -254,6 +281,23 @@ Normally auto-save files are written under other names."
:type 'boolean
:group 'auto-save)
(defcustom auto-save-file-name-transforms
'(("\\`/[^/]*:\\(.+/\\)*\\(.*\\)" "/tmp/\\2"))
"*Transforms to apply to buffer file name before making auto-save file name.
Each transform is a list (REGEXP REPLACEMENT):
REGEXP is a regular expression to match against the file name.
If it matches, `replace-match' is used to replace the
matching part with REPLACEMENT.
All the transforms in the list are tried, in the order they are listed.
When one transform applies, its result is final;
no further transforms are tried.
The default value is set up to put the auto-save file into `/tmp'
for editing a remote file."
:group 'auto-save
:type '(repeat (list (string :tag "Regexp") (string :tag "Replacement")))
:version "21.1")
(defcustom save-abbrevs nil
"*Non-nil means save word abbrevs too when files are saved.
Loading an abbrev file sets this to t."
......@@ -261,16 +305,24 @@ Loading an abbrev file sets this to t."
:group 'abbrev)
(defcustom find-file-run-dired t
"*Non-nil says run dired if `find-file' is given the name of a directory."
"*Non-nil means allow `find-file' to visit directories.
To visit the directory, `find-file' runs `find-directory-functions'."
:type 'boolean
:group 'find-file)
(defcustom find-directory-functions '(cvs-dired-noselect dired-noselect)
"*List of functions to try in sequence to visit a directory.
Each function is called with the directory name as the sole argument
and should return either a buffer or nil."
:type '(hook :options (cvs-dired-noselect dired-noselect))
:group 'find-file)
;;;It is not useful to make this a local variable.
;;;(put 'find-file-not-found-hooks 'permanent-local t)
(defvar find-file-not-found-hooks nil
"List of functions to be called for `find-file' on nonexistent file.
These functions are called as soon as the error is detected.
`buffer-file-name' is already set up.
Variable `buffer-file-name' is already set up.
The functions are called in the order given until one of them returns non-nil.")
;;;It is not useful to make this a local variable.
......@@ -285,7 +337,8 @@ functions are called.")
If one of them returns non-nil, the file is considered already written
and the rest are not called.
These hooks are considered to pertain to the visited file.
So this list is cleared if you change the visited file name.
So any buffer-local binding of `write-file-hooks' is
discarded if you change the visited file name with \\[set-visited-file-name].
Don't make this variable buffer-local; instead, use `local-write-file-hooks'.
See also `write-contents-hooks'.")
......@@ -380,14 +433,21 @@ and ignores this variable."
(or (getenv "TMPDIR") (getenv "TMP") (getenv "TEMP") "/tmp"))))
"The directory for writing temporary files.")
(defvar small-temporary-file-directory
(if (eq system-type 'ms-dos) (getenv "TMPDIR"))
"The directory for writing small temporary files.
If non-nil, this directory is used instead of `temporary-file-directory'
by programs that create small temporary files. This is for systems that
have fast storage with limited space, such as a RAM disk.")
;; The system null device. (Should reference NULL_DEVICE from C.)
(defvar null-device "/dev/null" "The system null device.")
;; This hook function provides support for ange-ftp host name
;; completion. It runs the usual ange-ftp hook, but only for
;; completion operations. Having this here avoids the need
;; to load ange-ftp when it's not really in use.
(defun ange-ftp-completion-hook-function (op &rest args)
"Provides support for ange-ftp host name completion.
Runs the usual ange-ftp hook, but only for completion operations."
;; Having this here avoids the need to load ange-ftp when it's not
;; really in use.
(if (memq op '(file-name-completion file-name-all-completions))
(apply 'ange-ftp-hook-function op args)
(let ((inhibit-file-name-handlers
......@@ -400,8 +460,9 @@ and ignores this variable."
(defun convert-standard-filename (filename)
"Convert a standard file's name to something suitable for the current OS.
This function's standard definition is trivial; it just returns the argument.
However, on some systems, the function is redefined
with a definition that really does change some file names."
However, on some systems, the function is redefined with a definition
that really does change some file names to canonicalize certain
patterns and to guarantee valid names."
filename)
(defun pwd ()
......@@ -414,7 +475,9 @@ with a definition that really does change some file names."
Not actually set up until the first time you you use it.")
(defun parse-colon-path (cd-path)
"Explode a colon-separated search path into a list of directory names."
"Explode a colon-separated search path into a list of directory names.
\(For values of `colon' equal to `path-separator'.)"
;; We could use split-string here.
(and cd-path
(let (cd-prefix cd-list (cd-start 0) cd-colon)
(setq cd-path (concat cd-path path-separator))
......@@ -473,7 +536,9 @@ colon-separated list of directories when resolving a relative directory name."
(defun load-file (file)
"Load the Lisp file named FILE."
(interactive "fLoad file: ")
(load (expand-file-name file) nil nil t))
(let ((completion-ignored-extensions
(delete ".elc" completion-ignored-extensions)))
(load (expand-file-name file) nil nil t)))
(defun load-library (library)
"Load the library named LIBRARY.
......@@ -481,10 +546,12 @@ This is an interface to the function `load'."
(interactive "sLoad library: ")
(load library))
(defun file-local-copy (file &optional buffer)
(defun file-local-copy (file)
"Copy the file FILE into a temporary file on this machine.
Returns the name of the local copy, or nil, if FILE is directly
accessible."
;; This formerly had an optional BUFFER argument that wasn't used by
;; anything.
(let ((handler (find-file-name-handler file 'file-local-copy)))
(if handler
(funcall handler 'file-local-copy file)
......@@ -541,7 +608,7 @@ Do not specify them in other calls."
(if handler
(setq filename (funcall handler 'file-truename filename))
;; If filename contains a wildcard, newname will be the old name.
(if (string-match "[*?]" filename)
(if (string-match "[[*?]" filename)
(setq newname filename)
;; If filename doesn't exist, newname will be nil.
(setq newname (w32-long-file-name filename)))
......@@ -651,7 +718,8 @@ do not put this buffer at the front of the list of recently selected ones."
Switch to a buffer visiting file FILENAME,
creating one if none already exists.
Interactively, or if WILDCARDS is non-nil in a call from Lisp,
expand wildcards (if any) and visit multiple files."
expand wildcards (if any) and visit multiple files. Wildcard expansion
can be suppressed by setting `find-file-wildcards'."
(interactive "FFind file: \np")
(let ((value (find-file-noselect filename nil nil wildcards)))
(if (listp value)
......@@ -690,7 +758,7 @@ expand wildcards (if any) and visit multiple files."
(defun find-file-read-only (filename &optional wildcards)
"Edit file FILENAME but don't allow changes.
Like \\[find-file] but marks buffer as read-only.
Like `find-file' but marks buffer as read-only.
Use \\[toggle-read-only] to permit editing."
(interactive "fFind file read-only: \np")
(find-file filename wildcards)
......@@ -791,11 +859,13 @@ otherwise a string <2> or <3> or ... is appended to get an unused name."
Choose the buffer's name using `generate-new-buffer-name'."
(get-buffer-create (generate-new-buffer-name name)))
(defvar automount-dir-prefix "^/tmp_mnt/"
"Regexp to match the automounter prefix in a directory name.")
(defcustom automount-dir-prefix "^/tmp_mnt/"
"Regexp to match the automounter prefix in a directory name."
:group 'files
:type 'regexp)
(defvar abbreviated-home-dir nil
"The user's homedir abbreviated according to `directory-abbrev-list'.")
"The user's homedir abbreviated according to `directory-abbrev-alist'.")
(defun abbreviate-file-name (filename)
"Return a version of FILENAME shortened using `directory-abbrev-alist'.
......@@ -896,6 +966,15 @@ whose names match the pattern."
:version "20.4"
:type 'boolean)
(defcustom find-file-suppress-same-file-warnings nil
"*Non-nil means suppress warning messages for symlinked files.
When nil, Emacs prints a warning when visiting a file that is already
visited, but with a different name. Setting this option to t
suppresses this warning."
:group 'files
:version "21.1"
:type 'boolean)
(defun find-file-noselect (filename &optional nowarn rawfile wildcards)
"Read file FILENAME into a buffer and return the buffer.
If a buffer exists visiting FILENAME, return that one, but
......@@ -911,21 +990,24 @@ that are visiting the various files."
(abbreviate-file-name
(expand-file-name filename)))
(if (file-directory-p filename)
(if find-file-run-dired
(dired-noselect (if find-file-visit-truename
(or (and find-file-run-dired
(run-hook-with-args-until-success
'find-directory-functions
(if find-file-visit-truename
(abbreviate-file-name (file-truename filename))
filename))
filename)))
(error "%s is a directory" filename))
(if (and wildcards
find-file-wildcards
(not (string-match "\\`/:" filename))
(string-match "[[*?]" filename))
(let ((files (file-expand-wildcards filename t))
(let ((files (condition-case nil
(file-expand-wildcards filename t)
(error (list filename))))
(find-file-wildcards nil))
(if (null files)
(error "No files match `%s'" filename))
(mapcar #'(lambda (fn) (find-file-noselect fn))
files))
(find-file-noselect filename)
(car (mapcar #'find-file-noselect files))))
(let* ((buf (get-file-buffer filename))
(truename (abbreviate-file-name (file-truename filename)))
(number (nthcdr 10 (file-attributes truename)))
......@@ -935,6 +1017,7 @@ that are visiting the various files."
(if other
(progn
(or nowarn
find-file-suppress-same-file-warnings
(string-equal filename (buffer-file-name other))
(message "%s and %s are the same file"
filename (buffer-file-name other)))
......@@ -1167,10 +1250,15 @@ unless NOMODES is non-nil."
(msg
(cond ((and error (file-attributes buffer-file-name))
(setq buffer-read-only t)
"File exists, but cannot be read.")
"File exists, but cannot be read")
((not buffer-read-only)
(if (and warn
(file-newer-than-file-p (make-auto-save-file-name)
;; No need to warn if buffer is auto-saved
;; under the name of the visited file.
(not (and buffer-file-name
auto-save-visited-file-name))
(file-newer-than-file-p (or buffer-auto-save-file-name
(make-auto-save-file-name))
buffer-file-name))
(format "%s has auto save data; consider M-x recover-file"
(file-name-nondirectory buffer-file-name))
......@@ -1194,8 +1282,14 @@ unless NOMODES is non-nil."
(or not-serious (sit-for 1 nil t)))))
(if (and auto-save-default (not noauto))
(auto-save-mode t)))
;; Make people do a little extra work (C-x C-q)
;; before altering a backup file.
(if (backup-file-name-p buffer-file-name)
(setq buffer-read-only t))
(if nomodes
nil
(and view-read-only view-mode
(view-mode-disable))
(normal-mode t)
(if (and buffer-read-only view-read-only
(not (eq (get major-mode 'mode-class) 'special)))
......@@ -1231,6 +1325,9 @@ in that case, this function acts as if `enable-local-variables' were t."
(prin1-to-string err)))))
(defvar auto-mode-alist
(mapc
(lambda (elt)
(cons (purecopy (car elt)) (cdr elt)))
'(("\\.te?xt\\'" . text-mode)
("\\.c\\'" . c-mode)
("\\.h\\'" . c-mode)
......@@ -1281,7 +1378,7 @@ in that case, this function acts as if `enable-local-variables' were t."
("\\.scm\\.[0-9]*\\'" . scheme-mode)
("\\.[ck]?sh\\'\\|\\.shar\\'\\|/\\.z?profile\\'" . sh-mode)
("\\(/\\|\\`\\)\\.\\(bash_profile\\|z?login\\|bash_login\\|z?logout\\)\\'" . sh-mode)
("\\(/\\|\\`\\)\\.\\(bash_logout\\|[kz]shrc\\|bashrc\\|t?cshrc\\|esrc\\)\\'" . sh-mode)
("\\(/\\|\\`\\)\\.\\(bash_logout\\|shrc\\|[kz]shrc\\|bashrc\\|t?cshrc\\|esrc\\)\\'" . sh-mode)
("\\(/\\|\\`\\)\\.\\([kz]shenv\\|xinitrc\\|startxrc\\|xsession\\)\\'" . sh-mode)
("\\.m?spec$" . sh-mode)
("\\.mm\\'" . nroff-mode)
......@@ -1315,6 +1412,7 @@ in that case, this function acts as if `enable-local-variables' were t."
("\\.sim\\'" . simula-mode)
("\\.mss\\'" . scribe-mode)
("\\.f90\\'" . f90-mode)
("\\.pro\\'" . idlwave-mode)
("\\.lsp\\'" . lisp-mode)
("\\.awk\\'" . awk-mode)
("\\.prolog\\'" . prolog-mode)
......@@ -1344,15 +1442,21 @@ in that case, this function acts as if `enable-local-variables' were t."
;; _emacs following a directory delimiter
;; in MsDos syntax
("[:/]_emacs\\'" . emacs-lisp-mode)
("/crontab\\.X*[0-9]+\\'" . shell-script-mode)
("\\.ml\\'" . lisp-mode)
("\\.asn$" . snmp-mode)
("\\.mib$" . snmp-mode)
("\\.smi$" . snmp-mode)
("\\.as2$" . snmpv2-mode)
("\\.mi2$" . snmpv2-mode)
("\\.sm2$" . snmpv2-mode))
"\
Alist of filename patterns vs corresponding major mode functions.
("\\.sm2$" . snmpv2-mode)
("\\.\\(diffs?\\|patch\\|rej\\)\\'" . diff-mode)
("\\.[eE]?[pP][sS]$" . ps-mode)
("configure\\.in\\'" . autoconf-mode)
("BROWSE\\'" . ebrowse-tree-mode)
("\\.ebrowse\\'" . ebrowse-tree-mode)
("#\\*mail\\*" . mail-mode)))
"Alist of filename patterns vs corresponding major mode functions.
Each element looks like (REGEXP . FUNCTION) or (REGEXP FUNCTION NON-NIL).
\(NON-NIL stands for anything that is not nil; the value does not matter.)
Visiting a file whose name matches REGEXP specifies FUNCTION as the
......@@ -1364,6 +1468,9 @@ REGEXP and search the list again for another match.")
(defvar interpreter-mode-alist
(mapc
(lambda (l)
(cons (purecopy (car l)) (cdr l)))
'(("perl" . perl-mode)
("perl5" . perl-mode)
("miniperl" . perl-mode)
......@@ -1398,7 +1505,10 @@ REGEXP and search the list again for another match.")
("tail" . text-mode)
("more" . text-mode)
("less" . text-mode)
("pg" . text-mode))
("pg" . text-mode)
("make" . makefile-mode) ; Debian uses this
("guile" . scheme-mode)
("clisp" . lisp-mode)))
"Alist mapping interpreter names to major modes.
This alist applies to files whose first line starts with `#!'.
Each element looks like (INTERPRETER . MODE).
......@@ -1414,8 +1524,16 @@ If it matches, mode MODE is selected.")
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 nil
"File name, including directory, of user's initialization file.")
(defvar auto-mode-interpreter-regexp
"#![ \t]?\\([^ \t\n]*\
/bin/env[ \t]\\)?\\([^ \t\n]+\\)"
"Regular expression matching interpreters, for file mode determination.
This regular expression is matched against the first line of a file
to determine the file's mode in `set-auto-mode' when Emacs can't deduce
a mode from the file's name. If it matches, the file is assumed to
be interpreted by the interpreter matched by the second group of the
regular expression. The mode is then determined as the mode associated
with that interpreter in `interpreter-mode-alist'.")
(defun set-auto-mode (&optional just-from-file-name)
"Select major mode appropriate for current buffer.
......@@ -1498,7 +1616,7 @@ and we don't even do that unless it would come from the file name."
;; outside the save-excursion.
(when modes
(unless just-from-file-name
(mapcar 'funcall (nreverse modes)))
(mapc 'funcall (nreverse modes)))
(setq done t))
;; If we didn't find a mode from a -*- line, try using the file name.
(if (and (not done) buffer-file-name)
......@@ -1517,10 +1635,9 @@ and we don't even do that unless it would come from the file name."
(if (string-match (car (car alist)) name)
(if (and (consp (cdr (car alist)))
(nth 2 (car alist)))
(progn
(setq mode (car (cdr (car alist)))
name (substring name 0 (match-beginning 0))
keep-going t))
keep-going t)
(setq mode (cdr (car alist))
keep-going nil)))
(setq alist (cdr alist))))
......@@ -1539,9 +1656,8 @@ and we don't even do that unless it would come from the file name."
(let ((interpreter
(save-excursion
(goto-char (point-min))
(if (looking-at "#![ \t]?\\([^ \t\n]*/bin/env[ \t]\\)?\\([^ \t\n]+\\)")
(buffer-substring (match-beginning 2)
(match-end 2))
(if (looking-at auto-mode-interpreter-regexp)
(match-string 2)
"")))
elt)
;; Map interpreter name to a mode.
......@@ -1552,10 +1668,10 @@ and we don't even do that unless it would come from the file name."
(funcall (cdr elt))))))))))))
(defun hack-local-variables-prop-line ()
;; Set local variables specified in the -*- line.
;; Ignore any specification for `mode:' and `coding:';
;; set-auto-mode should already have handled `mode:',
;; set-auto-coding should already have handled `coding:'.
"Set local variables specified in the -*- line.
Ignore any specification for `mode:' and `coding:';
`set-auto-mode' should already have handled `mode:',
`set-auto-coding' should already have handled `coding:'."
(save-excursion
(goto-char (point-min))
(let ((result nil)
......@@ -1578,7 +1694,7 @@ and we don't even do that unless it would come from the file name."
(error "-*- not terminated before end of line")))
(while (< (point) end)
(or (looking-at "[ \t]*\\([^ \t\n:]+\\)[ \t]*:[ \t]*")
(error "malformed -*- line"))
(error "Malformed -*- line"))
(goto-char (match-end 0))
;; There used to be a downcase here,
;; but the manual didn't say so,
......@@ -1743,9 +1859,9 @@ is specified, returning t if it is specified."
(defun hack-one-local-variable-quotep (exp)
(and (consp exp) (eq (car exp) 'quote) (consp (cdr exp))))
;; "Set" one variable in a local variables spec.
;; A few variable names are treated specially.
(defun hack-one-local-variable (var val)
"\"Set\" one variable in a local variables spec.
A few variable names are treated specially."
(cond ((eq var 'mode)
(funcall (intern (concat (downcase (symbol-name val))
"-mode"))))
......@@ -2003,10 +2119,15 @@ no longer accessible under its old name."
backup-by-copying
(and backup-by-copying-when-linked
(> (file-nlinks real-file-name) 1))
(and backup-by-copying-when-mismatch
(and (or backup-by-copying-when-mismatch
(integerp backup-by-copying-when-privileged-mismatch))
(let ((attr (file-attributes real-file-name)))
(and (or backup-by-copying-when-mismatch
(and (integerp (nth 2 attr))
(integerp backup-by-copying-when-privileged-mismatch)
(<= (nth 2 attr) backup-by-copying-when-privileged-mismatch)))
(or (nth 9 attr)
(not (file-ownership-preserved-p real-file-name))))))
(not (file-ownership-preserved-p real-file-name)))))))
(condition-case ()
(copy-file real-file-name backupname t t)
(file-error
......@@ -2048,7 +2169,7 @@ no longer accessible under its old name."
(file-error nil))))))
(defun file-name-sans-versions (name &optional keep-backup-version)
"Return FILENAME sans backup versions or strings.
"Return file NAME sans backup versions or strings.
This is a separate procedure so your site-init or startup file can
redefine it.
If the optional argument KEEP-BACKUP-VERSION is non-nil,
......@@ -2075,7 +2196,7 @@ we do not remove backup version numbers, only true file version numbers."
(length name))))))))
(defun file-ownership-preserved-p (file)
"Returns t if deleting FILE and rewriting it would preserve the owner."
"Return t if deleting FILE and rewriting it would preserve the owner."
(let ((handler (find-file-name-handler file 'file-ownership-preserved-p)))
(if handler
(funcall handler 'file-ownership-preserved-p file)
......@@ -2114,19 +2235,117 @@ the value is \"\"."
(if period
"")))))
(defcustom make-backup-file-name-function nil
"A function to use instead of the default `make-backup-file-name'.
A value of nil gives the default `make-backup-file-name' behaviour.
This could be buffer-local to do something special for for specific
files. If you define it, you may need to change `backup-file-name-p'
and `file-name-sans-versions' too.
See also `backup-directory-alist'."
:group 'backup
:type '(choice (const :tag "Default" nil)
(function :tag "Your function")))
(defcustom backup-directory-alist nil
"Alist of filename patterns and backup directory names.
Each element looks like (REGEXP . DIRECTORY). Backups of files with
names matching REGEXP will be made in DIRECTORY. DIRECTORY may be
relative or absolute. If it is absolute, so that all matching files
are backed up into the same directory, the file names in this
directory will be the full name of the file backed up with all
directory separators changed to `!' to prevent clashes. This will not
work correctly if your filesystem truncates the resulting name.
For the common case of all backups going into one directory, the alist
should contain a single element pairing \".\" with the appropriate
directory name.
If this variable is nil, or it fails to match a filename, the backup
is made in the original file's directory.
On MS-DOS filesystems without long names this variable is always
ignored."
:group 'backup
:type '(repeat (cons (regexp :tag "Regexp macthing filename")
(directory :tag "Backup directory name"))))
(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."
Normally this will just be the file's name with `~' appended.
Customization hooks are provided as follows.
If the variable `make-backup-file-name-function' is non-nil, its value
should be a function which will be called with FILE as its argument;
the resulting name is used.
Otherwise a match for FILE is sought in `backup-directory-alist'; see
the documentation of that variable. If the directory for the backup
doesn't exist, it is created."
(if make-backup-file-name-function
(funcall make-backup-file-name-function file)
(if (and (eq system-type 'ms-dos)
(not (msdos-long-file-names)))
(let ((fn (file-name-nondirectory file)))
(concat (file-name-directory file)
(or
(and (string-match "\\`[^.]+\\'" fn)
(or (and (string-match "\\`[^.]+\\'" fn)
(concat (match-string 0 fn) ".~"))
(and (string-match "\\`[^.]+\\.\\(..?\\)?" fn)
(concat (match-string 0 fn) "~")))))
(concat file "~")))
(concat (make-backup-file-name-1 file) "~"))))
(defun make-backup-file-name-1 (file)
"Subroutine of `make-backup-file-name' and `find-backup-file-name'."
(let ((alist backup-directory-alist)
elt backup-directory dir-sep-string)
(while alist
(setq elt (pop alist))
(if (string-match (car elt) file)
(setq backup-directory (cdr elt)
alist nil)))
(if (null backup-directory)
file
(unless (file-exists-p backup-directory)
(condition-case nil
(make-directory backup-directory 'parents)
(file-error file)))
(if (file-name-absolute-p backup-directory)
(progn
(when (memq system-type '(windows-nt ms-dos))
;; Normalize DOSish file names: convert all slashes to
;; directory-sep-char, downcase the drive letter, if any,
;; and replace the leading "x:" with "/drive_x".
(or (file-name-absolute-p file)
(setq file (expand-file-name file))) ; make defaults explicit
;; Replace any invalid file-name characters (for the
;; case of backing up remote files).
(setq file (convert-standard-filename file))
(setq dir-sep-string (char-to-string directory-sep-char))
(or (eq directory-sep-char ?/)
(subst-char-in-string ?/ ?\\ file))
(or (eq directory-sep-char ?\\)
(subst-char-in-string ?\\ ?/ file))
(if (eq (aref file 1) ?:)
(setq file (concat dir-sep-string
"drive_"
(char-to-string (downcase (aref file 0)))
(if (eq (aref file 2) directory-sep-char)
""
dir-sep-string)
(substring file 2)))))
;; Make the name unique by substituting directory
;; separators. It may not really be worth bothering about
;; doubling `!'s in the original name...
(expand-file-name
(subst-char-in-string
directory-sep-char ?!
(replace-regexp-in-string "!" "!!" file))
backup-directory))
(expand-file-name (file-name-nondirectory file)
(file-name-as-directory
(expand-file-name backup-directory
(file-name-directory file))))))))