comparison lisp/prim/files.el @ 70:131b0175ea99 r20-0b30

Import from CVS: tag r20-0b30
author cvs
date Mon, 13 Aug 2007 09:02:59 +0200
parents 56c54cf7c5b6
children b9518feda344
comparison
equal deleted inserted replaced
69:804d1389bcd6 70:131b0175ea99
14 ;; WITHOUT ANY WARRANTY; without even the implied warranty of 14 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
16 ;; General Public License for more details. 16 ;; General Public License for more details.
17 17
18 ;; You should have received a copy of the GNU General Public License 18 ;; You should have received a copy of the GNU General Public License
19 ;; along with XEmacs; see the file COPYING. If not, write to the Free 19 ;; along with XEmacs; see the file COPYING. If not, write to the
20 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 20 ;; Free Software Foundation, 59 Temple Place - Suite 330,
21 ;; 02111-1307, USA. 21 ;; Boston, MA 02111-1307, USA.
22 22
23 ;;; Synched up with: FSF 19.34 [Partial]. 23 ;;; Synched up with: FSF 19.30.
24 ;;; Warning: Merging this file is tough. Beware. 24 ;;; Warning: Merging this file is tough. Beware.
25 25
26 ;;; Commentary: 26 ;;; Commentary:
27 27
28 ;; Defines most of XEmacs's file- and directory-handling functions, 28 ;; Defines most of XEmacs's file- and directory-handling functions,
29 ;; including basic file visiting, backup generation, link handling, 29 ;; including basic file visiting, backup generation, link handling,
30 ;; ITS-id version control, load- and write-hook handling, and the like. 30 ;; ITS-id version control, load- and write-hook handling, and the like.
31 31
32 ;;; Code: 32 ;;; Code:
33 33
34 ;; XEmacs: Avoid compilation warnings. 34 ;; Avoid compilation warnings.
35 (defvar overriding-file-coding-system) 35 (defvar overriding-file-coding-system)
36 (defvar file-coding-system) 36 (defvar file-coding-system)
37 37
38 ;; XEmacs: In buffer.c 38 ;; In buffer.c
39 ;(defconst delete-auto-save-files t 39 ;(defconst delete-auto-save-files t
40 ; "*Non-nil means delete auto-save file when a buffer is saved or killed.") 40 ; "*Non-nil means delete auto-save file when a buffer is saved or killed.")
41
42 ;; FSF has automount-dir-prefix. Our directory-abbrev-alist is more general.
43 ;; note: tmp_mnt bogosity conversion is established in paths.el.
44 (defvar directory-abbrev-alist nil
45 "*Alist of abbreviations for file directories.
46 A list of elements of the form (FROM . TO), each meaning to replace
47 FROM with TO when it appears in a directory name.
48 This replacement is done when setting up the default directory of a
49 newly visited file. *Every* FROM string should start with \\\\` or ^.
50
51 Use this feature when you have directories which you normally refer to
52 via absolute symbolic links or to eliminate automounter mount points
53 from the beginning of your filenames. Make TO the name of the link,
54 and FROM the name it is linked to.")
55 41
56 ;;; Turn off backup files on VMS since it has version numbers. 42 ;;; Turn off backup files on VMS since it has version numbers.
57 (defconst make-backup-files (not (eq system-type 'vax-vms)) 43 (defconst make-backup-files (not (eq system-type 'vax-vms))
58 "*Non-nil means make a backup of a file the first time it is saved. 44 "*Non-nil means make a backup of a file the first time it is saved.
59 This can be done by renaming the file or by copying. 45 This can be done by renaming the file or by copying.
108 "*Non-nil in a buffer means offer to save the buffer on exit 94 "*Non-nil in a buffer means offer to save the buffer on exit
109 even if the buffer is not visiting a file. 95 even if the buffer is not visiting a file.
110 Automatically local in all buffers.") 96 Automatically local in all buffers.")
111 (make-variable-buffer-local 'buffer-offer-save) 97 (make-variable-buffer-local 'buffer-offer-save)
112 98
113 ;; FSF uses normal defconst
114 (defvaralias 'find-file-visit-truename 'find-file-use-truenames) 99 (defvaralias 'find-file-visit-truename 'find-file-use-truenames)
115 (defvaralias 'find-file-existing-other-name 'find-file-compare-truenames) 100 (defvaralias 'find-file-existing-other-name 'find-file-compare-truenames)
116 101
117 (defvar buffer-file-number nil 102 (defvar buffer-file-number nil
118 "The device number and file number of the file visited in the current buffer. 103 "The device number and file number of the file visited in the current buffer.
120 This pair of numbers uniquely identifies the file. 105 This pair of numbers uniquely identifies the file.
121 If the buffer is visiting a new file, the value is nil.") 106 If the buffer is visiting a new file, the value is nil.")
122 (make-variable-buffer-local 'buffer-file-number) 107 (make-variable-buffer-local 'buffer-file-number)
123 (put 'buffer-file-number 'permanent-local t) 108 (put 'buffer-file-number 'permanent-local t)
124 109
125 (defvar buffer-file-numbers-unique (not (memq system-type '(windows-nt)))
126 "Non-nil means that buffer-file-number uniquely identifies files.")
127
128 (defconst file-precious-flag nil 110 (defconst file-precious-flag nil
129 "*Non-nil means protect against I/O errors while saving files. 111 "*Non-nil means protect against I/O errors while saving files.
130 Some modes set this non-nil in particular buffers. 112 Some modes set this non-nil in particular buffers.
131 113
132 This feature works by writing the new contents into a temporary file 114 This feature works by writing the new contents into a temporary file
142 "*Control use of version numbers for backup files. 124 "*Control use of version numbers for backup files.
143 t means make numeric backup versions unconditionally. 125 t means make numeric backup versions unconditionally.
144 nil means make them for files that have some already. 126 nil means make them for files that have some already.
145 `never' means do not make them.") 127 `never' means do not make them.")
146 128
147 ;; This is now defined in efs. 129 (defvar dired-kept-versions 2
148 ;(defvar dired-kept-versions 2 130 "*When cleaning directory, number of versions to keep.")
149 ; "*When cleaning directory, number of versions to keep.")
150 131
151 (defvar delete-old-versions nil 132 (defvar delete-old-versions nil
152 "*If t, delete excess backup versions silently. 133 "*If t, delete excess backup versions silently.
153 If nil, ask confirmation. Any other value prevents any trimming.") 134 If nil, ask confirmation. Any other value prevents any trimming.")
154 135
197 "List of functions to be called before writing out a buffer to a file. 178 "List of functions to be called before writing out a buffer to a file.
198 If one of them returns non-nil, the file is considered already written 179 If one of them returns non-nil, the file is considered already written
199 and the rest are not called. 180 and the rest are not called.
200 These hooks are considered to pertain to the visited file. 181 These hooks are considered to pertain to the visited file.
201 So this list is cleared if you change the visited file name. 182 So this list is cleared if you change the visited file name.
202 183 See also `write-contents-hooks' and `continue-save-buffer'.
203 Don't make this variable buffer-local; instead, use `local-write-file-hooks'. 184 Don't make this variable buffer-local; instead, use `local-write-file-hooks'.")
204 See also `write-contents-hooks' and `continue-save-buffer'.")
205 ;;; However, in case someone does make it local... 185 ;;; However, in case someone does make it local...
206 (put 'write-file-hooks 'permanent-local t) 186 (put 'write-file-hooks 'permanent-local t)
207 187
208 (defvar local-write-file-hooks nil 188 (defvar local-write-file-hooks nil
209 "Just like `write-file-hooks', except intended for per-buffer use. 189 "Just like `write-file-hooks', except intended for per-buffer use.
210 The functions in this list are called before the ones in 190 The functions in this list are called before the ones in
211 `write-file-hooks'. 191 `write-file-hooks'.")
212
213 This variable is meant to be used for hooks that have to do with a
214 particular visited file. Therefore, it is a permanent local, so that
215 changing the major mode does not clear it. However, calling
216 `set-visited-file-name' does clear it.")
217 (make-variable-buffer-local 'local-write-file-hooks) 192 (make-variable-buffer-local 'local-write-file-hooks)
218 (put 'local-write-file-hooks 'permanent-local t) 193 (put 'local-write-file-hooks 'permanent-local t)
219 194
220 195
221 ;; XEmacs: #### think about this (added by Sun). 196 ;; #### think about this (added by Sun).
222 (put 'after-set-visited-file-name-hooks 'permanent-local t) 197 (put 'after-set-visited-file-name-hooks 'permanent-local t)
223 (defvar after-set-visited-file-name-hooks nil 198 (defvar after-set-visited-file-name-hooks nil
224 "List of functions to be called after \\[set-visited-file-name] 199 "List of functions to be called after \\[set-visited-file-name]
225 or during \\[write-file]. 200 or during \\[write-file].
226 You can use this hook to restore local values of write-file-hooks, 201 You can use this hook to restore local values of write-file-hooks,
235 and the rest are not called. 210 and the rest are not called.
236 These hooks are considered to pertain to the buffer's contents, 211 These hooks are considered to pertain to the buffer's contents,
237 not to the particular visited file; thus, `set-visited-file-name' does 212 not to the particular visited file; thus, `set-visited-file-name' does
238 not clear this variable, but changing the major mode does clear it. 213 not clear this variable, but changing the major mode does clear it.
239 See also `write-file-hooks' and `continue-save-buffer'.") 214 See also `write-file-hooks' and `continue-save-buffer'.")
240 ;(make-variable-buffer-local 'write-contents-hooks) 215
241 216 ;; Not in FSF19
242 ;; XEmacs addition
243 ;; Energize needed this to hook into save-buffer at a lower level; we need 217 ;; Energize needed this to hook into save-buffer at a lower level; we need
244 ;; to provide a new output method, but don't want to have to duplicate all 218 ;; to provide a new output method, but don't want to have to duplicate all
245 ;; of the backup file and file modes logic.that does not occur if one uses 219 ;; of the backup file and file modes logic.that does not occur if one uses
246 ;; a write-file-hook which returns non-nil. 220 ;; a write-file-hook which returns non-nil.
247 (put 'write-file-data-hooks 'permanent-local t) 221 (put 'write-file-data-hooks 'permanent-local t)
271 A value of t means obey `eval' variables; 245 A value of t means obey `eval' variables;
272 nil means ignore them; anything else means query. 246 nil means ignore them; anything else means query.
273 247
274 The command \\[normal-mode] always obeys local-variables lists 248 The command \\[normal-mode] always obeys local-variables lists
275 and ignores this variable.") 249 and ignores this variable.")
250
251 (defvar hack-local-variables-hook nil
252 "Normal hook run after processing a file's local variables specs.
253 Major modes can use this to examine user-specified local variables
254 in order to initialize other data structure based on them.
255
256 This hook runs even if there were no local variables or if their
257 evaluation was suppressed. See also `enable-local-variables' and
258 `enable-local-eval'.")
276 259
277 ;; Avoid losing in versions where CLASH_DETECTION is disabled. 260 ;; Avoid losing in versions where CLASH_DETECTION is disabled.
278 (or (fboundp 'lock-buffer) 261 (or (fboundp 'lock-buffer)
279 (defalias 'lock-buffer 'ignore)) 262 (defalias 'lock-buffer 'ignore))
280 (or (fboundp 'unlock-buffer) 263 (or (fboundp 'unlock-buffer)
315 "Character used to separate concatenated paths.") 298 "Character used to separate concatenated paths.")
316 299
317 (defun parse-colon-path (cd-path) 300 (defun parse-colon-path (cd-path)
318 "Explode a colon-separated list of paths into a string list." 301 "Explode a colon-separated list of paths into a string list."
319 (and cd-path 302 (and cd-path
320 (let (cd-prefix cd-list (cd-start 0) cd-colon) 303 (let (cd-list (cd-start 0) cd-colon)
321 (setq cd-path (concat cd-path path-separator)) 304 (setq cd-path (concat cd-path path-separator))
322 (while (setq cd-colon (string-match path-separator cd-path cd-start)) 305 (while (setq cd-colon (string-match path-separator cd-path cd-start))
323 (setq cd-list 306 (setq cd-list
324 (nconc cd-list 307 (nconc cd-list
325 (list (if (= cd-start cd-colon) 308 (list (if (= cd-start cd-colon)
350 333
351 (defun cd (dir) 334 (defun cd (dir)
352 "Make DIR become the current buffer's default directory. 335 "Make DIR become the current buffer's default directory.
353 If your environment includes a `CDPATH' variable, try each one of that 336 If your environment includes a `CDPATH' variable, try each one of that
354 colon-separated list of directories when resolving a relative directory name." 337 colon-separated list of directories when resolving a relative directory name."
338 ; (interactive "DChange default directory: ")
355 (interactive 339 (interactive
356 ;; XEmacs change? (read-file-name => read-directory-name) 340 ;; XEmacs change?
357 (list (read-directory-name "Change default directory: " 341 (list (read-directory-name "Change default directory: "
358 default-directory default-directory 342 default-directory default-directory
359 (and (member cd-path '(nil ("./"))) 343 (and (member cd-path '(nil ("./")))
360 (null (getenv "CDPATH")))))) 344 (null (getenv "CDPATH"))))))
361 (if (file-name-absolute-p dir) 345 (if (file-name-absolute-p dir)
362 (cd-absolute (expand-file-name dir)) 346 (cd-absolute (expand-file-name dir))
363 ;; XEmacs 347 (progn
364 (if (null cd-path) 348 (if (null cd-path)
365 ;;#### Unix-specific 349 ;;#### Unix-specific
366 (let ((trypath (parse-colon-path (getenv "CDPATH")))) 350 (let ((trypath (parse-colon-path (getenv "CDPATH"))))
367 (setq cd-path (or trypath (list "./"))))) 351 (setq cd-path (or trypath (list "./")))))
368 (or (catch 'found 352 (or (catch 'found
369 (mapcar #'(lambda (x) 353 (mapcar #'(lambda (x)
370 (let ((f (expand-file-name (concat x dir)))) 354 (let ((f (expand-file-name (concat x dir))))
371 (if (file-directory-p f) 355 (if (file-directory-p f)
372 (progn 356 (progn
373 (cd-absolute f) 357 (cd-absolute f)
374 (throw 'found t))))) 358 (throw 'found t)))))
376 nil) 360 nil)
377 ;; jwz: give a better error message to those of us with the 361 ;; jwz: give a better error message to those of us with the
378 ;; good taste not to use a kludge like $CDPATH. 362 ;; good taste not to use a kludge like $CDPATH.
379 (if (equal cd-path '("./")) 363 (if (equal cd-path '("./"))
380 (error "No such directory: %s" (expand-file-name dir)) 364 (error "No such directory: %s" (expand-file-name dir))
381 (error "Directory not found in $CDPATH: %s" dir))))) 365 (error "Directory not found in $CDPATH: %s" dir))))))
382 366
383 (defun load-file (file) 367 (defun load-file (file)
384 "Load the Lisp file named FILE." 368 "Load the Lisp file named FILE."
385 (interactive "fLoad file: ") 369 (interactive "fLoad file: ")
386 (load (expand-file-name file) nil nil t)) 370 (load (expand-file-name file) nil nil t))
387 371
388 ; We now dump utils/lib-complete.el which has an improved version of this. 372 ; We now dump utils/lib-complete.el which has improved versions of these.
389 ;(defun load-library (library) 373 ;(defun load-library (library)
390 ; "Load the library named LIBRARY. 374 ; "Load the library named LIBRARY.
391 ;This is an interface to the function `load'." 375 ;This is an interface to the function `load'."
392 ; (interactive "sLoad library: ") 376 ; (interactive "sLoad library: ")
393 ; (load library)) 377 ; (load library))
378 ;
379 ;(defun find-library (library)
380 ; "Find the library of Lisp code named LIBRARY.
381 ;This searches `load-path' for a file named either \"LIBRARY\" or \"LIBRARY.el\"."
382 ; (interactive "sFind library file: ")
383 ; (let ((f (locate-file library load-path ":.el:")))
384 ; (if f
385 ; (find-file f)
386 ; (error "Couldn't locate library %s" library))))
394 387
395 (defun file-local-copy (file &optional buffer) 388 (defun file-local-copy (file &optional buffer)
396 "Copy the file FILE into a temporary file on this machine. 389 "Copy the file FILE into a temporary file on this machine.
397 Returns the name of the local copy, or nil, if FILE is directly 390 Returns the name of the local copy, or nil, if FILE is directly
398 accessible." 391 accessible."
399 (let ((handler (find-file-name-handler file 'file-local-copy))) 392 (let ((handler (find-file-name-handler file 'file-local-copy)))
400 (if handler 393 (if handler
401 (funcall handler 'file-local-copy file) 394 (funcall handler 'file-local-copy file)
402 nil))) 395 nil)))
403 396
404 ;; XEmacs change block
405 ; We have this in C and use the realpath() system call. 397 ; We have this in C and use the realpath() system call.
406 398
407 ;(defun file-truename (filename &optional counter prev-dirs) 399 ;(defun file-truename (filename &optional counter prev-dirs)
408 ; "Return the truename of FILENAME, which should be absolute. 400 ; "Return the truename of FILENAME, which should be absolute.
409 ;The truename of a file name is found by chasing symbolic links 401 ;The truename of a file name is found by chasing symbolic links
509 dir))))) 501 dir)))))
510 (if (and find-file-use-truenames buffer-file-truename) 502 (if (and find-file-use-truenames buffer-file-truename)
511 (setq buffer-file-name (abbreviate-file-name buffer-file-truename) 503 (setq buffer-file-name (abbreviate-file-name buffer-file-truename)
512 default-directory (file-name-directory buffer-file-name))) 504 default-directory (file-name-directory buffer-file-name)))
513 buffer-file-truename)) 505 buffer-file-truename))
514 ;; End XEmacs change block
515 506
516 (defun file-chase-links (filename) 507 (defun file-chase-links (filename)
517 "Chase links in FILENAME until a name that is not a link. 508 "Chase links in FILENAME until a name that is not a link.
518 Does not examine containing directories for links, 509 Does not examine containing directories for links,
519 unlike `file-truename'." 510 unlike `file-truename'."
566 (pop-to-buffer buffer t (selected-frame)))) 557 (pop-to-buffer buffer t (selected-frame))))
567 558
568 (defun switch-to-buffer-other-frame (buffer) 559 (defun switch-to-buffer-other-frame (buffer)
569 "Switch to buffer BUFFER in a newly-created frame." 560 "Switch to buffer BUFFER in a newly-created frame."
570 (interactive "BSwitch to buffer in other frame: ") 561 (interactive "BSwitch to buffer in other frame: ")
571 ;; XEmacs guarantees a new frame
572 (let* ((name (get-frame-name-for-buffer buffer)) 562 (let* ((name (get-frame-name-for-buffer buffer))
573 (frame (make-frame (if name 563 (frame (make-frame (if name
574 (list (cons 'name (symbol-name name))))))) 564 (list (cons 'name (symbol-name name)))))))
575 (pop-to-buffer buffer t frame) 565 (pop-to-buffer buffer t frame)
576 (make-frame-visible frame) 566 (make-frame-visible frame)
577 buffer)) 567 buffer))
578 568
579 (defun find-file (filename) 569 (defun find-file (filename &optional codesys)
580 "Edit file FILENAME. 570 "Edit file FILENAME.
581 Switch to a buffer visiting file FILENAME, 571 Switch to a buffer visiting file FILENAME,
582 creating one if none already exists." 572 creating one if none already exists.
583 (interactive "FFind file: ") 573 Under XEmacs/Mule, optional second argument specifies the
584 (switch-to-buffer (find-file-noselect filename))) 574 coding system to use when decoding the file. Interactively,
585 575 with a prefix argument, you will be prompted for the coding system."
586 (defun find-file-other-window (filename) 576 (interactive "FFind file: \nZCoding system: ")
577 (if codesys
578 (let ((overriding-file-coding-system
579 (get-coding-system codesys)))
580 (switch-to-buffer (find-file-noselect filename)))
581 (switch-to-buffer (find-file-noselect filename))))
582
583 (defun find-file-other-window (filename &optional codesys)
587 "Edit file FILENAME, in another window. 584 "Edit file FILENAME, in another window.
588 May create a new window, or reuse an existing one. 585 May create a new window, or reuse an existing one.
589 See the function `display-buffer'." 586 See the function `display-buffer'.
590 (interactive "FFind file in other window: ") 587 Under XEmacs/Mule, optional second argument specifies the
591 (switch-to-buffer-other-window (find-file-noselect filename))) 588 coding system to use when decoding the file. Interactively,
592 589 with a prefix argument, you will be prompted for the coding system."
593 (defun find-file-other-frame (filename) 590 (interactive "FFind file in other window: \nZCoding system: ")
591 (if codesys
592 (let ((overriding-file-coding-system
593 (get-coding-system codesys)))
594 (switch-to-buffer-other-window (find-file-noselect filename)))
595 (switch-to-buffer-other-window (find-file-noselect filename))))
596
597 (defun find-file-other-frame (filename &optional codesys)
594 "Edit file FILENAME, in a newly-created frame. 598 "Edit file FILENAME, in a newly-created frame.
595 This function will create a new frame. 599 Under XEmacs/Mule, optional second argument specifies the
596 See the function `display-buffer'." 600 coding system to use when decoding the file. Interactively,
597 (interactive "FFind file in other frame: ") 601 with a prefix argument, you will be prompted for the coding system."
598 (switch-to-buffer-other-frame (find-file-noselect filename))) 602 (interactive "FFind file in other frame: \nZCoding system: ")
599 603 (if codesys
600 (defun find-file-read-only (filename) 604 (let ((overriding-file-coding-system
605 (get-coding-system codesys)))
606 (switch-to-buffer-other-frame (find-file-noselect filename)))
607 (switch-to-buffer-other-frame (find-file-noselect filename))))
608
609 (defun find-file-read-only (filename &optional codesys)
601 "Edit file FILENAME but don't allow changes. 610 "Edit file FILENAME but don't allow changes.
602 Like \\[find-file] but marks buffer as read-only. 611 Like \\[find-file] but marks buffer as read-only.
603 Use \\[toggle-read-only] to permit editing." 612 Use \\[toggle-read-only] to permit editing.
604 (interactive "fFind file read-only: ") 613 Under XEmacs/Mule, optional second argument specifies the
605 (find-file filename) 614 coding system to use when decoding the file. Interactively,
615 with a prefix argument, you will be prompted for the coding system."
616 (interactive "fFind file read-only: \nZCoding system: ")
617 (if codesys
618 (let ((overriding-file-coding-system
619 (get-coding-system codesys)))
620 (find-file filename))
621 (find-file filename))
606 (setq buffer-read-only t) 622 (setq buffer-read-only t)
607 (current-buffer)) 623 (current-buffer))
608 624
609 (defun find-file-read-only-other-window (filename) 625 (defun find-file-read-only-other-window (filename &optional codesys)
610 "Edit file FILENAME in another window but don't allow changes. 626 "Edit file FILENAME in another window but don't allow changes.
611 Like \\[find-file-other-window] but marks buffer as read-only. 627 Like \\[find-file-other-window] but marks buffer as read-only.
612 Use \\[toggle-read-only] to permit editing." 628 Use \\[toggle-read-only] to permit editing.
613 (interactive "fFind file read-only other window: ") 629 Under XEmacs/Mule, optional second argument specifies the
614 (find-file-other-window filename) 630 coding system to use when decoding the file. Interactively,
631 with a prefix argument, you will be prompted for the coding system."
632 (interactive "fFind file read-only other window: \nZCoding system: ")
633 (if codesys
634 (let ((overriding-file-coding-system
635 (get-coding-system codesys)))
636 (find-file-other-window filename))
637 (find-file-other-window filename))
615 (setq buffer-read-only t) 638 (setq buffer-read-only t)
616 (current-buffer)) 639 (current-buffer))
617 640
618 (defun find-file-read-only-other-frame (filename) 641 (defun find-file-read-only-other-frame (filename &optional codesys)
619 "Edit file FILENAME in another frame but don't allow changes. 642 "Edit file FILENAME in another frame but don't allow changes.
620 Like \\[find-file-other-frame] but marks buffer as read-only. 643 Like \\[find-file-other-frame] but marks buffer as read-only.
621 Use \\[toggle-read-only] to permit editing." 644 Use \\[toggle-read-only] to permit editing.
622 (interactive "fFind file read-only other frame: ") 645 Under XEmacs/Mule, optional second argument specifies the
623 (find-file-other-frame filename) 646 coding system to use when decoding the file. Interactively,
647 with a prefix argument, you will be prompted for the coding system."
648 (interactive "fFind file read-only other frame: \nZCoding system: ")
649 (if codesys
650 (let ((overriding-file-coding-system
651 (get-coding-system codesys)))
652 (find-file-other-frame filename))
653 (find-file-other-frame filename))
624 (setq buffer-read-only t) 654 (setq buffer-read-only t)
625 (current-buffer)) 655 (current-buffer))
626 656
627 (defun find-alternate-file-other-window (filename) 657 (defun find-alternate-file-other-window (filename &optional codesys)
628 "Find file FILENAME as a replacement for the file in the next window. 658 "Find file FILENAME as a replacement for the file in the next window.
629 This command does not select that window." 659 This command does not select that window.
660 Under XEmacs/Mule, optional second argument specifies the
661 coding system to use when decoding the file. Interactively,
662 with a prefix argument, you will be prompted for the coding system."
630 (interactive 663 (interactive
631 (save-selected-window 664 (save-selected-window
632 (other-window 1) 665 (other-window 1)
633 (let ((file buffer-file-name) 666 (let ((file buffer-file-name)
634 (file-name nil) 667 (file-name nil)
635 (file-dir nil)) 668 (file-dir nil))
636 (and file 669 (and file
637 (setq file-name (file-name-nondirectory file) 670 (setq file-name (file-name-nondirectory file)
638 file-dir (file-name-directory file))) 671 file-dir (file-name-directory file)))
639 (list (read-file-name 672 (list (read-file-name
640 "Find alternate file: " file-dir nil nil file-name))))) 673 "Find alternate file: " file-dir nil nil file-name)
674 (if (and current-prefix-arg (featurep 'mule))
675 (read-coding-system "Coding-system: "))))))
641 (if (one-window-p) 676 (if (one-window-p)
642 (find-file-other-window filename) 677 (find-file-other-window filename)
643 (save-selected-window 678 (save-selected-window
644 (other-window 1) 679 (other-window 1)
645 (find-alternate-file filename)))) 680 (find-alternate-file filename codesys))))
646 681
647 (defun find-alternate-file (filename) 682 (defun find-alternate-file (filename &optional codesys)
648 "Find file FILENAME, select its buffer, kill previous buffer. 683 "Find file FILENAME, select its buffer, kill previous buffer.
649 If the current buffer now contains an empty file that you just visited 684 If the current buffer now contains an empty file that you just visited
650 \(presumably by mistake), use this command to visit the file you really want." 685 \(presumably by mistake), use this command to visit the file you really want.
686 Under XEmacs/Mule, optional second argument specifies the
687 coding system to use when decoding the file. Interactively,
688 with a prefix argument, you will be prompted for the coding system."
651 (interactive 689 (interactive
652 (let ((file buffer-file-name) 690 (let ((file buffer-file-name)
653 (file-name nil) 691 (file-name nil)
654 (file-dir nil)) 692 (file-dir nil))
655 (and file 693 (and file
656 (setq file-name (file-name-nondirectory file) 694 (setq file-name (file-name-nondirectory file)
657 file-dir (file-name-directory file))) 695 file-dir (file-name-directory file)))
658 (list (read-file-name 696 (list (read-file-name
659 "Find alternate file: " file-dir nil nil file-name)))) 697 "Find alternate file: " file-dir nil nil file-name)
698 (if (and current-prefix-arg (featurep 'mule))
699 (read-coding-system "Coding-system: ")))))
660 (and (buffer-modified-p) (buffer-file-name) 700 (and (buffer-modified-p) (buffer-file-name)
661 ;; (not buffer-read-only) 701 ;; (not buffer-read-only)
662 (not (yes-or-no-p (format "Buffer %s is modified; kill anyway? " 702 (not (yes-or-no-p (format
663 (buffer-name)))) 703 "Buffer %s is modified; kill anyway? "
704 (buffer-name))))
664 (error "Aborted")) 705 (error "Aborted"))
665 (let ((obuf (current-buffer)) 706 (let ((obuf (current-buffer))
666 (ofile buffer-file-name) 707 (ofile buffer-file-name)
667 (onum buffer-file-number) 708 (onum buffer-file-number)
668 (otrue buffer-file-truename) 709 (otrue buffer-file-truename)
669 (oname (buffer-name))) 710 (oname (buffer-name)))
670 (if (get-buffer " **lose**") 711 (if (get-buffer " **lose**")
671 (kill-buffer " **lose**")) 712 (kill-buffer " **lose**"))
672 (rename-buffer " **lose**") 713 (rename-buffer " **lose**")
714 (setq buffer-file-name nil)
715 (setq buffer-file-number nil)
716 (setq buffer-file-truename nil)
673 (unwind-protect 717 (unwind-protect
674 (progn 718 (progn
675 (unlock-buffer) 719 (unlock-buffer)
676 (setq buffer-file-name nil) 720 (if codesys
677 (setq buffer-file-number nil) 721 (let ((overriding-file-coding-system
678 (setq buffer-file-truename nil) 722 (get-coding-system codesys)))
679 (find-file filename)) 723 (find-file filename))
724 (find-file filename)))
680 (cond ((eq obuf (current-buffer)) 725 (cond ((eq obuf (current-buffer))
681 (setq buffer-file-name ofile) 726 (setq buffer-file-name ofile)
682 (setq buffer-file-number onum) 727 (setq buffer-file-number onum)
683 (setq buffer-file-truename otrue) 728 (setq buffer-file-truename otrue)
684 (lock-buffer) 729 (lock-buffer)
688 733
689 (defun create-file-buffer (filename) 734 (defun create-file-buffer (filename)
690 "Create a suitably named buffer for visiting FILENAME, and return it. 735 "Create a suitably named buffer for visiting FILENAME, and return it.
691 FILENAME (sans directory) is used unchanged if that name is free; 736 FILENAME (sans directory) is used unchanged if that name is free;
692 otherwise a string <2> or <3> or ... is appended to get an unused name." 737 otherwise a string <2> or <3> or ... is appended to get an unused name."
693 (let ((handler (find-file-name-handler filename 'create-file-buffer))) 738 (let ((lastname (file-name-nondirectory filename)))
694 (if handler 739 (if (string= lastname "")
695 (funcall handler 'create-file-buffer filename) 740 (setq lastname filename))
696 (let ((lastname (file-name-nondirectory filename))) 741 (generate-new-buffer lastname)))
697 (if (string= lastname "")
698 (setq lastname filename))
699 (generate-new-buffer lastname)))))
700 742
701 (defun generate-new-buffer (name) 743 (defun generate-new-buffer (name)
702 "Create and return a buffer with a name based on NAME. 744 "Create and return a buffer with a name based on NAME.
703 Choose the buffer's name using `generate-new-buffer-name'." 745 Choose the buffer's name using `generate-new-buffer-name'."
704 (get-buffer-create (generate-new-buffer-name name))) 746 (get-buffer-create (generate-new-buffer-name name)))
705 747
706 ;(defconst automount-dir-prefix "^/tmp_mnt/" 748 ;; FSF has automount-dir-prefix. Our directory-abbrev-alist is more general.
707 ; "Regexp to match the automounter prefix in a directory name.") 749 ;; note: tmp_mnt bogosity conversion is established in paths.el.
750 (defvar directory-abbrev-alist nil
751 "*Alist of abbreviations for file directories.
752 A list of elements of the form (FROM . TO), each meaning to replace
753 FROM with TO when it appears in a directory name.
754 This replacement is done when setting up the default directory of a
755 newly visited file. *Every* FROM string should start with \\\\` or ^.
756
757 Use this feature when you have directories which you normally refer to
758 via absolute symbolic links or to eliminate automounter mount points
759 from the beginning of your filenames. Make TO the name of the link,
760 and FROM the name it is linked to.")
708 761
709 (defvar abbreviated-home-dir nil 762 (defvar abbreviated-home-dir nil
710 "The user's homedir abbreviated according to `directory-abbrev-alist'.") 763 "The user's homedir abbreviated according to `directory-abbrev-alist'.")
711 764
712 ;; XEmacs additional parameter
713 (defun abbreviate-file-name (filename &optional hack-homedir) 765 (defun abbreviate-file-name (filename &optional hack-homedir)
714 "Return a version of FILENAME shortened using `directory-abbrev-alist'. 766 "Return a version of FILENAME shortened using `directory-abbrev-alist'.
715 See documentation of variable `directory-abbrev-alist' for more information. 767 See documentation of variable `directory-abbrev-alist' for more information.
716 If optional argument HACK-HOMEDIR is non-nil, then this also substitutes 768 If optional argument HACK-HOMEDIR is non-nil, then this also substitutes
717 \"~\" for the user's home directory." 769 \"~\" for the user's home directory."
718 (let ((handler (find-file-name-handler filename 'abbreviate-file-name))) 770 ;; Get rid of the prefixes added by the automounter.
719 (if handler 771 ;(if (and (string-match automount-dir-prefix filename)
720 (funcall handler 'abbreviate-file-name filename hack-homedir) 772 ; (file-exists-p (file-name-directory
721 ;; Get rid of the prefixes added by the automounter. 773 ; (substring filename (1- (match-end 0))))))
722 ;;(if (and (string-match automount-dir-prefix filename) 774 ; (setq filename (substring filename (1- (match-end 0)))))
723 ;; (file-exists-p (file-name-directory 775 (let ((tail directory-abbrev-alist))
724 ;; (substring filename (1- (match-end 0)))))) 776 ;; If any elt of directory-abbrev-alist matches this name,
725 ;; (setq filename (substring filename (1- (match-end 0))))) 777 ;; abbreviate accordingly.
726 (let ((tail directory-abbrev-alist)) 778 (while tail
727 ;; If any elt of directory-abbrev-alist matches this name, 779 (if (string-match (car (car tail)) filename)
728 ;; abbreviate accordingly. 780 (setq filename
729 (while tail 781 (concat (cdr (car tail)) (substring filename (match-end 0)))))
730 (if (string-match (car (car tail)) filename) 782 (setq tail (cdr tail))))
731 (setq filename 783 (if hack-homedir
732 (concat (cdr (car tail)) (substring filename (match-end 0))))) 784 (progn
733 (setq tail (cdr tail)))) 785 ;; Compute and save the abbreviated homedir name.
734 (if hack-homedir 786 ;; We defer computing this until the first time it's needed, to
735 (progn 787 ;; give time for directory-abbrev-alist to be set properly.
736 ;; Compute and save the abbreviated homedir name. 788 ;; We include a slash at the end, to avoid spurious matches
737 ;; We defer computing this until the first time it's needed, to 789 ;; such as `/usr/foobar' when the home dir is `/usr/foo'.
738 ;; give time for directory-abbrev-alist to be set properly. 790 (or abbreviated-home-dir
739 ;; We include a slash at the end, to avoid spurious matches 791 (setq abbreviated-home-dir
740 ;; such as `/usr/foobar' when the home dir is `/usr/foo'. 792 (let ((abbreviated-home-dir "$foo"))
741 (or abbreviated-home-dir 793 (concat "\\`" (regexp-quote (abbreviate-file-name
742 (setq abbreviated-home-dir 794 (expand-file-name "~")))
743 (let ((abbreviated-home-dir "$foo")) 795 "\\(/\\|\\'\\)"))))
744 (concat "\\`" (regexp-quote (abbreviate-file-name 796 ;; If FILENAME starts with the abbreviated homedir,
745 (expand-file-name "~"))) 797 ;; make it start with `~' instead.
746 "\\(/\\|\\'\\)")))) 798 (if (and (string-match abbreviated-home-dir filename)
747 ;; If FILENAME starts with the abbreviated homedir, 799 ;; If the home dir is just /, don't change it.
748 ;; make it start with `~' instead. 800 (not (and (= (match-end 0) 1) ;#### unix-specific
749 (if (and (string-match abbreviated-home-dir filename) 801 (= (aref filename 0) ?/)))
750 ;; If the home dir is just /, don't change it. 802 (not (and (or (eq system-type 'ms-dos)
751 (not (and (= (match-end 0) 1) ;#### unix-specific 803 (eq system-type 'windows-nt))
752 (= (aref filename 0) ?/))) 804 (save-match-data
753 ;; MS-DOS root directories can come with a drive letter; 805 (string-match "^[a-zA-Z]:/$" filename)))))
754 ;; Novell Netware allows drive letters beyond `Z:'. 806 (setq filename
755 (not (and (or (eq system-type 'ms-dos) 807 (concat "~"
756 (eq system-type 'windows-nt)) 808 (substring filename
757 (save-match-data 809 (match-beginning 1) (match-end 1))
758 (string-match "^[a-zA-Z-`]:/$" filename))))) 810 (substring filename (match-end 0)))))))
759 (setq filename 811 filename)
760 (concat "~"
761 (substring filename
762 (match-beginning 1) (match-end 1))
763 (substring filename (match-end 0)))))))
764 filename)))
765 812
766 (defvar find-file-not-true-dirname-list nil 813 (defvar find-file-not-true-dirname-list nil
767 "*List of logical names for which visiting shouldn't save the true dirname. 814 "*List of logical names for which visiting shouldn't save the true dirname.
768 On VMS, when you visit a file using a logical name that searches a path, 815 On VMS, when you visit a file using a logical name that searches a path,
769 you may or may not want the visited file name to record the specific 816 you may or may not want the visited file name to record the specific
770 directory where the file was found. If you *do not* want that, add the logical 817 directory where the file was found. If you *do not* want that, add the logical
771 name to this list as a string.") 818 name to this list as a string.")
772 819
773 ;; XEmacs -- why was this commented out?? -- Hrv 820 ;(defun find-buffer-visiting (filename)
774 (defun find-buffer-visiting (filename) 821 ; "Return the buffer visiting file FILENAME (a string).
775 "Return the buffer visiting file FILENAME (a string). 822 ;This is like `get-file-buffer', except that it checks for any buffer
776 This is like `get-file-buffer', except that it checks for any buffer 823 ;visiting the same file, possibly under a different name.
777 visiting the same file, possibly under a different name. 824 ;If there is no such live buffer, return nil."
778 If there is no such live buffer, return nil." 825 ; (let ((buf (get-file-buffer filename))
779 (let ((buf (get-file-buffer filename)) 826 ; (truename (abbreviate-file-name (file-truename filename))))
780 (truename (abbreviate-file-name (file-truename filename)))) 827 ; (or buf
781 (or buf 828 ; (let ((list (buffer-list)) found)
782 (let ((list (buffer-list)) found) 829 ; (while (and (not found) list)
783 (while (and (not found) list) 830 ; (save-excursion
784 (save-excursion 831 ; (set-buffer (car list))
785 (set-buffer (car list)) 832 ; (if (and buffer-file-name
786 (if (and buffer-file-name 833 ; (string= buffer-file-truename truename))
787 (string= buffer-file-truename truename)) 834 ; (setq found (car list))))
788 (setq found (car list)))) 835 ; (setq list (cdr list)))
789 (setq list (cdr list))) 836 ; found)
790 found) 837 ; (let ((number (nthcdr 10 (file-attributes truename)))
791 (let ((number (nthcdr 10 (file-attributes truename))) 838 ; (list (buffer-list)) found)
792 (list (buffer-list)) found) 839 ; (and number
793 (and buffer-file-numbers-unique 840 ; (while (and (not found) list)
794 number 841 ; (save-excursion
795 (while (and (not found) list) 842 ; (set-buffer (car list))
796 (save-excursion 843 ; (if (and buffer-file-number
797 (set-buffer (car list)) 844 ; (equal buffer-file-number number)
798 (if (and buffer-file-name 845 ; ;; Verify this buffer's file number
799 (equal buffer-file-number number) 846 ; ;; still belongs to its file.
800 ;; Verify this buffer's file number 847 ; (file-exists-p buffer-file-name)
801 ;; still belongs to its file. 848 ; (equal (nthcdr 10 (file-attributes buffer-file-name))
802 (file-exists-p buffer-file-name) 849 ; number))
803 (equal (nthcdr 10 (file-attributes buffer-file-name)) 850 ; (setq found (car list))))
804 number)) 851 ; (setq list (cdr list))))
805 (setq found (car list)))) 852 ; found))))
806 (setq list (cdr list))))
807 found))))
808 853
809 (defun insert-file-contents-literally (filename &optional visit beg end replace) 854 (defun insert-file-contents-literally (filename &optional visit beg end replace)
810 "Like `insert-file-contents', q.v., but only reads in the file. 855 "Like `insert-file-contents', q.v., but only reads in the file.
811 A buffer may be modified in several ways after reading into the buffer due 856 A buffer may be modified in several ways after reading into the buffer due
812 to advanced Emacs features, such as file-name-handlers, format decoding, 857 to advanced Emacs features, such as file-name-handlers, format decoding,
832 If a buffer exists visiting FILENAME, return that one, but 877 If a buffer exists visiting FILENAME, return that one, but
833 verify that the file has not changed since visited or saved. 878 verify that the file has not changed since visited or saved.
834 The buffer is not selected, just returned to the caller. 879 The buffer is not selected, just returned to the caller.
835 If NOWARN is non-nil warning messages about several potential 880 If NOWARN is non-nil warning messages about several potential
836 problems will be suppressed." 881 problems will be suppressed."
837 (setq filename 882 (setq filename (abbreviate-file-name (expand-file-name filename)))
838 (abbreviate-file-name
839 (expand-file-name filename)))
840 (if (file-directory-p filename) 883 (if (file-directory-p filename)
841 (if find-file-run-dired 884 (if find-file-run-dired
842 (dired-noselect (if find-file-use-truenames ; XEmacs 885 (dired-noselect (if find-file-use-truenames
843 (abbreviate-file-name (file-truename filename)) 886 (abbreviate-file-name (file-truename filename))
844 filename)) 887 filename))
845 (error "%s is a directory" filename)) 888 (error "%s is a directory." filename))
846 (let* ((buf (get-file-buffer filename)) 889 (let* ((buf (get-file-buffer filename))
847 ; (truename (abbreviate-file-name (file-truename filename))) 890 ; (truename (abbreviate-file-name (file-truename filename)))
848 ; (number (nthcdr 10 (file-attributes truename))) 891 ; (number (nthcdr 10 (file-attributes truename)))
849 (number (and buffer-file-truename 892 (number (and buffer-file-truename
850 (nthcdr 10 (file-attributes buffer-file-truename)))) 893 (nthcdr 10 (file-attributes buffer-file-truename))))
851 ; ;; Find any buffer for a file which has same truename. 894 ; ;; Find any buffer for a file which has same truename.
852 ; (other (and (not buf) (find-buffer-visiting filename))) 895 ; (other (and (not buf) (find-buffer-visiting filename)))
853 (error nil)) 896 (error nil))
854 897
855 ; ;; Let user know if there is a buffer with the same truename. 898 ; ;; Let user know if there is a buffer with the same truename.
856 ; (if other 899 ; (if (and (not buf) same-truename (not nowarn))
857 ; (progn 900 ; (message "%s and %s are the same file (%s)"
858 ; (or nowarn 901 ; filename (buffer-file-name same-truename)
859 ; (string-equal filename (buffer-file-name other)) 902 ; truename)
860 ; (message "%s and %s are the same file" 903 ; (if (and (not buf) same-number (not nowarn))
861 ; filename (buffer-file-name other))) 904 ; (message "%s and %s are the same file"
862 ; ;; Optionally also find that buffer. 905 ; filename (buffer-file-name same-number))))
863 ; (if (or find-file-existing-other-name find-file-visit-truename) 906 ; ;; Optionally also find that buffer.
864 ; (setq buf other)))) 907 ; (if (or find-file-existing-other-name find-file-visit-truename)
908 ; (setq buf (or same-truename same-number)))
865 909
866 (if (and buf 910 (if (and buf
867 (or find-file-compare-truenames find-file-use-truenames) 911 (or find-file-compare-truenames find-file-use-truenames)
868 (not nowarn)) 912 (not nowarn))
869 (save-excursion 913 (save-excursion
911 (condition-case () 955 (condition-case ()
912 (insert-file-contents-literally filename t) 956 (insert-file-contents-literally filename t)
913 (file-error 957 (file-error
914 ;; Unconditionally set error 958 ;; Unconditionally set error
915 (setq error t))) 959 (setq error t)))
916 (condition-case e ; XEmacs - pass error through 960 (condition-case e
917 (insert-file-contents filename t) 961 (insert-file-contents filename t)
918 (file-error 962 (file-error
919 ;; Run find-file-not-found-hooks until one returns non-nil. 963 ;; Run find-file-not-found-hooks until one returns non-nil.
920 (or (run-hook-with-args-until-success 'find-file-not-found-hooks) 964 (or (run-hook-with-args-until-success 'find-file-not-found-hooks)
921 ;; If they fail too, set error. 965 ;; If they fail too, set error.
922 (setq error e))))) ; XEmacs 966 (setq error e)))))
923 ;; Find the file's truename, and maybe use that as visited name. 967 ;; Find the file's truename, and maybe use that as visited name.
924 ;; automatically computed in XEmacs. 968 ;; automatically computed in XEmacs.
925 ; (setq buffer-file-truename truename) 969 ; (setq buffer-file-truename truename)
926 (setq buffer-file-number number) 970 (setq buffer-file-number number)
927 ;; On VMS, we may want to remember which directory in a search list 971 ;; On VMS, we may want to remember which directory in a search list
951 (progn 995 (progn
952 (make-local-variable 'backup-inhibited) 996 (make-local-variable 'backup-inhibited)
953 (setq backup-inhibited t))) 997 (setq backup-inhibited t)))
954 (if rawfile 998 (if rawfile
955 nil 999 nil
956 (after-find-file error (not nowarn)) 1000 (after-find-file error (not nowarn)))))
957 (setq buf (current-buffer)))))
958 buf))) 1001 buf)))
959 1002
960 (defvar after-find-file-from-revert-buffer nil) 1003 (defvar after-find-file-from-revert-buffer nil)
961 1004
962 (defun after-find-file (&optional error warn noauto 1005 (defun after-find-file (&optional error warn noauto
963 after-find-file-from-revert-buffer 1006 after-find-file-from-revert-buffer)
964 nomodes)
965 "Called after finding a file and by the default revert function. 1007 "Called after finding a file and by the default revert function.
966 Sets buffer mode, parses local variables. 1008 Sets buffer mode, parses local variables.
967 Optional args ERROR, WARN, and NOAUTO: ERROR non-nil means there was an 1009 Optional args ERROR, WARN, and NOAUTO: ERROR non-nil means there was an
968 error in reading the file. WARN non-nil means warn if there 1010 error in reading the file. WARN non-nil means warn if there
969 exists an auto-save file more recent than the visited file. 1011 exists an auto-save file more recent than the visited file.
970 NOAUTO means don't mess with auto-save mode. 1012 NOAUTO means don't mess with auto-save mode.
971 Fourth arg AFTER-FIND-FILE-FROM-REVERT-BUFFER non-nil 1013 Fourth arg AFTER-FIND-FILE-FROM-REVERT-BUFFER non-nil
972 means this call was from `revert-buffer'. 1014 means this call was from `revert-buffer'.
973 Finishes by calling the functions in `find-file-hooks'. 1015 Finishes by calling the functions in `find-file-hooks'."
974 Fifth arg NOMODES non-nil means don't alter the file's modes.
975 Finishes by calling the functions in `find-file-hooks'
976 unless NOMODES is non-nil."
977 (setq buffer-read-only (not (file-writable-p buffer-file-name))) 1016 (setq buffer-read-only (not (file-writable-p buffer-file-name)))
978 (if noninteractive 1017 (if noninteractive
979 nil 1018 nil
980 (let* (not-serious 1019 (let* (not-serious
981 (msg 1020 (msg
1000 ;; If the directory the buffer is in doesn't exist, 1039 ;; If the directory the buffer is in doesn't exist,
1001 ;; offer to create it. It's better to do this now 1040 ;; offer to create it. It's better to do this now
1002 ;; than when we save the buffer, because we want 1041 ;; than when we save the buffer, because we want
1003 ;; autosaving to work. 1042 ;; autosaving to work.
1004 (setq buffer-read-only nil) 1043 (setq buffer-read-only nil)
1005 ;; XEmacs change
1006 (or (file-exists-p (file-name-directory buffer-file-name)) 1044 (or (file-exists-p (file-name-directory buffer-file-name))
1007 (if (yes-or-no-p 1045 (if (yes-or-no-p
1008 (format 1046 (format
1009 "The directory containing %s does not exist. Create? " 1047 "The directory containing %s does not exist. Create? "
1010 (abbreviate-file-name buffer-file-name))) 1048 (abbreviate-file-name buffer-file-name)))
1016 (progn 1054 (progn
1017 (message msg) 1055 (message msg)
1018 (or not-serious (sit-for 1 t))))) 1056 (or not-serious (sit-for 1 t)))))
1019 (if (and auto-save-default (not noauto)) 1057 (if (and auto-save-default (not noauto))
1020 (auto-save-mode t))) 1058 (auto-save-mode t)))
1021 (unless nomodes 1059 (normal-mode t)
1022 (normal-mode t) 1060 (run-hooks 'find-file-hooks))
1023 (run-hooks 'find-file-hooks)))
1024 1061
1025 (defun normal-mode (&optional find-file) 1062 (defun normal-mode (&optional find-file)
1026 "Choose the major mode for this buffer automatically. 1063 "Choose the major mode for this buffer automatically.
1027 Also sets up any specified local variables of the file. 1064 Also sets up any specified local variables of the file.
1028 Uses the visited file name, the -*- line, and the local variables spec. 1065 Uses the visited file name, the -*- line, and the local variables spec.
1032 `enable-local-variables': if it is t, we do; if it is nil, we don't; 1069 `enable-local-variables': if it is t, we do; if it is nil, we don't;
1033 otherwise, we query. `enable-local-variables' is ignored if you 1070 otherwise, we query. `enable-local-variables' is ignored if you
1034 run `normal-mode' explicitly." 1071 run `normal-mode' explicitly."
1035 (interactive) 1072 (interactive)
1036 (or find-file (funcall (or default-major-mode 'fundamental-mode))) 1073 (or find-file (funcall (or default-major-mode 'fundamental-mode)))
1037 ;; XEmacs change
1038 (and (condition-case err 1074 (and (condition-case err
1039 (progn (set-auto-mode) 1075 (progn (set-auto-mode)
1040 t) 1076 t)
1041 (error (message "File mode specification error: %s" 1077 (error (message "File mode specification error: %s"
1042 (prin1-to-string err)) 1078 (prin1-to-string err))
1049 (defvar auto-mode-alist 1085 (defvar auto-mode-alist
1050 (mapcar 1086 (mapcar
1051 'purecopy 1087 'purecopy
1052 '(("\\.te?xt\\'" . text-mode) 1088 '(("\\.te?xt\\'" . text-mode)
1053 ("\\.[ch]\\'" . c-mode) 1089 ("\\.[ch]\\'" . c-mode)
1054 ("\\.tex\\'" . tex-mode)
1055 ("\\.ltx\\'" . latex-mode) 1090 ("\\.ltx\\'" . latex-mode)
1056 ("\\.el\\'" . emacs-lisp-mode) 1091 ("\\.el\\'" . emacs-lisp-mode)
1057 ("\\.l\\(i?sp\\)?\\'" . lisp-mode) 1092 ("\\.l\\(i?sp\\)?\\'" . lisp-mode)
1058 ("\\.[Ff]\\(or\\)?\\'" . fortran-mode) 1093 ("\\.f\\(or\\)?\\'" . fortran-mode)
1059 ("\\.p\\(as\\)?\\'" . pascal-mode) 1094 ("\\.p\\(as\\)?\\'" . pascal-mode)
1060 ("\\.ad[abs]\\'" . ada-mode) 1095 ("\\.ad[abs]\\'" . ada-mode)
1061 ("\\.pl\\'" . perl-mode) 1096 ("\\.p[lm]\\'" . perl-mode)
1062 ("\\.pm\\'" . perl-mode)
1063 ("\\.\\([CH]\\|cc\\|hh\\)\\'" . c++-mode) 1097 ("\\.\\([CH]\\|cc\\|hh\\)\\'" . c++-mode)
1064 ("\\.[ch]\\(pp\\|xx\\|\\+\\+\\)\\'" . c++-mode) 1098 ("\\.[ch]\\(pp\\|xx\\|\\+\\+\\)\\'" . c++-mode)
1065 ("\\.java\\'" . java-mode) 1099 ("\\.java\\'" . java-mode)
1066 ("\\.ma?k\\'" . makefile-mode) 1100 ("\\.ma?k\\'" . makefile-mode)
1067 ("\\(M\\|m\\|GNUm\\)akefile\\(.in\\)?\\(.in\\)?\\'" . makefile-mode) 1101 ("[Mm]akefile\\(.in\\)?\\(.in\\)?\\'" . makefile-mode)
1068 ;;; Less common extensions come here 1102 ;;; Less common extensions come here
1069 ;;; so more common ones above are found faster. 1103 ;;; so more common ones above are found faster.
1070 ("\\.texi\\(nfo\\)?\\'" . texinfo-mode) 1104 ("\\.texi\\(nfo\\)?\\'" . texinfo-mode)
1071 ("\\.[Ss]\\'" . asm-mode) 1105 ("\\.[sS]\\'" . asm-mode)
1072 ("\\.asm\\'" . asm-mode)
1073 ("[Cc]hange.?[Ll]og?\\(.[0-9]+\\)?\\'" . change-log-mode) 1106 ("[Cc]hange.?[Ll]og?\\(.[0-9]+\\)?\\'" . change-log-mode)
1074 ("\\$CHANGE_LOG\\$\\.TXT" . change-log-mode) 1107 ("\\$CHANGE_LOG\\$\\.TXT" . change-log-mode)
1075 ("\\.scm\\(\\.[0-9]*\\)?\\'" . scheme-mode) 1108 ("\\.scm\\(\\.[0-9]*\\)?\\'" . scheme-mode)
1076 ("\\.py\\'" . python-mode) 1109 ("\\.py\\'" . python-mode)
1077 ("\\.e\\'" . eiffel-mode) 1110 ("\\.e\\'" . eiffel-mode)
1078 ("\\.mss\\'" . scribe-mode) 1111 ("\\.mss\\'" . scribe-mode)
1079 ("\\.m\\([mes]\\|an\\)\\'" . nroff-mode) 1112 ("\\.m\\([mes]\\|an\\)\\'" . nroff-mode)
1080 ("\\.icn\\'" . icon-mode) 1113 ("\\.icn\\'" . icon-mode)
1081 ("\\.[ck]?sh\\'\\|\\.shar\\'\\|/\\.z?profile\\'" . sh-mode)
1082 ("/\\.\\(bash_profile\\|z?login\\|bash_login\\|z?logout\\)\\'" . sh-mode)
1083 ("/\\.\\(bash_logout\\|[kz]shrc\\|bashrc\\|t?cshrc\\|esrc\\)\\'" . sh-mode)
1084 ("/\\.\\([kz]shenv\\|xinitrc\\|startxrc\\|xsession\\)\\'" . sh-mode)
1085 ;;; The following should come after the ChangeLog pattern 1114 ;;; The following should come after the ChangeLog pattern
1086 ;;; for the sake of ChangeLog.1, etc. 1115 ;;; for the sake of ChangeLog.1, etc.
1087 ;;; and after the .scm.[0-9] pattern too. 1116 ;;; and after the .scm.[0-9] pattern too.
1088 ("\\.[12345678]\\'" . nroff-mode) 1117 ("\\.[12345678]\\'" . nroff-mode)
1089 ("\\.[tT]e[xX]\\'" . tex-mode) 1118 ("\\.[tT]e[xX]\\'" . tex-mode)
1092 ("\\.article\\'" . text-mode) 1121 ("\\.article\\'" . text-mode)
1093 ("\\.letter\\'" . text-mode) 1122 ("\\.letter\\'" . text-mode)
1094 ("\\.\\(tcl\\|exp\\)\\'" . tcl-mode) 1123 ("\\.\\(tcl\\|exp\\)\\'" . tcl-mode)
1095 ("\\.wrl\\'" . vrml-mode) 1124 ("\\.wrl\\'" . vrml-mode)
1096 ("\\.f90\\'" . f90-mode) 1125 ("\\.f90\\'" . f90-mode)
1097 ("\\.lsp\\'" . lisp-mode)
1098 ("\\.awk\\'" . awk-mode) 1126 ("\\.awk\\'" . awk-mode)
1099 ("\\.prolog\\'" . prolog-mode) 1127 ("\\.prolog\\'" . prolog-mode)
1100 ("\\.tar\\'" . tar-mode) 1128 ("\\.tar\\'" . tar-mode)
1101 ("\\.\\(arc\\|zip\\|lzh\\|zoo\\)\\'" . archive-mode) 1129 ("\\.\\(arc\\|zip\\|lzh\\|zoo\\)\\'" . archive-mode)
1102 ("\\.\\(ARC\\|ZIP\\|LZH\\|ZOO\\)\\'" . archive-mode)
1103 ;; Mailer puts message to be edited in 1130 ;; Mailer puts message to be edited in
1104 ;; /tmp/Re.... or Message 1131 ;; /tmp/Re.... or Message
1105 ("^/tmp/Re" . text-mode) 1132 ("^/tmp/Re" . text-mode)
1106 ("^/tmp/L[0-9]+TMP\\.html" . text-mode) ; Lynx mail mode
1107 ("/Message[0-9]*\\'" . text-mode) 1133 ("/Message[0-9]*\\'" . text-mode)
1108 ("/drafts/[0-9]+\\'" . mh-letter-mode) 1134 ("/drafts/[0-9]+\\'" . mh-letter-mode)
1109 ;; some news reader is reported to use this 1135 ;; some news reader is reported to use this
1110 ("^/tmp/fol/" . text-mode) 1136 ("^/tmp/fol/" . text-mode)
1111 ("\\.y\\'" . c-mode) 1137 ("\\.y\\'" . c-mode)
1132 calling FUNCTION (if it's not nil), we delete the suffix that matched 1158 calling FUNCTION (if it's not nil), we delete the suffix that matched
1133 REGEXP and search the list again for another match.") 1159 REGEXP and search the list again for another match.")
1134 1160
1135 (defconst interpreter-mode-alist 1161 (defconst interpreter-mode-alist
1136 (mapcar 'purecopy 1162 (mapcar 'purecopy
1137 '(("^#!.*[acjkwz]sh" . sh-mode) 1163 '(("^#!.*csh" . sh-mode)
1138 ("^#!.*sh\\b" . sh-mode) 1164 ("^#!.*sh\\b" . ksh-mode)
1139 ("^#!.*\\b\\(scope\\|wishx?\\|tcl\\|tclsh\\|expect\\)" . tcl-mode) 1165 ("^#!.*\\b\\(scope\\|wish\\|tcl\\|expect\\)" . tcl-mode)
1140 ("perl" . perl-mode) 1166 ("perl" . perl-mode)
1141 ("python" . python-mode) 1167 ("python" . python-mode)
1142 ("[mng]?awk\\b" . awk-mode) 1168 ("awk\\b" . awk-mode)
1143 ("rexx" . rexx-mode) 1169 ("rexx" . rexx-mode)
1144 ("scm" . scheme-mode) 1170 ("scm" . scheme-mode)
1145 ("^:" . sh-mode) 1171 ("^:" . ksh-mode)
1146 )) 1172 ))
1147 "Alist mapping interpreter names to major modes. 1173 "Alist mapping interpreter names to major modes.
1148 This alist is used to guess the major mode of a file based on the 1174 This alist is used to guess the major mode of a file based on the
1149 contents of the first line. This line often contains something like: 1175 contents of the first line. This line often contains something like:
1150 #!/bin/sh 1176 #!/bin/sh
1168 1194
1169 (defvar user-init-file 1195 (defvar user-init-file
1170 "" ; set by command-line 1196 "" ; set by command-line
1171 "File name including directory of user's initialization file.") 1197 "File name including directory of user's initialization file.")
1172 1198
1173 ;; XEmacs (This function is not synched with FSF)
1174 (defun set-auto-mode () 1199 (defun set-auto-mode ()
1175 "Select major mode appropriate for current buffer. 1200 "Select major mode appropriate for current buffer.
1176 This checks for a -*- mode tag in the buffer's text, 1201 This checks for a -*- mode tag in the buffer's text,
1177 compares the filename against the entries in `auto-mode-alist', 1202 compares the filename against the entries in `auto-mode-alist',
1178 or checks the interpreter that runs this file against 1203 or checks the interpreter that runs this file against
1213 (setq mode (cdr (car alist)) 1238 (setq mode (cdr (car alist))
1214 keep-going nil))) 1239 keep-going nil)))
1215 (setq alist (cdr alist)))) 1240 (setq alist (cdr alist))))
1216 ;; If we can't deduce a mode from the file name, 1241 ;; If we can't deduce a mode from the file name,
1217 ;; look for an interpreter specified in the first line. 1242 ;; look for an interpreter specified in the first line.
1218 (if (and (null mode) 1243 (if (null mode)
1219 (save-excursion ; XEmacs
1220 (goto-char (point-min))
1221 (looking-at "#!")))
1222 (let ((firstline 1244 (let ((firstline
1223 (buffer-substring 1245 (buffer-substring
1224 (point-min) 1246 (point-min)
1225 (save-excursion 1247 (save-excursion
1226 (goto-char (point-min)) (end-of-line) (point))))) 1248 (goto-char (point-min)) (end-of-line) (point)))))
1233 (setq alist (cdr alist)))))) 1255 (setq alist (cdr alist))))))
1234 (if mode 1256 (if mode
1235 (funcall mode)) 1257 (funcall mode))
1236 )))))) 1258 ))))))
1237 1259
1238 ;; XEmacs: this function is not synched with FSF
1239 ;; jwz - New Version 20.1/19.15
1240 (defun hack-local-variables-prop-line (&optional force)
1241 ;; Set local variables specified in the -*- line.
1242 ;; Returns t if mode was set.
1243 (let ((result nil))
1244 (save-excursion
1245 (goto-char (point-min))
1246 (skip-chars-forward " \t\n\r")
1247 (let ((end (save-excursion
1248 ;; If the file begins with "#!"
1249 ;; (un*x exec interpreter magic), look
1250 ;; for mode frobs in the first two
1251 ;; lines. You cannot necessarily
1252 ;; put them in the first line of
1253 ;; such a file without screwing up
1254 ;; the interpreter invocation.
1255 (end-of-line (and (looking-at "^#!") 2))
1256 (point))))
1257 ;; Parse the -*- line into the `result' alist.
1258 (cond ((not (search-forward "-*-" end t))
1259 ;; doesn't have one.
1260 (setq force t))
1261 ((looking-at "[ \t]*\\([^ \t\n\r:;]+\\)\\([ \t]*-\\*-\\)")
1262 ;; Antiquated form: "-*- ModeName -*-".
1263 (setq result
1264 (list (cons 'mode
1265 (intern (buffer-substring
1266 (match-beginning 1)
1267 (match-end 1)))))
1268 ))
1269 (t
1270 ;; Usual form: '-*-' [ <variable> ':' <value> ';' ]* '-*-'
1271 ;; (last ";" is optional).
1272 (save-excursion
1273 (if (search-forward "-*-" end t)
1274 (setq end (- (point) 3))
1275 (error "-*- not terminated before end of line")))
1276 (while (< (point) end)
1277 (or (looking-at "[ \t]*\\([^ \t\n:]+\\)[ \t]*:[ \t]*")
1278 (error "malformed -*- line"))
1279 (goto-char (match-end 0))
1280 ;; There used to be a downcase here,
1281 ;; but the manual didn't say so,
1282 ;; and people want to set var names that aren't all lc.
1283 (let ((key (intern (buffer-substring
1284 (match-beginning 1)
1285 (match-end 1))))
1286 (val (save-restriction
1287 (narrow-to-region (point) end)
1288 (read (current-buffer)))))
1289 ;; Case sensitivity! Icepicks in my forehead!
1290 (if (equal (downcase (symbol-name key)) "mode")
1291 (setq key 'mode))
1292 (setq result (cons (cons key val) result))
1293 (skip-chars-forward " \t;")))
1294 (setq result (nreverse result))))))
1295
1296 (let ((set-any-p (or force (hack-local-variables-p t)))
1297 (mode-p nil))
1298 (while result
1299 (let ((key (car (car result)))
1300 (val (cdr (car result))))
1301 (cond ((eq key 'mode)
1302 (setq mode-p t)
1303 (and enable-local-variables
1304 (funcall (intern (concat (downcase (symbol-name val))
1305 "-mode")))))
1306 (set-any-p
1307 (hack-one-local-variable key val))
1308 (t
1309 nil)))
1310 (setq result (cdr result)))
1311 mode-p)))
1312
1313 (defvar hack-local-variables-hook nil
1314 "Normal hook run after processing a file's local variables specs.
1315 Major modes can use this to examine user-specified local variables
1316 in order to initialize other data structure based on them.
1317
1318 This hook runs even if there were no local variables or if their
1319 evaluation was suppressed. See also `enable-local-variables' and
1320 `enable-local-eval'.")
1321
1322 ;; XEmacs this function is not synched with FSF
1323 (defun hack-local-variables (&optional force) 1260 (defun hack-local-variables (&optional force)
1324 "Parse, and bind or evaluate as appropriate, any local variables 1261 "Parse, and bind or evaluate as appropriate, any local variables
1325 for current buffer." 1262 for current buffer."
1326 ;; Don't look for -*- if this file name matches any 1263 ;; Don't look for -*- if this file name matches any
1327 ;; of the regexps in inhibit-first-line-modes-regexps. 1264 ;; of the regexps in inhibit-first-line-modes-regexps.
1453 (error "Local variables entry is terminated incorrectly")) 1390 (error "Local variables entry is terminated incorrectly"))
1454 ;; Set the variable. "Variables" mode and eval are funny. 1391 ;; Set the variable. "Variables" mode and eval are funny.
1455 (hack-one-local-variable var val)))))))) 1392 (hack-one-local-variable var val))))))))
1456 1393
1457 1394
1395 (defun hack-local-variables-prop-line (&optional force)
1396 ;; Set local variables specified in the -*- line.
1397 ;; Returns t if mode was set.
1398 (let ((result nil))
1399 (save-excursion
1400 (goto-char (point-min))
1401 (skip-chars-forward " \t\n\r")
1402 (let ((end (save-excursion
1403 ;; If the file begins with "#!"
1404 ;; (un*x exec interpreter magic), look
1405 ;; for mode frobs in the first two
1406 ;; lines. You cannot necessarily
1407 ;; put them in the first line of
1408 ;; such a file without screwing up
1409 ;; the interpreter invocation.
1410 (end-of-line (and (looking-at "^#!") 2))
1411 (point))))
1412 ;; Parse the -*- line into the `result' alist.
1413 (cond ((not (search-forward "-*-" end t))
1414 ;; doesn't have one.
1415 nil)
1416 ((looking-at "[ \t]*\\([^ \t\n\r:;]+\\)\\([ \t]*-\\*-\\)")
1417 ;; Antiquated form: "-*- ModeName -*-".
1418 (setq result
1419 (list (cons 'mode
1420 (intern (buffer-substring
1421 (match-beginning 1)
1422 (match-end 1)))))
1423 ))
1424 (t
1425 ;; Usual form: '-*-' [ <variable> ':' <value> ';' ]* '-*-'
1426 ;; (last ";" is optional).
1427 (save-excursion
1428 (if (search-forward "-*-" end t)
1429 (setq end (- (point) 3))
1430 (error "-*- not terminated before end of line")))
1431 (while (< (point) end)
1432 (or (looking-at "[ \t]*\\([^ \t\n:]+\\)[ \t]*:[ \t]*")
1433 (error "malformed -*- line"))
1434 (goto-char (match-end 0))
1435 ;; There used to be a downcase here,
1436 ;; but the manual didn't say so,
1437 ;; and people want to set var names that aren't all lc.
1438 (let ((key (intern (buffer-substring
1439 (match-beginning 1)
1440 (match-end 1))))
1441 (val (save-restriction
1442 (narrow-to-region (point) end)
1443 (read (current-buffer)))))
1444 ;; Case sensitivity! Icepicks in my forehead!
1445 (if (equal (downcase (symbol-name key)) "mode")
1446 (setq key 'mode))
1447 (setq result (cons (cons key val) result))
1448 (skip-chars-forward " \t;")))
1449 (setq result (nreverse result))))))
1450
1451 (let ((set-any-p (or force (hack-local-variables-p t)))
1452 (mode-p nil))
1453 (while result
1454 (let ((key (car (car result)))
1455 (val (cdr (car result))))
1456 (cond ((eq key 'mode)
1457 (setq mode-p t)
1458 (funcall (intern (concat (downcase (symbol-name val))
1459 "-mode"))))
1460 (set-any-p
1461 (hack-one-local-variable key val))
1462 (t
1463 nil)))
1464 (setq result (cdr result)))
1465 mode-p)))
1458 1466
1459 (defconst ignored-local-variables 1467 (defconst ignored-local-variables
1460 '(enable-local-eval) 1468 (list 'enable-local-eval)
1461 "Variables to be ignored in a file's local variable spec.") 1469 "Variables to be ignored in a file's local variable spec.")
1462 1470
1463 ;; Get confirmation before setting these variables as locals in a file. 1471 ;; Get confirmation before setting these variables as locals in a file.
1464 (put 'debugger 'risky-local-variable t) 1472 (put 'debugger 'risky-local-variable t)
1465 (put 'enable-local-eval 'risky-local-variable t) 1473 (put 'enable-local-eval 'risky-local-variable t)
1473 (put 'buffer-file-truename 'risky-local-variable t) 1481 (put 'buffer-file-truename 'risky-local-variable t)
1474 (put 'exec-path 'risky-local-variable t) 1482 (put 'exec-path 'risky-local-variable t)
1475 (put 'load-path 'risky-local-variable t) 1483 (put 'load-path 'risky-local-variable t)
1476 (put 'exec-directory 'risky-local-variable t) 1484 (put 'exec-directory 'risky-local-variable t)
1477 (put 'process-environment 'risky-local-variable t) 1485 (put 'process-environment 'risky-local-variable t)
1478 (put 'dabbrev-case-fold-search 'risky-local-variable t)
1479 (put 'dabbrev-case-replace 'risky-local-variable t)
1480 ;; Don't wait for outline.el to be loaded, for the sake of outline-minor-mode. 1486 ;; Don't wait for outline.el to be loaded, for the sake of outline-minor-mode.
1481 (put 'outline-level 'risky-local-variable t) 1487 (put 'outline-level 'risky-local-variable t)
1482 (put 'rmail-output-file-alist 'risky-local-variable t) 1488 (put 'rmail-output-file-alist 'risky-local-variable t)
1483 1489
1484 ;; This one is safe because the user gets to check it before it is used. 1490 ;; This one is safe because the user gets to check it before it is used.
1485 (put 'compile-command 'safe-local-variable t) 1491 (put 'compile-command 'safe-local-variable t)
1486 1492
1487 ;(defun hack-one-local-variable-quotep (exp) 1493 ;(defun hack-one-local-variable-quotep (exp)
1488 ; (and (consp exp) (eq (car exp) 'quote) (consp (cdr exp)))) 1494 ; (and (consp exp) (eq (car exp) 'quote) (consp (cdr exp))))
1533 (message "Ignoring `eval:' in file's local variables"))) 1539 (message "Ignoring `eval:' in file's local variables")))
1534 ;; Ordinary variable, really set it. 1540 ;; Ordinary variable, really set it.
1535 (t (make-local-variable var) 1541 (t (make-local-variable var)
1536 (set var val)))) 1542 (set var val))))
1537 1543
1538 (defun set-visited-file-name (filename &optional no-query) 1544 (defun set-visited-file-name (filename)
1539 "Change name of file visited in current buffer to FILENAME. 1545 "Change name of file visited in current buffer to FILENAME.
1540 The next time the buffer is saved it will go in the newly specified file. 1546 The next time the buffer is saved it will go in the newly specified file.
1541 nil or empty string as argument means make buffer not be visiting any file. 1547 nil or empty string as argument means make buffer not be visiting any file.
1542 Remember to delete the initial contents of the minibuffer 1548 Remember to delete the initial contents of the minibuffer
1543 if you wish to pass an empty string as the argument. 1549 if you wish to pass an empty string as the argument."
1544
1545 The optional second argument NO-QUERY, if non-nil, inhibits asking for
1546 confirmation in the case where the file FILENAME already exists."
1547 (interactive "FSet visited file name: ") 1550 (interactive "FSet visited file name: ")
1548 (if (buffer-base-buffer) 1551 (if (buffer-base-buffer)
1549 (error "An indirect buffer cannot visit a file")) 1552 (error "An indirect buffer cannot visit a file"))
1550 (let (truename) 1553 (let (truename)
1551 (if filename 1554 (if filename
1555 (expand-file-name filename)))) 1558 (expand-file-name filename))))
1556 (if filename 1559 (if filename
1557 (progn 1560 (progn
1558 (setq truename (file-truename filename)) 1561 (setq truename (file-truename filename))
1559 ;; #### Do we need to check if truename is non-nil? 1562 ;; #### Do we need to check if truename is non-nil?
1560 ;; XEmacs: FSF uses -visit-
1561 (if find-file-use-truenames 1563 (if find-file-use-truenames
1562 (setq filename truename)))) 1564 (setq filename truename))))
1563 ; (let ((buffer (and filename (find-buffer-visiting filename))))
1564 ; (and buffer (not (eq buffer (current-buffer)))
1565 ; (not no-query)
1566 ; (not (y-or-n-p (message "A buffer is visiting %s; proceed? "
1567 ; filename)))
1568 ; (error "Aborted")))
1569 (or (equal filename buffer-file-name) 1565 (or (equal filename buffer-file-name)
1570 (progn 1566 (progn
1571 (and filename (lock-buffer filename)) 1567 (and filename (lock-buffer filename))
1572 (unlock-buffer))) 1568 (unlock-buffer)))
1573 (setq buffer-file-name filename) 1569 (setq buffer-file-name filename)
1581 (or (string= new-name (buffer-name)) 1577 (or (string= new-name (buffer-name))
1582 (rename-buffer new-name t)))) 1578 (rename-buffer new-name t))))
1583 (setq buffer-backed-up nil) 1579 (setq buffer-backed-up nil)
1584 (clear-visited-file-modtime) 1580 (clear-visited-file-modtime)
1585 (compute-buffer-file-truename) ; insert-file-contents does this too. 1581 (compute-buffer-file-truename) ; insert-file-contents does this too.
1586 ;; XEmacs deletion
1587 ; ;; Abbreviate the file names of the buffer. 1582 ; ;; Abbreviate the file names of the buffer.
1588 ; (if truename 1583 ; (if truename
1589 ; (progn 1584 ; (progn
1590 ; (setq buffer-file-truename (abbreviate-file-name truename)) 1585 ; (setq buffer-file-truename (abbreviate-file-name truename))
1591 ; (if find-file-visit-truename 1586 ; (if find-file-visit-truename
1596 nil))) 1591 nil)))
1597 ;; write-file-hooks is normally used for things like ftp-find-file 1592 ;; write-file-hooks is normally used for things like ftp-find-file
1598 ;; that visit things that are not local files as if they were files. 1593 ;; that visit things that are not local files as if they were files.
1599 ;; Changing to visit an ordinary local file instead should flush the hook. 1594 ;; Changing to visit an ordinary local file instead should flush the hook.
1600 (kill-local-variable 'write-file-hooks) 1595 (kill-local-variable 'write-file-hooks)
1601 (kill-local-variable 'after-save-hook) ; XEmacs 1596 (kill-local-variable 'after-save-hook)
1602 (kill-local-variable 'local-write-file-hooks) 1597 (kill-local-variable 'local-write-file-hooks)
1603 (kill-local-variable 'write-file-data-hooks) ; XEmacs 1598 (kill-local-variable 'write-file-data-hooks)
1604 (kill-local-variable 'revert-buffer-function) 1599 (kill-local-variable 'revert-buffer-function)
1605 (kill-local-variable 'backup-inhibited) 1600 (kill-local-variable 'backup-inhibited)
1606 ;; If buffer was read-only because of version control, 1601 ;; If buffer was read-only because of version control,
1607 ;; that reason is gone now, so make it writable. 1602 ;; that reason is gone now, so make it writable.
1608 (if (and (boundp 'vc-mode) vc-mode) 1603 (if (and (boundp 'vc-mode) vc-mode)
1630 (and oauto buffer-auto-save-file-name 1625 (and oauto buffer-auto-save-file-name
1631 (file-exists-p oauto) 1626 (file-exists-p oauto)
1632 (rename-file oauto buffer-auto-save-file-name t))) 1627 (rename-file oauto buffer-auto-save-file-name t)))
1633 (if buffer-file-name 1628 (if buffer-file-name
1634 (set-buffer-modified-p t)) 1629 (set-buffer-modified-p t))
1635 ;; #### ?? (Not in FSF -sb) 1630 ;; #### ??
1636 (run-hooks 'after-set-visited-file-name-hooks)) 1631 (run-hooks 'after-set-visited-file-name-hooks))
1637 1632
1638 (defun write-file (filename &optional confirm) 1633 (defun write-file (filename &optional confirm codesys)
1639 "Write current buffer into file FILENAME. 1634 "Write current buffer into file FILENAME.
1640 Makes buffer visit that file, and marks it not modified. 1635 Makes buffer visit that file, and marks it not modified.
1641 If the buffer is already visiting a file, you can specify 1636 If the buffer is already visiting a file, you can specify
1642 a directory name as FILENAME, to write a file of the same 1637 a directory name as FILENAME, to write a file of the same
1643 old name in that directory. 1638 old name in that directory.
1644
1645 If optional second arg CONFIRM is non-nil, 1639 If optional second arg CONFIRM is non-nil,
1646 ask for confirmation for overwriting an existing file. 1640 ask for confirmation for overwriting an existing file.
1647 Interactively, confirmation is required unless you supply a prefix argument." 1641 Under XEmacs/Mule, optional third argument specifies the
1642 coding system to use when encoding the file. Interactively,
1643 with a prefix argument, you will be prompted for the coding system."
1648 ;; (interactive "FWrite file: ") 1644 ;; (interactive "FWrite file: ")
1649 (interactive 1645 (interactive
1650 (list (if buffer-file-name 1646 (list (if buffer-file-name
1651 (read-file-name "Write file: " 1647 (read-file-name "Write file: "
1652 nil nil nil nil) 1648 nil nil nil nil)
1653 (read-file-name "Write file: " 1649 (read-file-name "Write file: "
1654 (cdr (assq 'default-directory 1650 (cdr (assq 'default-directory
1655 (buffer-local-variables))) 1651 (buffer-local-variables)))
1656 nil nil (buffer-name))) 1652 nil nil (buffer-name)))
1657 t)) 1653 t
1658 ;; XEmacs 1654 (if (and current-prefix-arg (featurep 'mule))
1655 (read-coding-system "Coding system: "))))
1659 (and (eq (current-buffer) mouse-grabbed-buffer) 1656 (and (eq (current-buffer) mouse-grabbed-buffer)
1660 (error "Can't write minibuffer window")) 1657 (error "Can't write minibuffer window"))
1661 (or (null filename) (string-equal filename "") 1658 (or (null filename) (string-equal filename "")
1662 (progn 1659 (progn
1663 ;; If arg is just a directory, 1660 ;; If arg is just a directory,
1669 (file-exists-p filename) 1666 (file-exists-p filename)
1670 (or (y-or-n-p (format "File `%s' exists; overwrite? " filename)) 1667 (or (y-or-n-p (format "File `%s' exists; overwrite? " filename))
1671 (error "Canceled"))) 1668 (error "Canceled")))
1672 (set-visited-file-name filename))) 1669 (set-visited-file-name filename)))
1673 (set-buffer-modified-p t) 1670 (set-buffer-modified-p t)
1674 (setq buffer-read-only nil) ; XEmacs 1671 (setq buffer-read-only nil)
1675 (save-buffer)) 1672 (if codesys
1673 (let ((file-coding-system (get-coding-system codesys)))
1674 (save-buffer))
1675 (save-buffer)))
1676 1676
1677 (defun backup-buffer () 1677 (defun backup-buffer ()
1678 "Make a backup of the disk file visited by the current buffer, if appropriate. 1678 "Make a backup of the disk file visited by the current buffer, if appropriate.
1679 This is normally done before saving the buffer the first time. 1679 This is normally done before saving the buffer the first time.
1680 If the value is non-nil, it is the result of `file-modes' on the original 1680 If the value is non-nil, it is the result of `file-modes' on the original file;
1681 file; this means that the caller, after saving the buffer, should change 1681 this means that the caller, after saving the buffer, should change the modes
1682 the modes of the new file to agree with the old modes." 1682 of the new file to agree with the old modes."
1683 (if buffer-file-name 1683 (if (and make-backup-files
1684 (let ((handler (find-file-name-handler buffer-file-name 'backup-buffer))) 1684 (not backup-inhibited)
1685 (if handler 1685 (not buffer-backed-up)
1686 (funcall handler 'backup-buffer) 1686 (file-exists-p buffer-file-name)
1687 (if (and make-backup-files (not backup-inhibited) 1687 (memq (aref (elt (file-attributes buffer-file-name) 8) 0)
1688 (not buffer-backed-up) 1688 '(?- ?l)))
1689 (file-exists-p buffer-file-name) 1689 (let ((real-file-name buffer-file-name)
1690 (memq (aref (elt (file-attributes buffer-file-name) 8) 0) 1690 backup-info backupname targets setmodes)
1691 '(?- ?l))) 1691 ;; If specified name is a symbolic link, chase it to the target.
1692 (let ((real-file-name buffer-file-name) 1692 ;; Thus we make the backups in the directory where the real file is.
1693 backup-info backupname targets setmodes) 1693 (setq real-file-name (file-chase-links real-file-name))
1694 ;; If specified name is a symbolic link, chase it to the target. 1694 (setq backup-info (find-backup-file-name real-file-name)
1695 ;; Thus we make the backups in the directory where the real file is. 1695 backupname (car backup-info)
1696 (setq real-file-name (file-chase-links real-file-name)) 1696 targets (cdr backup-info))
1697 (setq backup-info (find-backup-file-name real-file-name)
1698 backupname (car backup-info)
1699 targets (cdr backup-info))
1700 ;;; (if (file-directory-p buffer-file-name) 1697 ;;; (if (file-directory-p buffer-file-name)
1701 ;;; (error "Cannot save buffer in directory %s" buffer-file-name)) 1698 ;;; (error "Cannot save buffer in directory %s" buffer-file-name))
1702 (if backup-info 1699 (if backup-info
1703 (condition-case () 1700 (condition-case ()
1704 (let ((delete-old-versions 1701 (let ((delete-old-versions
1705 ;; If have old versions to maybe delete, 1702 ;; If have old versions to maybe delete,
1706 ;; ask the user to confirm now, before doing anything. 1703 ;; ask the user to confirm now, before doing anything.
1707 ;; But don't actually delete til later. 1704 ;; But don't actually delete til later.
1708 (and targets 1705 (and targets
1709 (or (eq delete-old-versions t) 1706 (or (eq delete-old-versions t)
1710 (eq delete-old-versions nil)) 1707 (eq delete-old-versions nil))
1711 (or delete-old-versions 1708 (or delete-old-versions
1712 (y-or-n-p (format "Delete excess backup versions of %s? " 1709 (y-or-n-p (format "Delete excess backup versions of %s? "
1713 real-file-name)))))) 1710 real-file-name))))))
1714 ;; Actually write the back up file. 1711 ;; Actually write the back up file.
1712 (condition-case ()
1713 (if (or file-precious-flag
1714 ; (file-symlink-p buffer-file-name)
1715 backup-by-copying
1716 (and backup-by-copying-when-linked
1717 (> (file-nlinks real-file-name) 1))
1718 (and backup-by-copying-when-mismatch
1719 (let ((attr (file-attributes real-file-name)))
1720 (or (nth 9 attr)
1721 (not (file-ownership-preserved-p real-file-name))))))
1715 (condition-case () 1722 (condition-case ()
1716 (if (or file-precious-flag 1723 (copy-file real-file-name backupname t t)
1717 ; (file-symlink-p buffer-file-name)
1718 backup-by-copying
1719 (and backup-by-copying-when-linked
1720 (> (file-nlinks real-file-name) 1))
1721 (and backup-by-copying-when-mismatch
1722 (let ((attr (file-attributes real-file-name)))
1723 (or (nth 9 attr)
1724 (not (file-ownership-preserved-p real-file-name))))))
1725 (condition-case ()
1726 (copy-file real-file-name backupname t t)
1727 (file-error
1728 ;; If copying fails because file BACKUPNAME
1729 ;; is not writable, delete that file and try again.
1730 (if (and (file-exists-p backupname)
1731 (not (file-writable-p backupname)))
1732 (delete-file backupname))
1733 (copy-file real-file-name backupname t t)))
1734 ;; rename-file should delete old backup.
1735 (rename-file real-file-name backupname t)
1736 (setq setmodes (file-modes backupname)))
1737 (file-error 1724 (file-error
1738 ;; If trouble writing the backup, write it in ~. 1725 ;; If copying fails because file BACKUPNAME
1739 (setq backupname (expand-file-name 1726 ;; is not writable, delete that file and try again.
1740 (convert-standard-filename 1727 (if (and (file-exists-p backupname)
1741 "~/%backup%~"))) 1728 (not (file-writable-p backupname)))
1742 (message "Cannot write backup file; backing up in %s" 1729 (delete-file backupname))
1743 (file-name-nondirectory backupname)) 1730 (copy-file real-file-name backupname t t)))
1744 (sleep-for 1) 1731 ;; rename-file should delete old backup.
1745 (condition-case () 1732 (rename-file real-file-name backupname t)
1746 (copy-file real-file-name backupname t t) 1733 (setq setmodes (file-modes backupname)))
1747 (file-error 1734 (file-error
1748 ;; If copying fails because file BACKUPNAME 1735 ;; If trouble writing the backup, write it in ~.
1749 ;; is not writable, delete that file and try again. 1736 (setq backupname (expand-file-name "~/%backup%~"))
1750 (if (and (file-exists-p backupname) 1737 (message "Cannot write backup file; backing up in ~/%%backup%%~")
1751 (not (file-writable-p backupname))) 1738 (sleep-for 1)
1752 (delete-file backupname)) 1739 (condition-case ()
1753 (copy-file real-file-name backupname t t))))) 1740 (copy-file real-file-name backupname t t)
1754 (setq buffer-backed-up t) 1741 (file-error
1755 ;; Now delete the old versions, if desired. 1742 ;; If copying fails because file BACKUPNAME
1756 (if delete-old-versions 1743 ;; is not writable, delete that file and try again.
1757 (while targets 1744 (if (and (file-exists-p backupname)
1758 (condition-case () 1745 (not (file-writable-p backupname)))
1759 (delete-file (car targets)) 1746 (delete-file backupname))
1760 (file-error nil)) 1747 (copy-file real-file-name backupname t t)))))
1761 (setq targets (cdr targets)))) 1748 (setq buffer-backed-up t)
1762 setmodes) 1749 ;; Now delete the old versions, if desired.
1763 (file-error nil))))))))) 1750 (if delete-old-versions
1751 (while targets
1752 (condition-case ()
1753 (delete-file (car targets))
1754 (file-error nil))
1755 (setq targets (cdr targets))))
1756 setmodes)
1757 (file-error nil))))))
1764 1758
1765 (defun file-name-sans-versions (name &optional keep-backup-version) 1759 (defun file-name-sans-versions (name &optional keep-backup-version)
1766 "Return FILENAME sans backup versions or strings. 1760 "Return FILENAME sans backup versions or strings.
1767 This is a separate procedure so your site-init or startup file can 1761 This is a separate procedure so your site-init or startup file can
1768 redefine it. 1762 redefine it.
1784 (match-beginning 1)) 1778 (match-beginning 1))
1785 (length name)) 1779 (length name))
1786 (if keep-backup-version 1780 (if keep-backup-version
1787 (length name) 1781 (length name)
1788 (or (string-match "\\.~[0-9.]+~\\'" name) 1782 (or (string-match "\\.~[0-9.]+~\\'" name)
1789 ;; XEmacs - VC uses extensions like ".~tagname~" 1783 ;; XEmacs - VC uses extensions like ".~tagname~" or ".~1.1.5.2~"
1790 ;; or ".~1.1.5.2~"
1791 (let ((pos (string-match "\\.~\\([^.~ \t]+\\|[0-9.]+\\)~\\'" name))) 1784 (let ((pos (string-match "\\.~\\([^.~ \t]+\\|[0-9.]+\\)~\\'" name)))
1792 (and pos 1785 (and pos
1793 ;; #### - is this filesystem check too paranoid? 1786 ;; #### - is this filesystem check too paranoid?
1794 (file-exists-p (substring name 0 pos)) 1787 (file-exists-p (substring name 0 pos))
1795 pos)) 1788 pos))
1821 filename)))) 1814 filename))))
1822 1815
1823 (defun make-backup-file-name (file) 1816 (defun make-backup-file-name (file)
1824 "Create the non-numeric backup file name for FILE. 1817 "Create the non-numeric backup file name for FILE.
1825 This is a separate function so you can redefine it for customization." 1818 This is a separate function so you can redefine it for customization."
1826 (if (and (eq system-type 'ms-dos) 1819 (if (eq system-type 'ms-dos)
1827 (not (msdos-long-file-names)))
1828 (let ((fn (file-name-nondirectory file))) 1820 (let ((fn (file-name-nondirectory file)))
1829 (concat (file-name-directory file) 1821 (concat (file-name-directory file)
1830 (if (string-match "\\([^.]*\\)\\(\\..*\\)?" fn) 1822 (if (string-match "\\([^.]*\\)\\(\\..*\\)?" fn)
1831 (substring fn 0 (match-end 1))) 1823 (substring fn 0 (match-end 1)))
1832 ; (or
1833 ; (and (string-match "\\`[^.]+\\'" fn)
1834 ; (concat (match-string 0 fn) ".~"))
1835 ; (and (string-match "\\`[^.]+\\.\\(..?\\)?" fn)
1836 ; (concat (match-string 0 fn) "~")))))
1837 ".bak")) 1824 ".bak"))
1838 (concat file "~"))) 1825 (concat file "~")))
1839 1826
1840 (defun backup-file-name-p (file) 1827 (defun backup-file-name-p (file)
1841 "Return non-nil if FILE is a backup file name (numeric or not). 1828 "Return non-nil if FILE is a backup file name (numeric or not).
1917 directory (file-name-as-directory (expand-file-name 1904 directory (file-name-as-directory (expand-file-name
1918 (or directory default-directory)))) 1905 (or directory default-directory))))
1919 (let ((ancestor "")) 1906 (let ((ancestor ""))
1920 (while (not (string-match (concat "^" (regexp-quote directory)) filename)) 1907 (while (not (string-match (concat "^" (regexp-quote directory)) filename))
1921 (setq directory (file-name-directory (substring directory 0 -1)) 1908 (setq directory (file-name-directory (substring directory 0 -1))
1922 ancestor (concat "../" ancestor))) 1909 ancestor (concat "../" ancestor)))
1923 (concat ancestor (substring filename (match-end 0))))) 1910 (concat ancestor (substring filename (match-end 0)))))
1924 1911
1925 (defun save-buffer (&optional args) 1912 (defun save-buffer (&optional args)
1926 "Save current buffer in visited file if modified. Versions described below. 1913 "Save current buffer in visited file if modified. Versions described below.
1927 1914
1928 By default, makes the previous version into a backup file 1915 By default, makes the previous version into a backup file
1929 if previously requested or if this is the first save. 1916 if previously requested or if this is the first save.
1930 With 1 \\[universal-argument], marks this version 1917 With 1 or 3 \\[universal-argument]'s, marks this version
1931 to become a backup when the next save is done. 1918 to become a backup when the next save is done.
1932 With 2 \\[universal-argument]'s, 1919 With 2 or 3 \\[universal-argument]'s,
1933 unconditionally makes the previous version into a backup file. 1920 unconditionally makes the previous version into a backup file.
1934 With 3 \\[universal-argument]'s, marks this version
1935 to become a backup when the next save is done,
1936 and unconditionally makes the previous version into a backup file.
1937
1938 With argument of 0, never makes the previous version into a backup file. 1921 With argument of 0, never makes the previous version into a backup file.
1939 1922
1940 If a file's name is FOO, the names of its numbered backup versions are 1923 If a file's name is FOO, the names of its numbered backup versions are
1941 FOO.~i~ for various integers i. A non-numbered backup file is called FOO~. 1924 FOO.~i~ for various integers i. A non-numbered backup file is called FOO~.
1942 Numeric backups (rather than FOO~) will be made if value of 1925 Numeric backups (rather than FOO~) will be made if value of
1948 and `kept-new-versions', which tells how many newest versions to keep. 1931 and `kept-new-versions', which tells how many newest versions to keep.
1949 Defaults are 2 old versions and 2 new. 1932 Defaults are 2 old versions and 2 new.
1950 `dired-kept-versions' controls dired's clean-directory (.) command. 1933 `dired-kept-versions' controls dired's clean-directory (.) command.
1951 If `delete-old-versions' is nil, system will query user 1934 If `delete-old-versions' is nil, system will query user
1952 before trimming versions. Otherwise it does it silently." 1935 before trimming versions. Otherwise it does it silently."
1953 (interactive "_p") 1936 (interactive "p")
1954 (let ((modp (buffer-modified-p)) 1937 (let ((modp (buffer-modified-p))
1955 (large (> (buffer-size) 50000)) 1938 (large (> (buffer-size) 50000))
1956 (make-backup-files (or (and make-backup-files (not (eq args 0))) 1939 (make-backup-files (or (and make-backup-files (not (eq args 0)))
1957 (memq args '(16 64))))) 1940 (memq args '(16 64)))))
1958 (and modp (memq args '(16 64)) (setq buffer-backed-up nil)) 1941 (and modp (memq args '(16 64)) (setq buffer-backed-up nil))
1959 (if (and modp large) (message "Saving file %s..." (buffer-file-name))) 1942 (if (and modp large) (message "Saving file %s..."
1943 (buffer-file-name)))
1960 (basic-save-buffer) 1944 (basic-save-buffer)
1961 (and modp (memq args '(4 64)) (setq buffer-backed-up nil)))) 1945 (and modp (memq args '(4 64)) (setq buffer-backed-up nil))))
1962 1946
1963 (defun delete-auto-save-file-if-necessary (&optional force) 1947 (defun delete-auto-save-file-if-necessary (&optional force)
1964 "Delete auto-save file for current buffer if `delete-auto-save-files' is t. 1948 "Delete auto-save file for current buffer if `delete-auto-save-files' is t.
2009 (save-excursion 1993 (save-excursion
2010 ;; In an indirect buffer, save its base buffer instead. 1994 ;; In an indirect buffer, save its base buffer instead.
2011 (if (buffer-base-buffer) 1995 (if (buffer-base-buffer)
2012 (set-buffer (buffer-base-buffer))) 1996 (set-buffer (buffer-base-buffer)))
2013 (if (buffer-modified-p) 1997 (if (buffer-modified-p)
2014 (let ((recent-save (recent-auto-save-p)) 1998 (let ((recent-save (recent-auto-save-p)))
2015 setmodes tempsetmodes)
2016 ;; On VMS, rename file and buffer to get rid of version number. 1999 ;; On VMS, rename file and buffer to get rid of version number.
2017 (if (and (eq system-type 'vax-vms) 2000 (if (and (eq system-type 'vax-vms)
2018 (not (string= buffer-file-name 2001 (not (string= buffer-file-name
2019 (file-name-sans-versions buffer-file-name)))) 2002 (file-name-sans-versions buffer-file-name))))
2020 (let (buffer-new-name) 2003 (let (buffer-new-name)
2096 ;; This does the "real job" of writing a buffer into its visited file 2079 ;; This does the "real job" of writing a buffer into its visited file
2097 ;; and making a backup file. This is what is normally done 2080 ;; and making a backup file. This is what is normally done
2098 ;; but inhibited if one of write-file-hooks returns non-nil. 2081 ;; but inhibited if one of write-file-hooks returns non-nil.
2099 ;; It returns a value to store in setmodes. 2082 ;; It returns a value to store in setmodes.
2100 (defun basic-save-buffer-1 () 2083 (defun basic-save-buffer-1 ()
2101 (let (tempsetmodes setmodes) 2084 (let (setmodes tempsetmodes)
2102 (if (not (file-writable-p buffer-file-name)) 2085 (if (not (file-writable-p buffer-file-name))
2103 (let ((dir (file-name-directory buffer-file-name))) 2086 (let ((dir (file-name-directory buffer-file-name)))
2104 (if (not (file-directory-p dir)) 2087 (if (not (file-directory-p dir))
2105 (error "%s is not a directory" dir) 2088 (error "%s is not a directory" dir)
2106 (if (not (file-exists-p buffer-file-name)) 2089 (if (not (file-exists-p buffer-file-name))
2112 (setq tempsetmodes t) 2095 (setq tempsetmodes t)
2113 (error 2096 (error
2114 "Attempt to save to a file which you aren't allowed to write")))))) 2097 "Attempt to save to a file which you aren't allowed to write"))))))
2115 (or buffer-backed-up 2098 (or buffer-backed-up
2116 (setq setmodes (backup-buffer))) 2099 (setq setmodes (backup-buffer)))
2117 (let ((dir (file-name-directory buffer-file-name))) 2100 (let ((dir (file-name-directory buffer-file-name)))
2118 (if (and file-precious-flag 2101 (if (and file-precious-flag
2119 (file-writable-p dir)) 2102 (file-writable-p dir))
2120 ;; If file is precious, write temp name, then rename it. 2103 ;; If file is precious, write temp name, then rename it.
2121 ;; This requires write access to the containing dir, 2104 ;; This requires write access to the containing dir,
2122 ;; which is why we don't try it if we don't have that access. 2105 ;; which is why we don't try it if we don't have that access.
2123 (let ((realname buffer-file-name) 2106 (let ((realname buffer-file-name)
2124 tempname temp nogood i succeed 2107 tempname nogood i succeed
2125 (old-modtime (visited-file-modtime))) 2108 (old-modtime (visited-file-modtime)))
2126 (setq i 0) 2109 (setq i 0)
2127 (setq nogood t) 2110 (setq nogood t)
2128 ;; Find the temporary name to write under. 2111 ;; Find the temporary name to write under.
2129 (while nogood 2112 (while nogood
2130 (setq tempname (format 2113 (setq tempname (format "%s#tmp#%d" dir i))
2131 (if (and (eq system-type 'ms-dos)
2132 (not (msdos-long-file-names)))
2133 "%s#%d.tm#" ; MSDOS limits files to 8+3
2134 "%s#tmp#%d")
2135 dir i))
2136 (setq nogood (file-exists-p tempname)) 2114 (setq nogood (file-exists-p tempname))
2137 (setq i (1+ i))) 2115 (setq i (1+ i)))
2138 (unwind-protect 2116 (unwind-protect
2139 (progn (clear-visited-file-modtime) 2117 (progn (clear-visited-file-modtime)
2140 (write-region (point-min) (point-max) 2118 (write-region (point-min) (point-max)
2141 tempname nil realname 2119 tempname nil realname
2142 buffer-file-truename) 2120 buffer-file-truename)
2143 (setq succeed t)) 2121 (setq succeed t))
2144 ;; If writing the temp file fails, 2122 ;; If writing the temp file fails,
2145 ;; delete the temp file. 2123 ;; delete the temp file.
2146 (or succeed 2124 (or succeed
2147 (progn 2125 (progn
2148 (delete-file tempname) 2126 (delete-file tempname)
2149 (set-visited-file-modtime old-modtime)))) 2127 (set-visited-file-modtime old-modtime))))
2150 ;; Since we have created an entirely new file 2128 ;; Since we have created an entirely new file
2151 ;; and renamed it, make sure it gets the 2129 ;; and renamed it, make sure it gets the
2160 ;; (setmodes is set) because that says we're superseding. 2138 ;; (setmodes is set) because that says we're superseding.
2161 (cond ((and tempsetmodes (not setmodes)) 2139 (cond ((and tempsetmodes (not setmodes))
2162 ;; Change the mode back, after writing. 2140 ;; Change the mode back, after writing.
2163 (setq setmodes (file-modes buffer-file-name)) 2141 (setq setmodes (file-modes buffer-file-name))
2164 (set-file-modes buffer-file-name 511))) 2142 (set-file-modes buffer-file-name 511)))
2165 ;; XEmacs change to end of function
2166 (basic-write-file-data buffer-file-name buffer-file-truename))) 2143 (basic-write-file-data buffer-file-name buffer-file-truename)))
2167 (setq buffer-file-number 2144 (setq buffer-file-number
2168 (if buffer-file-name 2145 (if buffer-file-name
2169 (nth 10 (file-attributes buffer-file-name)) 2146 (nth 10 (file-attributes buffer-file-name))
2170 nil)) 2147 nil))
2204 Optional argument (the prefix) non-nil means save all with no questions. 2181 Optional argument (the prefix) non-nil means save all with no questions.
2205 Optional second argument EXITING means ask about certain non-file buffers 2182 Optional second argument EXITING means ask about certain non-file buffers
2206 as well as about file buffers." 2183 as well as about file buffers."
2207 (interactive "P") 2184 (interactive "P")
2208 (save-window-excursion 2185 (save-window-excursion
2209 ;; XEmacs - do not use queried flag
2210 (let ((files-done 2186 (let ((files-done
2211 (map-y-or-n-p 2187 (map-y-or-n-p
2212 (function 2188 (function
2213 (lambda (buffer) 2189 (lambda (buffer)
2214 (and (buffer-modified-p buffer) 2190 (and (buffer-modified-p buffer)
2287 (not buffer-read-only) 2263 (not buffer-read-only)
2288 (> (prefix-numeric-value arg) 0))) 2264 (> (prefix-numeric-value arg) 0)))
2289 ;; Force modeline redisplay 2265 ;; Force modeline redisplay
2290 (redraw-modeline)) 2266 (redraw-modeline))
2291 2267
2292 (defun insert-file (filename) 2268 (defun insert-file (filename &optional codesys)
2293 "Insert contents of file FILENAME into buffer after point. 2269 "Insert contents of file FILENAME into buffer after point.
2294 Set mark after the inserted text. 2270 Set mark after the inserted text.
2271
2272 Under XEmacs/Mule, optional second argument specifies the
2273 coding system to use when decoding the file. Interactively,
2274 with a prefix argument, you will be prompted for the coding system.
2295 2275
2296 This function is meant for the user to run interactively. 2276 This function is meant for the user to run interactively.
2297 Don't call it from programs! Use `insert-file-contents' instead. 2277 Don't call it from programs! Use `insert-file-contents' instead.
2298 \(Its calling sequence is different; see its documentation)." 2278 \(Its calling sequence is different; see its documentation)."
2299 (interactive "*fInsert file: ") 2279 (interactive "*fInsert file: \nZCoding system: ")
2300 (if (file-directory-p filename) 2280 (if (file-directory-p filename)
2301 (signal 'file-error (list "Opening input file" "file is a directory" 2281 (signal 'file-error (list "Opening input file" "file is a directory"
2302 filename))) 2282 filename)))
2303 (let ((tem (insert-file-contents filename))) 2283 (let ((tem
2284 (if codesys
2285 (let ((overriding-file-coding-system
2286 (get-coding-system codesys)))
2287 (insert-file-contents filename))
2288 (insert-file-contents filename))))
2304 (push-mark (+ (point) (car (cdr tem)))))) 2289 (push-mark (+ (point) (car (cdr tem))))))
2305 2290
2306 (defun append-to-file (start end filename) 2291 (defun append-to-file (start end filename &optional codesys)
2307 "Append the contents of the region to the end of file FILENAME. 2292 "Append the contents of the region to the end of file FILENAME.
2308 When called from a function, expects three arguments, 2293 When called from a function, expects three arguments,
2309 START, END and FILENAME. START and END are buffer positions 2294 START, END and FILENAME. START and END are buffer positions
2310 saying what text to write." 2295 saying what text to write.
2311 (interactive "r\nFAppend to file: ") 2296 Under XEmacs/Mule, optional fourth argument specifies the
2312 (write-region start end filename t)) 2297 coding system to use when encoding the file. Interactively,
2298 with a prefix argument, you will be prompted for the coding system."
2299 (interactive "r\nFAppend to file: \nZCoding system: ")
2300 (if codesys
2301 (let ((file-coding-system (get-coding-system codesys)))
2302 (write-region start end filename t))
2303 (write-region start end filename t)))
2313 2304
2314 (defun file-newest-backup (filename) 2305 (defun file-newest-backup (filename)
2315 "Return most recent backup file for FILENAME or nil if no backups exist." 2306 "Return most recent backup file for FILENAME or nil if no backups exist."
2316 (let* ((filename (expand-file-name filename)) 2307 (let* ((filename (expand-file-name filename))
2317 (file (file-name-nondirectory filename)) 2308 (file (file-name-nondirectory filename))
2318 (dir (file-name-directory filename)) 2309 (dir (file-name-directory filename))
2319 (comp (file-name-all-completions file dir)) 2310 (comp (file-name-all-completions file dir))
2320 newest tem) 2311 newest)
2321 (while comp 2312 (while comp
2322 (setq tem (car comp) 2313 (setq file (concat dir (car comp))
2323 comp (cdr comp)) 2314 comp (cdr comp))
2324 (cond ((and (backup-file-name-p tem) 2315 (if (and (backup-file-name-p file)
2325 (string= (file-name-sans-versions tem) file)) 2316 (or (null newest) (file-newer-than-file-p file newest)))
2326 (setq tem (concat dir tem)) 2317 (setq newest file)))
2327 (if (or (null newest)
2328 (file-newer-than-file-p tem newest))
2329 (setq newest tem)))))
2330 newest)) 2318 newest))
2331 2319
2332 (defun rename-uniquely () 2320 (defun rename-uniquely ()
2333 "Rename current buffer to a similar name not already taken. 2321 "Rename current buffer to a similar name not already taken.
2334 This function is useful for creating multiple shell process buffers 2322 This function is useful for creating multiple shell process buffers
2349 (name (buffer-name new-buf))) 2337 (name (buffer-name new-buf)))
2350 (kill-buffer new-buf) 2338 (kill-buffer new-buf)
2351 (rename-buffer name) 2339 (rename-buffer name)
2352 (redraw-modeline)))) 2340 (redraw-modeline))))
2353 2341
2354 ;; XEmacs
2355 (defun make-directory-path (path) 2342 (defun make-directory-path (path)
2356 "Create all the directories along path that don't exist yet." 2343 "Create all the directories along path that don't exist yet."
2357 (interactive "Fdirectory path to create: ") 2344 (interactive "Fdirectory path to create: ")
2358 (make-directory path t)) 2345 (make-directory path t))
2359 2346
2363 is the current default directory for file names. 2350 is the current default directory for file names.
2364 That is useful when you have visited a file in a nonexistent directory. 2351 That is useful when you have visited a file in a nonexistent directory.
2365 2352
2366 Noninteractively, the second (optional) argument PARENTS says whether 2353 Noninteractively, the second (optional) argument PARENTS says whether
2367 to create parent directories if they don't exist." 2354 to create parent directories if they don't exist."
2368 ;; XEmacs
2369 (interactive (list (let ((current-prefix-arg current-prefix-arg)) 2355 (interactive (list (let ((current-prefix-arg current-prefix-arg))
2370 (read-directory-name "Create directory: ")) 2356 (read-directory-name "Create directory: "))
2371 current-prefix-arg)) 2357 current-prefix-arg))
2372 (let ((handler (find-file-name-handler dir 'make-directory))) 2358 (let ((handler (find-file-name-handler dir 'make-directory)))
2373 (if handler 2359 (if handler
2407 hook functions. 2393 hook functions.
2408 2394
2409 If `revert-buffer-function' is used to override the normal revert 2395 If `revert-buffer-function' is used to override the normal revert
2410 mechanism, this hook is not used.") 2396 mechanism, this hook is not used.")
2411 2397
2412 (defun revert-buffer (&optional ignore-auto noconfirm preserve-modes) 2398 (defun revert-buffer (&optional ignore-auto noconfirm)
2413 "Replace the buffer text with the text of the visited file on disk. 2399 "Replace the buffer text with the text of the visited file on disk.
2414 This undoes all changes since the file was visited or saved. 2400 This undoes all changes since the file was visited or saved.
2415 With a prefix argument, offer to revert from latest auto-save file, if 2401 With a prefix argument, offer to revert from latest auto-save file, if
2416 that is more recent than the visited file. 2402 that is more recent than the visited file.
2417 When called from Lisp, the first argument is IGNORE-AUTO; only offer 2403 When called from Lisp, the first argument is IGNORE-AUTO; only offer
2437 (interactive (list (not current-prefix-arg))) 2423 (interactive (list (not current-prefix-arg)))
2438 (if revert-buffer-function 2424 (if revert-buffer-function
2439 (funcall revert-buffer-function ignore-auto noconfirm) 2425 (funcall revert-buffer-function ignore-auto noconfirm)
2440 (let* ((opoint (point)) 2426 (let* ((opoint (point))
2441 (auto-save-p (and (not ignore-auto) 2427 (auto-save-p (and (not ignore-auto)
2442 (recent-auto-save-p) 2428 (recent-auto-save-p)
2443 buffer-auto-save-file-name 2429 buffer-auto-save-file-name
2444 (file-readable-p buffer-auto-save-file-name) 2430 (file-readable-p buffer-auto-save-file-name)
2445 (y-or-n-p 2431 (y-or-n-p
2446 "Buffer has been auto-saved recently. Revert from auto-save file? "))) 2432 "Buffer has been auto-saved recently. Revert from auto-save file? ")))
2447 (file-name (if auto-save-p 2433 (file-name (if auto-save-p
2462 (or (eq buffer-undo-list t) 2448 (or (eq buffer-undo-list t)
2463 (setq buffer-undo-list nil)) 2449 (setq buffer-undo-list nil))
2464 ;; Effectively copy the after-revert-hook status, 2450 ;; Effectively copy the after-revert-hook status,
2465 ;; since after-find-file will clobber it. 2451 ;; since after-find-file will clobber it.
2466 (let ((global-hook (default-value 'after-revert-hook)) 2452 (let ((global-hook (default-value 'after-revert-hook))
2467 ;; XEmacs
2468 (local-hook-p (local-variable-p 'after-revert-hook 2453 (local-hook-p (local-variable-p 'after-revert-hook
2469 (current-buffer))) 2454 (current-buffer)))
2470 (local-hook (and (local-variable-p 'after-revert-hook 2455 (local-hook (and (local-variable-p 'after-revert-hook
2471 (current-buffer)) 2456 (current-buffer))
2472 after-revert-hook))) 2457 after-revert-hook)))
2489 (goto-char (min opoint (point-max))) 2474 (goto-char (min opoint (point-max)))
2490 ;; Recompute the truename in case changes in symlinks 2475 ;; Recompute the truename in case changes in symlinks
2491 ;; have changed the truename. 2476 ;; have changed the truename.
2492 ;XEmacs: already done by insert-file-contents 2477 ;XEmacs: already done by insert-file-contents
2493 ;(compute-buffer-file-truename) 2478 ;(compute-buffer-file-truename)
2494 (after-find-file nil nil t t preserve-modes) 2479 (after-find-file nil nil t t)
2495 ;; Run after-revert-hook as it was before we reverted. 2480 ;; Run after-revert-hook as it was before we reverted.
2496 (setq-default revert-buffer-internal-hook global-hook) 2481 (setq-default revert-buffer-internal-hook global-hook)
2497 (if local-hook-p 2482 (if local-hook-p
2498 (progn 2483 (progn
2499 (make-local-variable 'revert-buffer-internal-hook) 2484 (make-local-variable 'revert-buffer-internal-hook)
2507 ;; Actually putting the file name in the minibuffer should be used 2492 ;; Actually putting the file name in the minibuffer should be used
2508 ;; only rarely. 2493 ;; only rarely.
2509 ;; Not just because users often use the default. 2494 ;; Not just because users often use the default.
2510 (interactive "FRecover file: ") 2495 (interactive "FRecover file: ")
2511 (setq file (expand-file-name file)) 2496 (setq file (expand-file-name file))
2512 (let ((handler (or (find-file-name-handler file 'recover-file) 2497 (if (auto-save-file-name-p file)
2513 (find-file-name-handler 2498 (error "%s is an auto-save file" file))
2514 (let ((buffer-file-name file)) 2499 (let ((file-name (let ((buffer-file-name file))
2515 (make-auto-save-file-name)) 2500 (make-auto-save-file-name))))
2516 'recover-file)))) 2501 (cond ((if (file-exists-p file)
2517 (if handler 2502 (not (file-newer-than-file-p file-name file))
2518 (funcall handler 'recover-file file) 2503 (not (file-exists-p file-name)))
2519 (if (auto-save-file-name-p (file-name-nondirectory file)) 2504 (error "Auto-save file %s not current" file-name))
2520 (error "%s is an auto-save file" file)) 2505 ((save-window-excursion
2521 (let ((file-name (let ((buffer-file-name file)) 2506 (if (not (eq system-type 'vax-vms))
2522 (make-auto-save-file-name)))) 2507 (with-output-to-temp-buffer "*Directory*"
2523 (cond ((if (file-exists-p file) 2508 (buffer-disable-undo standard-output)
2524 (not (file-newer-than-file-p file-name file)) 2509 (call-process "ls" nil standard-output nil
2525 (not (file-exists-p file-name))) 2510 (if (file-symlink-p file) "-lL" "-l")
2526 (error "Auto-save file %s not current" file-name)) 2511 file file-name)))
2527 ((save-window-excursion 2512 (yes-or-no-p (format "Recover auto save file %s? " file-name)))
2528 (if (not (eq system-type 'vax-vms)) 2513 (switch-to-buffer (find-file-noselect file t))
2529 (with-output-to-temp-buffer "*Directory*" 2514 (let ((buffer-read-only nil))
2530 (buffer-disable-undo standard-output) 2515 (erase-buffer)
2531 (call-process "ls" nil standard-output nil 2516 (insert-file-contents file-name nil))
2532 (if (file-symlink-p file) "-lL" "-l") 2517 (after-find-file nil nil t))
2533 file file-name))) 2518 (t (error "Recover-file cancelled.")))))
2534 (yes-or-no-p (format "Recover auto save file %s? " file-name)))
2535 (switch-to-buffer (find-file-noselect file t))
2536 (let ((buffer-read-only nil))
2537 (erase-buffer)
2538 (insert-file-contents file-name nil))
2539 (after-find-file nil nil t))
2540 (t (error "Recover-file cancelled.")))))))
2541 2519
2542 (defun recover-session () 2520 (defun recover-session ()
2543 "Recover auto save files from a previous Emacs session. 2521 "Recover auto save files from a previous Emacs session.
2544 This command first displays a Dired buffer showing you the 2522 This command first displays a Dired buffer showing you the
2545 previous sessions that you could recover from. 2523 previous sessions that you could recover from.
2546 To choose one, move point to the proper line and then type C-c C-c. 2524 To choose one, move point to the proper line and then type C-c C-c.
2547 Then you'll be asked about a number of files to recover." 2525 Then you'll be asked about a number of files to recover."
2548 (interactive) 2526 (interactive)
2549 (let ((ls-lisp-support-shell-wildcards t)) 2527 (dired (concat auto-save-list-file-prefix "*"))
2550 (dired (concat auto-save-list-file-prefix "*")))
2551 (goto-char (point-min)) 2528 (goto-char (point-min))
2552 (or (looking-at "Move to the session you want to recover,") 2529 (or (looking-at "Move to the session you want to recover,")
2553 (let ((inhibit-read-only t)) 2530 (let ((inhibit-read-only t))
2554 (insert "Move to the session you want to recover,\n" 2531 (insert "Move to the session you want to recover,\n"
2555 "then type C-c C-c to select it.\n\n" 2532 "then type C-c C-c to select it.\n\n"
2556 "You can also delete some of these files;\n" 2533 "You can also delete some of these files;\n"
2557 "type d on a line to mark that file for deletion.\n\n"))) 2534 "type d on a line to mark that file for deletion.\n\n")))
2558 ;; XEmacs
2559 (use-local-map (let ((map (make-sparse-keymap))) 2535 (use-local-map (let ((map (make-sparse-keymap)))
2560 (set-keymap-parents map (list (current-local-map))) 2536 (set-keymap-parents map (list (current-local-map)))
2561 map)) 2537 map))
2562 (define-key (current-local-map) "\C-c\C-c" 'recover-session-finish)) 2538 (define-key (current-local-map) "\C-c\C-c" 'recover-session-finish))
2563 2539
2569 ;; Get the name of the session file to recover from. 2545 ;; Get the name of the session file to recover from.
2570 (let ((file (dired-get-filename)) 2546 (let ((file (dired-get-filename))
2571 files 2547 files
2572 (buffer (get-buffer-create " *recover*"))) 2548 (buffer (get-buffer-create " *recover*")))
2573 ;; #### dired-do-flagged-delete in FSF. 2549 ;; #### dired-do-flagged-delete in FSF.
2574 ;; This version is for ange-ftp 2550 (dired-do-deletions t)
2575 ;;(dired-do-deletions t)
2576 ;T This version is for efs
2577 (dired-expunge-deletions)
2578 (unwind-protect 2551 (unwind-protect
2579 (save-excursion 2552 (save-excursion
2580 ;; Read in the auto-save-list file. 2553 ;; Read in the auto-save-list file.
2581 (set-buffer buffer) 2554 (set-buffer buffer)
2582 (erase-buffer) 2555 (erase-buffer)
2626 (if files 2599 (if files
2627 (map-y-or-n-p "Recover %s? " 2600 (map-y-or-n-p "Recover %s? "
2628 (lambda (file) 2601 (lambda (file)
2629 (condition-case nil 2602 (condition-case nil
2630 (save-excursion (recover-file file)) 2603 (save-excursion (recover-file file))
2631 (error 2604 (error
2632 "Failed to recover `%s'" file))) 2605 "Failed to recover `%s'" file)))
2633 files 2606 files
2634 '("file" "files" "recover")) 2607 '("file" "files" "recover"))
2635 (message "No files can be recovered from this session now"))) 2608 (message "No files can be recovered from this session now")))
2636 (kill-buffer buffer)))) 2609 (kill-buffer buffer))))
2643 (let* ((buffer (car list)) 2616 (let* ((buffer (car list))
2644 (name (buffer-name buffer))) 2617 (name (buffer-name buffer)))
2645 (and (not (string-equal name "")) 2618 (and (not (string-equal name ""))
2646 (/= (aref name 0) ? ) 2619 (/= (aref name 0) ? )
2647 (yes-or-no-p 2620 (yes-or-no-p
2648 ;; XEmacs change
2649 (format 2621 (format
2650 (if (buffer-modified-p buffer) 2622 (if (buffer-modified-p buffer)
2651 (gettext "Buffer %s HAS BEEN EDITED. Kill? ") 2623 (gettext "Buffer %s HAS BEEN EDITED. Kill? ")
2652 (gettext "Buffer %s is unmodified. Kill? ")) 2624 (gettext "Buffer %s is unmodified. Kill? "))
2653 name)) 2625 name))
2691 (file-exists-p osave) 2663 (file-exists-p osave)
2692 (recent-auto-save-p)) 2664 (recent-auto-save-p))
2693 (rename-file osave buffer-auto-save-file-name t)))) 2665 (rename-file osave buffer-auto-save-file-name t))))
2694 2666
2695 ;; see also ../packages/auto-save.el 2667 ;; see also ../packages/auto-save.el
2696 ;; XEmacs change
2697 (defun make-auto-save-file-name (&optional filename) 2668 (defun make-auto-save-file-name (&optional filename)
2698 "Return file name to use for auto-saves of current buffer. 2669 "Return file name to use for auto-saves of current buffer.
2699 Does not consider `auto-save-visited-file-name' as that variable is checked 2670 Does not consider `auto-save-visited-file-name' as that variable is checked
2700 before calling this function. You can redefine this for customization. 2671 before calling this function. You can redefine this for customization.
2701 See also `auto-save-file-name-p'." 2672 See also `auto-save-file-name-p'."
2754 name 2725 name
2755 (expand-file-name (concat "~/" (file-name-nondirectory name)))))) 2726 (expand-file-name (concat "~/" (file-name-nondirectory name))))))
2756 2727
2757 (defun auto-save-file-name-p (filename) 2728 (defun auto-save-file-name-p (filename)
2758 "Return non-nil if FILENAME can be yielded by `make-auto-save-file-name'. 2729 "Return non-nil if FILENAME can be yielded by `make-auto-save-file-name'.
2759 FILENAME should lack slashes. You can redefine this for customization." 2730 FILENAME should lack slashes.
2731 You can redefine this for customization."
2760 (string-match "\\`#.*#\\'" filename)) 2732 (string-match "\\`#.*#\\'" filename))
2761
2762 (defun wildcard-to-regexp (wildcard)
2763 "Given a shell file name pattern WILDCARD, return an equivalent regexp.
2764 The generated regexp will match a filename iff the filename
2765 matches that wildcard according to shell rules. Only wildcards known
2766 by `sh' are supported."
2767 (let* ((i (string-match "[[.*+\\^$?]" wildcard))
2768 ;; Copy the initial run of non-special characters.
2769 (result (substring wildcard 0 i))
2770 (len (length wildcard)))
2771 ;; If no special characters, we're almost done.
2772 (if i
2773 (while (< i len)
2774 (let ((ch (aref wildcard i))
2775 j)
2776 (setq
2777 result
2778 (concat result
2779 (cond
2780 ((eq ch ?\[) ; [...] maps to regexp char class
2781 (progn
2782 (setq i (1+ i))
2783 (concat
2784 (cond
2785 ((eq (aref wildcard i) ?!) ; [!...] -> [^...]
2786 (progn
2787 (setq i (1+ i))
2788 (if (eq (aref wildcard i) ?\])
2789 (progn
2790 (setq i (1+ i))
2791 "[^]")
2792 "[^")))
2793 ((eq (aref wildcard i) ?^)
2794 ;; Found "[^". Insert a `\0' character
2795 ;; (which cannot happen in a filename)
2796 ;; into the character class, so that `^'
2797 ;; is not the first character after `[',
2798 ;; and thus non-special in a regexp.
2799 (progn
2800 (setq i (1+ i))
2801 "[\000^"))
2802 ((eq (aref wildcard i) ?\])
2803 ;; I don't think `]' can appear in a
2804 ;; character class in a wildcard, but
2805 ;; let's be general here.
2806 (progn
2807 (setq i (1+ i))
2808 "[]"))
2809 (t "["))
2810 (prog1 ; copy everything upto next `]'.
2811 (substring wildcard
2812 i
2813 (setq j (string-match
2814 "]" wildcard i)))
2815 (setq i (if j (1- j) (1- len)))))))
2816 ((eq ch ?.) "\\.")
2817 ((eq ch ?*) "[^\000]*")
2818 ((eq ch ?+) "\\+")
2819 ((eq ch ?^) "\\^")
2820 ((eq ch ?$) "\\$")
2821 ((eq ch ?\\) "\\\\") ; probably cannot happen...
2822 ((eq ch ??) "[^\000]")
2823 (t (char-to-string ch)))))
2824 (setq i (1+ i)))))
2825 ;; Shell wildcards should match the entire filename,
2826 ;; not its part. Make the regexp say so.
2827 (concat "\\`" result "\\'")))
2828 2733
2829 (defconst list-directory-brief-switches 2734 (defconst list-directory-brief-switches
2830 (if (eq system-type 'vax-vms) "" "-CF") 2735 (if (eq system-type 'vax-vms) "" "-CF")
2831 "*Switches for list-directory to pass to `ls' for brief listing,") 2736 "*Switches for list-directory to pass to `ls' for brief listing,")
2832 2737
2856 (princ "Directory ") 2761 (princ "Directory ")
2857 (princ dirname) 2762 (princ dirname)
2858 (terpri) 2763 (terpri)
2859 (save-excursion 2764 (save-excursion
2860 (set-buffer "*Directory*") 2765 (set-buffer "*Directory*")
2861 (setq default-directory 2766 (setq default-directory (file-name-directory dirname))
2862 (if (file-directory-p dirname)
2863 (file-name-as-directory dirname)
2864 (file-name-directory dirname)))
2865 (let ((wildcard (not (file-directory-p dirname)))) 2767 (let ((wildcard (not (file-directory-p dirname))))
2866 (insert-directory dirname switches wildcard (not wildcard))))))) 2768 (insert-directory dirname switches wildcard (not wildcard)))))))
2867 2769
2868 (defvar insert-directory-program "ls" 2770 (defvar insert-directory-program "ls"
2869 "Absolute or relative name of the `ls' program used by `insert-directory'.") 2771 "Absolute or relative name of the `ls' program used by `insert-directory'.")
2905 wildcard full-directory-p) 2807 wildcard full-directory-p)
2906 (if (eq system-type 'vax-vms) 2808 (if (eq system-type 'vax-vms)
2907 (vms-read-directory file switches (current-buffer)) 2809 (vms-read-directory file switches (current-buffer))
2908 (if wildcard 2810 (if wildcard
2909 ;; Run ls in the directory of the file pattern we asked for. 2811 ;; Run ls in the directory of the file pattern we asked for.
2910 (let ((default-directory 2812 (let ((default-directory
2911 (if (file-name-absolute-p file) 2813 (if (file-name-absolute-p file)
2912 (file-name-directory file) 2814 (file-name-directory file)
2913 (file-name-directory (expand-file-name file)))) 2815 (file-name-directory (expand-file-name file))))
2914 (pattern (file-name-nondirectory file)) 2816 (pattern (file-name-nondirectory file))
2915 (beg 0)) 2817 (beg 0))
2916 ;; Quote some characters that have special meanings in shells; 2818 ;; Quote some characters that have special meanings in shells;
2917 ;; but don't quote the wildcards--we want them to be special. 2819 ;; but don't quote the wildcards--we want them to be special.
2918 ;; We also currently don't quote the quoting characters 2820 ;; We also currently don't quote the quoting characters
2919 ;; in case people want to use them explicitly to quote 2821 ;; in case people want to use them explicitly to quote
2920 ;; wildcard characters. 2822 ;; wildcard characters.
2921 ;;#### Unix-specific 2823 ;;#### Unix-specific
2922 (while (string-match "[ \t\n;<>&|()#$]" pattern beg) 2824 (while (string-match "[ \t\n;<>&|()#$]" pattern beg)
2923 (setq pattern 2825 (setq pattern
2924 (concat (substring pattern 0 (match-beginning 0)) 2826 (concat (substring pattern 0 (match-beginning 0))
2925 "\\" 2827 "\\"
2926 (substring pattern (match-beginning 0))) 2828 (substring pattern (match-beginning 0)))
2947 ;; so we can pass separate options as separate args. 2849 ;; so we can pass separate options as separate args.
2948 (while (string-match " " switches) 2850 (while (string-match " " switches)
2949 (setq list (cons (substring switches 0 (match-beginning 0)) 2851 (setq list (cons (substring switches 0 (match-beginning 0))
2950 list) 2852 list)
2951 switches (substring switches (match-end 0)))) 2853 switches (substring switches (match-end 0))))
2952 (setq list (nreverse (cons switches list)))))) 2854 (setq list (cons switches list)))))
2953 (append list 2855 (append list
2954 (list 2856 (list
2955 (if full-directory-p 2857 (if full-directory-p
2956 (concat (file-name-as-directory file) 2858 (concat (file-name-as-directory file)
2957 ;;#### Unix-specific 2859 ;;#### Unix-specific
2989 (yes-or-no-p "Active processes exist; kill them and exit anyway? ")))) 2891 (yes-or-no-p "Active processes exist; kill them and exit anyway? "))))
2990 ;; Query the user for other things, perhaps. 2892 ;; Query the user for other things, perhaps.
2991 (run-hook-with-args-until-failure 'kill-emacs-query-functions) 2893 (run-hook-with-args-until-failure 'kill-emacs-query-functions)
2992 (kill-emacs))) 2894 (kill-emacs)))
2993 2895
2994 ;; XEmacs
2995 (defun symlink-expand-file-name (filename) 2896 (defun symlink-expand-file-name (filename)
2996 "If FILENAME is a symlink, return its non-symlink equivalent. 2897 "If FILENAME is a symlink, return its non-symlink equivalent.
2997 Unlike `file-truename', this doesn't chase symlinks in directory 2898 Unlike `file-truename', this doesn't chase symlinks in directory
2998 components of the file or expand a relative pathname into an 2899 components of the file or expand a relative pathname into an
2999 absolute one." 2900 absolute one."
3003 count (1- count))) 2904 count (1- count)))
3004 (if (> count 0) 2905 (if (> count 0)
3005 filename 2906 filename
3006 (error "Apparently circular symlink path")))) 2907 (error "Apparently circular symlink path"))))
3007 2908
3008 ;; Suggested by Michael Kifer <kifer@CS.SunySB.EDU>
3009 (defun file-remote-p (file-name)
3010 "Test whether FILE-NAME is looked for on a remote system."
3011 (cond ((not allow-remote-paths) nil)
3012 ((featurep 'ange-ftp) (ange-ftp-ftp-path file-name))
3013 (t (efs-ftp-path file-name))))
3014
3015 ;; Written in C in FSF
3016 (defun insert-file-contents (filename &optional visit beg end replace)
3017 "Insert contents of file FILENAME after point.
3018 Returns list of absolute file name and length of data inserted.
3019 If second argument VISIT is non-nil, the buffer's visited filename
3020 and last save file modtime are set, and it is marked unmodified.
3021 If visiting and the file does not exist, visiting is completed
3022 before the error is signaled.
3023
3024 The optional third and fourth arguments BEG and END
3025 specify what portion of the file to insert.
3026 If VISIT is non-nil, BEG and END must be nil.
3027 If optional fifth argument REPLACE is non-nil,
3028 it means replace the current buffer contents (in the accessible portion)
3029 with the file contents. This is better than simply deleting and inserting
3030 the whole thing because (1) it preserves some marker positions
3031 and (2) it puts less data in the undo list."
3032 (insert-file-contents-internal filename visit beg end replace))
3033
3034 ;; Written in C in FSF
3035 (defun write-region (start end filename &optional append visit lockname)
3036 "Write current region into specified file.
3037 When called from a program, takes three arguments:
3038 START, END and FILENAME. START and END are buffer positions.
3039 Optional fourth argument APPEND if non-nil means
3040 append to existing file contents (if any).
3041 Optional fifth argument VISIT if t means
3042 set the last-save-file-modtime of buffer to this file's modtime
3043 and mark buffer not modified.
3044 If VISIT is a string, it is a second file name;
3045 the output goes to FILENAME, but the buffer is marked as visiting VISIT.
3046 VISIT is also the file name to lock and unlock for clash detection.
3047 If VISIT is neither t nor nil nor a string,
3048 that means do not print the \"Wrote file\" message.
3049 The optional sixth arg LOCKNAME, if non-nil, specifies the name to
3050 use for locking and unlocking, overriding FILENAME and VISIT.
3051 Kludgy feature: if START is a string, then that string is written
3052 to the file, instead of any buffer contents, and END is ignored."
3053 (interactive "r\nFWrite region to file: ")
3054 (write-region-internal start end filename append visit lockname))
3055
3056 ;; Written in C in FSF
3057 (defun load (file &optional noerror nomessage nosuffix)
3058 "Execute a file of Lisp code named FILE.
3059 First try FILE with `.elc' appended, then try with `.el',
3060 then try FILE unmodified.
3061 This function searches the directories in `load-path'.
3062 If optional second arg NOERROR is non-nil,
3063 report no error if FILE doesn't exist.
3064 Print messages at start and end of loading unless
3065 optional third arg NOMESSAGE is non-nil (ignored in -batch mode).
3066 If optional fourth arg NOSUFFIX is non-nil, don't try adding
3067 suffixes `.elc' or `.el' to the specified name FILE.
3068 Return t if file exists."
3069 (load-internal file noerror nomessage nosuffix))
3070
3071 ;(define-key ctl-x-map "\C-f" 'find-file)
3072 ;(define-key ctl-x-map "\C-q" 'toggle-read-only)
3073 ;(define-key ctl-x-map "\C-r" 'find-file-read-only)
3074 ;(define-key ctl-x-map "\C-v" 'find-alternate-file)
3075 ;(define-key ctl-x-map "\C-s" 'save-buffer)
3076 ;(define-key ctl-x-map "s" 'save-some-buffers)
3077 ;(define-key ctl-x-map "\C-w" 'write-file)
3078 ;(define-key ctl-x-map "i" 'insert-file)
3079 ;(define-key esc-map "~" 'not-modified)
3080 ;(define-key ctl-x-map "\C-d" 'list-directory)
3081 ;(define-key ctl-x-map "\C-c" 'save-buffers-kill-emacs)
3082
3083 ;(define-key ctl-x-4-map "f" 'find-file-other-window)
3084 ;(define-key ctl-x-4-map "r" 'find-file-read-only-other-window)
3085 ;(define-key ctl-x-4-map "\C-f" 'find-file-other-window)
3086 ;(define-key ctl-x-4-map "b" 'switch-to-buffer-other-window)
3087 ;(define-key ctl-x-4-map "\C-o" 'display-buffer)
3088
3089 ;(define-key ctl-x-5-map "b" 'switch-to-buffer-other-frame)
3090 ;(define-key ctl-x-5-map "f" 'find-file-other-frame)
3091 ;(define-key ctl-x-5-map "\C-f" 'find-file-other-frame)
3092 ;(define-key ctl-x-5-map "r" 'find-file-read-only-other-frame)
3093
3094 ;;; files.el ends here 2909 ;;; files.el ends here
2910
2911
2912