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