1 ;;; code-files.el --- File I/O functions for XEmacs.
3 ;; Copyright (C) 1992,93,94,95 Free Software Foundation, Inc.
4 ;; Copyright (C) 1995 Amdahl Corporation.
5 ;; Copyright (C) 1995 Sun Microsystems.
7 ;; This file is part of SXEmacs.
9 ;; SXEmacs is free software: you can redistribute it and/or modify
10 ;; it under the terms of the GNU General Public License as published by
11 ;; the Free Software Foundation, either version 3 of the License, or
12 ;; (at your option) any later version.
14 ;; SXEmacs is distributed in the hope that it will be useful,
15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 ;; GNU General Public License for more details.
19 ;; You should have received a copy of the GNU General Public License
20 ;; along with this program. If not, see <http://www.gnu.org/licenses/>.
22 ;;; Synched up with: Not synched.
26 ;; Derived from mule.el in the original Mule but heavily modified
29 ;; 1997/3/11 modified by MORIOKA Tomohiko to sync with Emacs 20 API.
31 ;; This file was derived from the former mule-files.el which has been removed
32 ;; as of XEmacs 21.2.15.
36 (setq-default buffer-file-coding-system 'raw-text)
37 (put 'buffer-file-coding-system 'permanent-local t)
39 (define-obsolete-variable-alias
41 'buffer-file-coding-system)
43 (define-obsolete-variable-alias
44 'overriding-file-coding-system
45 'coding-system-for-read)
47 (defvar buffer-file-coding-system-for-read 'undecided
48 "Coding system used when reading a file.
49 This provides coarse-grained control; for finer-grained control, use
50 `file-coding-system-alist'. From a Lisp program, if you wish to
51 unilaterally specify the coding system used for one particular
52 operation, you should bind the variable `coding-system-for-read'
53 rather than setting this variable, which is intended to be used for
54 global environment specification.")
56 (define-obsolete-variable-alias
57 'file-coding-system-for-read
58 'buffer-file-coding-system-for-read)
60 (defvar file-coding-system-alist
62 ;; This must not be necessary, slb suggests -kkm
63 ;; ("loaddefs.el$" . (binary . binary))
65 #'(lambda (regexp) (cons regexp 'binary)) binary-file-regexps)
66 (#r"TUTORIAL\.\(?:hr\|pl\|ro\)\'" . iso-8859-2)
67 ;; ("\\.\\(el\\|emacs\\|info\\(-[0-9]+\\)?\\|texi\\)$" . iso-2022-8)
68 ;; ("\\(ChangeLog\\|CHANGES-beta\\)$" . iso-2022-8)
70 ;; This idea is totally broken, and the code didn't work anyway.
71 ;; Mailboxes should be decoded by mail clients, who actually know
72 ;; how to deal with them. Otherwise, their contents should be
73 ;; treated as `binary'.
74 ;("/spool/mail/.*$" . convert-mbox-coding-system)
76 "Alist to decide a coding system to use for a file I/O operation.
77 The format is ((PATTERN . VAL) ...),
78 where PATTERN is a regular expression matching a file name,
79 VAL is a coding system, a cons of coding systems, or a function symbol.
80 If VAL is a coding system, it is used for both decoding and encoding
82 If VAL is a cons of coding systems, the car part is used for decoding,
83 and the cdr part is used for encoding.
84 If VAL is a function symbol, the function must return a coding system
85 or a cons of coding systems which are used as above.
87 This overrides the more general specification in
88 `buffer-file-coding-system-for-read', but is overridden by
89 `coding-system-for-read'.")
91 (defun set-buffer-file-coding-system (coding-system &optional force)
92 "Set buffer-file-coding-system of the current buffer to CODING-SYSTEM.
93 If optional argument FORCE (interactively, the prefix argument) is not
94 given, attempt to match the EOL type of the new coding system to
95 the current value of `buffer-file-coding-system'."
96 (interactive "zFile coding system: \nP")
97 (get-coding-system coding-system) ;; correctness check
100 (subsidiary-coding-system
102 (coding-system-eol-type buffer-file-coding-system))))
103 (setq buffer-file-coding-system coding-system)
106 (defun toggle-buffer-file-coding-system ()
107 "Set EOL type of buffer-file-coding-system of the current buffer to
108 something other than what it is at the moment."
111 (coding-system-eol-type buffer-file-coding-system)))
112 (setq buffer-file-coding-system
113 (subsidiary-coding-system
114 (coding-system-base buffer-file-coding-system)
115 (cond ((eq eol-type 'lf) 'crlf)
116 ((eq eol-type 'crlf) 'lf)
117 ((eq eol-type 'cr) 'lf))))
118 (set-buffer-modified-p t)))
120 (define-obsolete-function-alias
121 'set-file-coding-system
122 'set-buffer-file-coding-system)
124 (defun set-buffer-file-coding-system-for-read (coding-system)
125 "Set the coding system used when reading in a file.
126 This is equivalent to setting the variable
127 `buffer-file-coding-system-for-read'. You can also use
128 `file-coding-system-alist' to specify the coding system for
130 (interactive "zFile coding system for read: ")
131 (get-coding-system coding-system) ;; correctness check
132 (setq buffer-file-coding-system-for-read coding-system))
134 (define-obsolete-function-alias
135 'set-file-coding-system-for-read
136 'set-buffer-file-coding-system-for-read)
138 (defun set-default-buffer-file-coding-system (coding-system)
139 "Set the default value of `buffer-file-coding-system' to CODING-SYSTEM.
140 The default value is used both for buffers without associated files
141 and for files with no apparent coding system (i.e. primarily ASCII).
142 See `buffer-file-coding-system' for more information."
143 (interactive "zDefault file coding system: ")
144 (setq-default buffer-file-coding-system coding-system)
147 (define-obsolete-function-alias
148 'set-default-file-coding-system
149 'set-default-buffer-file-coding-system)
151 (defun find-file-coding-system-for-read-from-filename (filename)
152 "Look up coding system to read a file in `file-coding-system-alist'.
153 The return value will be nil (no applicable entry) or a coding system
154 object (the entry specified a coding system)."
155 (let ((alist file-coding-system-alist)
158 (let ((case-fold-search nil))
159 (setq filename (file-name-sans-versions filename))
160 (while (and (not found) alist)
161 (if (string-match (car (car alist)) filename)
162 (setq codesys (cdr (car alist))
164 (setq alist (cdr alist))))
166 (if (functionp codesys)
167 (setq codesys (funcall codesys 'insert-file-contents filename))
169 (cond ((consp codesys) (find-coding-system (car codesys)))
170 ((find-coding-system codesys))
173 (define-obsolete-function-alias
174 'find-file-coding-system-from-filename
175 'find-file-coding-system-for-read-from-filename)
177 (defun find-file-coding-system-for-write-from-filename (filename)
178 "Look up coding system to write a file in `file-coding-system-alist'.
179 The return value will be nil (no applicable entry) or a coding system
180 object (the entry specified a coding system)."
181 (let ((alist file-coding-system-alist)
184 (let ((case-fold-search nil))
185 (setq filename (file-name-sans-versions filename))
186 (while (and (not found) alist)
187 (if (string-match (car (car alist)) filename)
188 (setq codesys (cdr (car alist))
190 (setq alist (cdr alist))))
192 (if (functionp codesys)
193 (setq codesys (funcall codesys 'write-region filename))
195 (cond ((consp codesys) (find-coding-system (cdr codesys)))
196 ((find-coding-system codesys))
199 ;; This was completely broken, not only in implementation (does not
200 ;; understand MIME), but in concept -- such high-level decoding should
201 ;; be done by mail readers, not by IO code! Removed 2000-04-18.
203 ;(defun convert-mbox-coding-system (filename visit start end) ...)
205 (defun find-coding-system-magic-cookie ()
206 "Look for the coding-system magic cookie in the current buffer.
207 The coding-system magic cookie is the exact string
208 \";;;###coding system: \" followed by a valid coding system symbol,
209 somewhere within the first 3000 characters of the file. If found,
210 the coding system symbol is returned; otherwise nil is returned.
211 Note that it is extremely unlikely that such a string would occur
212 coincidentally as the result of encoding some characters in a non-ASCII
213 charset, and that the spaces make it even less likely since the space
214 character is not a valid octet in any ISO 2022 encoding of most non-ASCII
217 (goto-char (point-min))
219 "^[^\n]*-\\*-[^\n]*coding: \\([^ \t\n;]+\\)[^\n]*-\\*-")
220 (let ((codesys (intern (buffer-substring
221 (match-beginning 1)(match-end 1)))))
222 (if (find-coding-system codesys) codesys)))
225 ;; (and (re-search-forward "^;+[ \t]*Local Variables:" nil t)
226 ;; (setq start (match-end 0))
227 ;; (re-search-forward "\n;+[ \t]*End:")
228 ;; (setq end (match-beginning 0))
230 ;; (narrow-to-region start end)
232 ;; (re-search-forward "^;;; coding: \\([^\n]+\\)$" nil t)
235 ;; (intern (buffer-substring
236 ;; (match-beginning 1)(match-end 1)))))
237 ;; (if (find-coding-system codesys) codesys))
239 (let ((case-fold-search nil))
241 ";;;###coding system: " (+ (point-min) 3000) t)
242 (let ((start (point))
244 (skip-chars-forward "^ \t\n\r")
247 (let ((codesys (intern (buffer-substring start end))))
248 (if (find-coding-system codesys) codesys)))
252 (defun load (file &optional noerror nomessage nosuffix)
253 "Execute a file of Lisp code named FILE.
254 First tries FILE with .elc appended, then tries with .el,
255 then tries FILE unmodified. Searches directories in load-path.
256 If optional second arg NOERROR is non-nil,
257 report no error if FILE doesn't exist.
258 Print messages at start and end of loading unless
259 optional third arg NOMESSAGE is non-nil.
260 If optional fourth arg NOSUFFIX is non-nil, don't try adding
261 suffixes .elc or .el to the specified name FILE.
262 Return t if file exists."
263 (let* ((filename (substitute-in-file-name file))
264 (handler (find-file-name-handler filename 'load))
267 (funcall handler 'load filename noerror nomessage nosuffix))
268 ((<= (length filename) 0)
270 (signal 'file-error (list "Cannot open load file" filename))))
271 ((setq path (locate-file filename load-path
272 (and (not nosuffix) '(".elc" ".el" ""))))
273 ;; now use the internal load to actually load the file.
275 file noerror nomessage nosuffix
277 ;; use string= instead of string-match to keep match-data.
278 (string= ".elc" (downcase (substring path -4)))))
279 (or (and (not elc) coding-system-for-read) ; prefer for source file
282 (set-buffer (get-buffer-create " *load*"))
284 (let ((coding-system-for-read 'raw-text))
285 (insert-file-contents path nil 0 3000))
286 (find-coding-system-magic-cookie))
288 ;; if reading a byte-compiled file and we didn't find
289 ;; a coding-system magic cookie, then use `binary'.
290 ;; We need to guarantee that we never do autodetection
291 ;; on byte-compiled files because confusion here would
292 ;; be a very bad thing. Pre-existing byte-compiled
293 ;; files are always in the `binary' coding system.
294 ;; Also, byte-compiled files always use `lf' to terminate
295 ;; a line; don't risk confusion here either.
297 (or (find-file-coding-system-for-read-from-filename path)
298 ;; looking up in `file-coding-system-alist'.
299 ;; otherwise use `buffer-file-coding-system-for-read',
301 buffer-file-coding-system-for-read)
303 ((setq path (locate-file filename load-path
305 (if (boundp 'module-extensions)
306 module-extensions))))
307 (if (featurep 'modules)
308 (let ((load-modules-quietly nomessage))
309 (declare-fboundp (load-module path)))
310 (signal 'file-error '("This SXEmacs does not support modules"))))
312 (signal 'file-error (list "Cannot open load file" filename))))))
314 (defvar insert-file-contents-access-hook nil
315 "A hook to make a file accessible before reading it.
316 `insert-file-contents' calls this hook before doing anything else.
317 Called with two arguments: FILENAME and VISIT, the same as the
318 corresponding arguments in the call to `insert-file-contents'.")
320 (defvar insert-file-contents-pre-hook nil
321 "A special hook to decide the coding system used for reading in a file.
323 Before reading a file, `insert-file-contents' calls the functions on
324 this hook with arguments FILENAME and VISIT, the same as the
325 corresponding arguments in the call to `insert-file-contents'. In
326 these functions, you may refer to the global variable
327 `buffer-file-coding-system-for-read'.
329 The return value of the functions should be either
332 -- A coding system or a symbol denoting it, indicating the coding system
333 to be used for reading the file
334 -- A list of two elements (absolute pathname and length of data inserted),
335 which is used as the return value to `insert-file-contents'. In this
336 case, `insert-file-contents' assumes that the function has inserted
337 the file for itself and suppresses further reading.
339 If any function returns non-nil, the remaining functions are not called.")
341 (defvar insert-file-contents-error-hook nil
342 "A hook to set `buffer-file-coding-system' when a read error has occurred.
344 When a file error (e.g. nonexistent file) occurs while read a file,
345 `insert-file-contents' calls the functions on this hook with three
346 arguments: FILENAME and VISIT (the same as the corresponding arguments
347 in the call to `insert-file-contents') and a cons (SIGNALED-CONDITIONS
350 After calling this hook, the error is signalled for real and
351 propagates to the caller of `insert-file-contents'.")
353 (defvar insert-file-contents-post-hook nil
354 "A hook to set `buffer-file-coding-system' for the current buffer.
356 After successful reading, `insert-file-contents' calls the functions
357 on this hook with four arguments: FILENAME and VISIT (the same as the
358 corresponding arguments in the call to `insert-file-contents'),
359 CODING-SYSTEM (the actual coding system used to decode the file), and
360 a cons of absolute pathname and length of data inserted (the same
361 thing as will be returned from `insert-file-contents').")
363 (defun insert-file-contents (filename &optional visit start end replace)
364 "Insert contents of file FILENAME after point.
365 Returns list of absolute file name and length of data inserted.
366 If second argument VISIT is non-nil, the buffer's visited filename
367 and last save file modtime are set, and it is marked unmodified.
368 If visiting and the file does not exist, visiting is completed
369 before the error is signaled.
371 The optional third and fourth arguments START and END
372 specify what portion of the file to insert.
373 If VISIT is non-nil, START and END must be nil.
374 If optional fifth argument REPLACE is non-nil,
375 it means replace the current buffer contents (in the accessible portion)
376 with the file contents. This is better than simply deleting and inserting
377 the whole thing because (1) it preserves some marker positions
378 and (2) it puts less data in the undo list.
380 The coding system used for decoding the file is determined as follows:
382 1. `coding-system-for-read', if non-nil.
383 2. The result of `insert-file-contents-pre-hook', if non-nil.
384 3. The matching value for this filename from
385 `file-coding-system-alist', if any.
386 4. `buffer-file-coding-system-for-read', if non-nil.
387 5. The coding system 'raw-text.
389 If a local value for `buffer-file-coding-system' in the current buffer
390 does not exist, it is set to the coding system which was actually used
393 See also `insert-file-contents-access-hook',
394 `insert-file-contents-pre-hook', `insert-file-contents-error-hook',
395 and `insert-file-contents-post-hook'."
396 (let (return-val coding-system used-codesys)
397 ;; OK, first load the file.
400 (run-hook-with-args 'insert-file-contents-access-hook
402 ;; determine the coding system to use, as described above.
406 coding-system-for-read
408 (run-hook-with-args-until-success
409 'insert-file-contents-pre-hook
412 (find-file-coding-system-for-read-from-filename filename)
414 buffer-file-coding-system-for-read
417 (if (consp coding-system)
418 (setq return-val coding-system)
419 (if (null (find-coding-system coding-system))
422 "Invalid coding-system (%s), using 'undecided"
424 (setq coding-system 'undecided)))
426 (insert-file-contents-internal filename visit start end
427 replace coding-system
432 (run-hook-with-args 'insert-file-contents-error-hook
434 (signal (car err) (cdr err))))
435 (setq coding-system used-codesys)
436 ;; call any `post-read-conversion' for the coding system that
439 (coding-system-property coding-system 'post-read-conversion))
440 (endmark (make-marker)))
441 (set-marker endmark (+ (point) (nth 1 return-val)))
445 (let (buffer-read-only)
446 (funcall func (point) (marker-position endmark))))
449 (set-buffer-auto-saved)
450 (set-buffer-modified-p nil)))))
451 (setcar (cdr return-val) (- (marker-position endmark) (point))))
452 ;; now finally set the buffer's `buffer-file-coding-system'.
453 (if (run-hook-with-args-until-success 'insert-file-contents-post-hook
454 filename visit return-val)
456 (if (local-variable-p 'buffer-file-coding-system (current-buffer))
457 ;; if buffer-file-coding-system is already local, just
458 ;; set its eol type to what was found, if it wasn't
460 (set-buffer-file-coding-system
461 (subsidiary-coding-system buffer-file-coding-system
462 (coding-system-eol-type coding-system)))
463 ;; otherwise actually set buffer-file-coding-system.
464 (set-buffer-file-coding-system coding-system)))
467 (defvar write-region-pre-hook nil
468 "A special hook to decide the coding system used for writing out a file.
470 Before writing a file, `write-region' calls the functions on this hook with
471 arguments START, END, FILENAME, APPEND, VISIT, LOCKNAME and CODING-SYSTEM,
472 the same as the corresponding arguments in the call to `write-region'.
474 The return value of each function should be one of
477 -- A coding system or a symbol denoting it, indicating the coding system
478 to be used for writing the file
479 -- A list of two elements (absolute pathname and length of data written),
480 which is used as the return value to `write-region'. In this case,
481 `write-region' assumes that the function has written the file and
484 If any function returns non-nil, the remaining functions are not called.")
486 (defvar write-region-post-hook nil
487 "A hook called by `write-region' after a file has been written out.
489 The functions on this hook are called with arguments START, END,
490 FILENAME, APPEND, VISIT, LOCKNAME, and CODING-SYSTEM, the same as the
491 corresponding arguments in the call to `write-region'.")
493 (defun write-region (start end filename
494 &optional append visit lockname coding-system)
495 "Write current region into specified file.
496 By default the file's existing contents are replaced by the specified region.
497 Called interactively, prompts for a file name. With a prefix arg, prompts
498 for a coding system as well.
500 When called from a program, takes three required arguments:
501 START, END and FILENAME. START and END are buffer positions.
502 Optional fourth argument APPEND if non-nil means
503 append to existing file contents (if any).
504 Optional fifth argument VISIT if t means
505 set last-save-file-modtime of buffer to this file's modtime
506 and mark buffer not modified.
507 If VISIT is a string, it is a second file name;
508 the output goes to FILENAME, but the buffer is marked as visiting VISIT.
509 VISIT is also the file name to lock and unlock for clash detection.
510 If VISIT is neither t nor nil nor a string,
511 that means do not print the \"Wrote file\" message.
512 The optional sixth arg LOCKNAME, if non-nil, specifies the name to
513 use for locking and unlocking, overriding FILENAME and VISIT.
514 Kludgy feature: if START is a string, then that string is written
515 to the file, instead of any buffer contents, and END is ignored.
516 Optional seventh argument CODING-SYSTEM specifies the coding system
517 used to encode the text when it is written out, and defaults to
518 the value of `buffer-file-coding-system' in the current buffer.
519 See also `write-region-pre-hook' and `write-region-post-hook'."
520 (interactive "r\nFWrite region to file: \ni\ni\ni\nZCoding-system: ")
522 (or coding-system-for-write
523 (run-hook-with-args-until-success
524 'write-region-pre-hook
525 start end filename append visit lockname coding-system)
527 buffer-file-coding-system
528 (find-file-coding-system-for-write-from-filename filename)
530 (if (consp coding-system)
531 ;; One of the `write-region-pre-hook' functions wrote the file
534 (coding-system-property coding-system 'pre-write-conversion)))
536 (let ((curbuf (current-buffer))
537 (tempbuf (generate-new-buffer " *temp-write-buffer*"))
538 (modif (buffer-modified-p)))
543 (insert-buffer-substring curbuf start end)
544 (funcall func (point-min) (point-max))
545 (write-region-internal (point-min) (point-max) filename
547 (if (eq visit t) nil visit)
550 ;; leaving a buffer associated with file will cause problems
551 ;; when next visiting.
552 (kill-buffer tempbuf)
553 (if (or visit (null modif))
555 (set-buffer-auto-saved)
556 (set-buffer-modified-p nil)
557 (if (buffer-file-name) (set-visited-file-modtime))))))
558 (write-region-internal start end filename append visit lockname
560 (run-hook-with-args 'write-region-post-hook
561 start end filename append visit lockname
564 ;;; code-files.el ends here