Mercurial > hg > xemacs-beta

comparison lisp/code-files.el @ 428:3ecd8885ac67 r21-2-22

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-22
author cvs
date Mon, 13 Aug 2007 11:28:15 +0200
parents
children abe6d1db359e
comparison
equal deleted inserted replaced
427:0a0253eac470 428:3ecd8885ac67
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 ("/spool/mail/.*$" . convert-mbox-coding-system))
72 "Alist to decide a coding system to use for a file I/O operation.
73 The format is ((PATTERN . VAL) ...),
74 where PATTERN is a regular expression matching a file name,
75 VAL is a coding system, a cons of coding systems, or a function symbol.
76 If VAL is a coding system, it is used for both decoding and encoding
77 the file contents.
78 If VAL is a cons of coding systems, the car part is used for decoding,
79 and the cdr part is used for encoding.
80 If VAL is a function symbol, the function must return a coding system
81 or a cons of coding systems which are used as above.
82
83 This overrides the more general specification in
84 `buffer-file-coding-system-for-read', but is overridden by
85 `coding-system-for-read'.")
86
87 (defun set-buffer-file-coding-system (coding-system &optional force)
88 "Set buffer-file-coding-system of the current buffer to CODING-SYSTEM.
89 If optional argument FORCE (interactively, the prefix argument) is not
90 given, attempt to match the EOL type of the new coding system to
91 the current value of `buffer-file-coding-system'."
92 (interactive "zFile coding system: \nP")
93 (get-coding-system coding-system) ;; correctness check
94 (if (not force)
95 (setq coding-system
96 (subsidiary-coding-system
97 coding-system
98 (coding-system-eol-type buffer-file-coding-system))))
99 (setq buffer-file-coding-system coding-system)
100 (redraw-modeline t))
101
102 (defun toggle-buffer-file-coding-system ()
103 "Set EOL type of buffer-file-coding-system of the current buffer to
104 something other than what it is at the moment."
105 (interactive)
106 (let ((eol-type
107 (coding-system-eol-type buffer-file-coding-system)))
108 (setq buffer-file-coding-system
109 (subsidiary-coding-system
110 (coding-system-base buffer-file-coding-system)
111 (cond ((eq eol-type 'lf) 'crlf)
112 ((eq eol-type 'crlf) 'lf)
113 ((eq eol-type 'cr) 'lf))))))
114
115 (define-obsolete-function-alias
116 'set-file-coding-system
117 'set-buffer-file-coding-system)
118
119 (defun set-buffer-file-coding-system-for-read (coding-system)
120 "Set the coding system used when reading in a file.
121 This is equivalent to setting the variable
122 `buffer-file-coding-system-for-read'. You can also use
123 `file-coding-system-alist' to specify the coding system for
124 particular files."
125 (interactive "zFile coding system for read: ")
126 (get-coding-system coding-system) ;; correctness check
127 (setq buffer-file-coding-system-for-read coding-system))
128
129 (define-obsolete-function-alias
130 'set-file-coding-system-for-read
131 'set-buffer-file-coding-system-for-read)
132
133 (defun set-default-buffer-file-coding-system (coding-system)
134 "Set the default value of `buffer-file-coding-system' to CODING-SYSTEM.
135 The default value is used both for buffers without associated files
136 and for files with no apparent coding system (i.e. primarily ASCII).
137 See `buffer-file-coding-system' for more information."
138 (interactive "zDefault file coding system: ")
139 (setq-default buffer-file-coding-system coding-system)
140 (redraw-modeline t))
141
142 (define-obsolete-function-alias
143 'set-default-file-coding-system
144 'set-default-buffer-file-coding-system)
145
146 (defun find-file-coding-system-for-read-from-filename (filename)
147 "Look up coding system to read a file in `file-coding-system-alist'.
148 The return value will be nil (no applicable entry) or a coding system
149 object (the entry specified a coding system)."
150 (let ((alist file-coding-system-alist)
151 (found nil)
152 (codesys nil))
153 (let ((case-fold-search nil))
154 (setq filename (file-name-sans-versions filename))
155 (while (and (not found) alist)
156 (if (string-match (car (car alist)) filename)
157 (setq codesys (cdr (car alist))
158 found t))
159 (setq alist (cdr alist))))
160 (when codesys
161 (if (functionp codesys)
162 (setq codesys (funcall codesys 'insert-file-contents filename))
163 )
164 (cond ((consp codesys) (find-coding-system (car codesys)))
165 ((find-coding-system codesys))
166 ))))
167
168 (define-obsolete-function-alias
169 'find-file-coding-system-from-filename
170 'find-file-coding-system-for-read-from-filename)
171
172 (defun find-file-coding-system-for-write-from-filename (filename)
173 "Look up coding system to write a file in `file-coding-system-alist'.
174 The return value will be nil (no applicable entry) or a coding system
175 object (the entry specified a coding system)."
176 (let ((alist file-coding-system-alist)
177 (found nil)
178 (codesys nil))
179 (let ((case-fold-search nil))
180 (setq filename (file-name-sans-versions filename))
181 (while (and (not found) alist)
182 (if (string-match (car (car alist)) filename)
183 (setq codesys (cdr (car alist))
184 found t))
185 (setq alist (cdr alist))))
186 (when codesys
187 (if (functionp codesys)
188 (setq codesys (funcall codesys 'write-region filename))
189 )
190 (cond ((consp codesys) (find-coding-system (cdr codesys)))
191 ((find-coding-system codesys))
192 ))))
193
194 (defun convert-mbox-coding-system (filename visit start end)
195 "Decoding function for Unix mailboxes.
196 Does separate detection and decoding on each message, since each
197 message might be in a different encoding."
198 (let ((buffer-read-only nil))
199 (save-restriction
200 (narrow-to-region start end)
201 (goto-char (point-min))
202 (while (not (eobp))
203 (let ((start (point))
204 end)
205 (forward-char 1)
206 (if (re-search-forward "^From" nil 'move)
207 (beginning-of-line))
208 (setq end (point))
209 (decode-coding-region start end 'undecided))))))
210
211 (defun find-coding-system-magic-cookie ()
212 "Look for the coding-system magic cookie in the current buffer.\n"
213 "The coding-system magic cookie is the exact string\n"
214 "\";;;###coding system: \" followed by a valid coding system symbol,\n"
215 "somewhere within the first 3000 characters of the file. If found,\n"
216 "the coding system symbol is returned; otherwise nil is returned.\n"
217 "Note that it is extremely unlikely that such a string would occur\n"
218 "coincidentally as the result of encoding some characters in a non-ASCII\n"
219 "charset, and that the spaces make it even less likely since the space\n"
220 "character is not a valid octet in any ISO 2022 encoding of most non-ASCII\n"
221 "charsets."
222 (save-excursion
223 (goto-char (point-min))
224 (or (and (looking-at
225 "^[^\n]*-\\*-[^\n]*coding: \\([^ \t\n;]+\\)[^\n]*-\\*-")
226 (let ((codesys (intern (buffer-substring
227 (match-beginning 1)(match-end 1)))))
228 (if (find-coding-system codesys) codesys)))
229 ;; (save-excursion
230 ;; (let (start end)
231 ;; (and (re-search-forward "^;+[ \t]*Local Variables:" nil t)
232 ;; (setq start (match-end 0))
233 ;; (re-search-forward "\n;+[ \t]*End:")
234 ;; (setq end (match-beginning 0))
235 ;; (save-restriction
236 ;; (narrow-to-region start end)
237 ;; (goto-char start)
238 ;; (re-search-forward "^;;; coding: \\([^\n]+\\)$" nil t)
239 ;; )
240 ;; (let ((codesys
241 ;; (intern (buffer-substring
242 ;; (match-beginning 1)(match-end 1)))))
243 ;; (if (find-coding-system codesys) codesys))
244 ;; )))
245 (let ((case-fold-search nil))
246 (if (search-forward
247 ";;;###coding system: " (+ (point-min) 3000) t)
248 (let ((start (point))
249 (end (progn
250 (skip-chars-forward "^ \t\n\r")
251 (point))))
252 (if (> end start)
253 (let ((codesys (intern (buffer-substring start end))))
254 (if (find-coding-system codesys) codesys)))
255 )))
256 )))
257
258 (defun load (file &optional noerror nomessage nosuffix)
259 "Execute a file of Lisp code named FILE.
260 First tries FILE with .elc appended, then tries with .el,
261 then tries FILE unmodified. Searches directories in load-path.
262 If optional second arg NOERROR is non-nil,
263 report no error if FILE doesn't exist.
264 Print messages at start and end of loading unless
265 optional third arg NOMESSAGE is non-nil.
266 If optional fourth arg NOSUFFIX is non-nil, don't try adding
267 suffixes .elc or .el to the specified name FILE.
268 Return t if file exists."
269 (let* ((filename (substitute-in-file-name file))
270 (handler (find-file-name-handler filename 'load))
271 (path nil))
272 (if handler
273 (funcall handler 'load filename noerror nomessage nosuffix)
274 (if (or (<= (length filename) 0)
275 (null (setq path
276 (locate-file filename load-path
277 (and (not nosuffix) '(".elc" ".el" ""))))))
278 (and (null noerror)
279 (signal 'file-error (list "Cannot open load file" filename)))
280 ;; now use the internal load to actually load the file.
281 (load-internal
282 file noerror nomessage nosuffix
283 (let ((elc ; use string= instead of string-match to keep match-data.
284 (string= ".elc" (downcase (substring path -4)))))
285 (or (and (not elc) coding-system-for-read) ; prefer for source file
286 ;; find magic-cookie
287 (save-excursion
288 (set-buffer (get-buffer-create " *load*"))
289 (erase-buffer)
290 (let ((coding-system-for-read 'raw-text))
291 (insert-file-contents path nil 1 3001))
292 (find-coding-system-magic-cookie))
293 (if elc
294 ;; if reading a byte-compiled file and we didn't find
295 ;; a coding-system magic cookie, then use `binary'.
296 ;; We need to guarantee that we never do autodetection
297 ;; on byte-compiled files because confusion here would
298 ;; be a very bad thing. Pre-existing byte-compiled
299 ;; files are always in the `binary' coding system.
300 ;; Also, byte-compiled files always use `lf' to terminate
301 ;; a line; don't risk confusion here either.
302 'binary
303 (or (find-file-coding-system-for-read-from-filename path)
304 ;; looking up in `file-coding-system-alist'.
305 ;; otherwise use `buffer-file-coding-system-for-read',
306 ;; as normal
307 buffer-file-coding-system-for-read)
308 )))
309 )))))
310
311 (defvar insert-file-contents-access-hook nil
312 "A hook to make a file accessible before reading it.
313 `insert-file-contents' calls this hook before doing anything else.
314 Called with two arguments: FILENAME and VISIT, the same as the
315 corresponding arguments in the call to `insert-file-contents'.")
316
317 (defvar insert-file-contents-pre-hook nil
318 "A special hook to decide the coding system used for reading in a file.
319
320 Before reading a file, `insert-file-contents' calls the functions on
321 this hook with arguments FILENAME and VISIT, the same as the
322 corresponding arguments in the call to `insert-file-contents'. In
323 these functions, you may refer to the global variable
324 `buffer-file-coding-system-for-read'.
325
326 The return value of the functions should be either
327
328 -- nil
329 -- A coding system or a symbol denoting it, indicating the coding system
330 to be used for reading the file
331 -- A list of two elements (absolute pathname and length of data inserted),
332 which is used as the return value to `insert-file-contents'. In this
333 case, `insert-file-contents' assumes that the function has inserted
334 the file for itself and suppresses further reading.
335
336 If any function returns non-nil, the remaining functions are not called.")
337
338 (defvar insert-file-contents-error-hook nil
339 "A hook to set `buffer-file-coding-system' when a read error has occurred.
340
341 When a file error (e.g. nonexistent file) occurs while read a file,
342 `insert-file-contents' calls the functions on this hook with three
343 arguments: FILENAME and VISIT (the same as the corresponding arguments
344 in the call to `insert-file-contents') and a cons (SIGNALED-CONDITIONS
345 . SIGNAL-DATA).
346
347 After calling this hook, the error is signalled for real and
348 propagates to the caller of `insert-file-contents'.")
349
350 (defvar insert-file-contents-post-hook nil
351 "A hook to set `buffer-file-coding-system' for the current buffer.
352
353 After successful reading, `insert-file-contents' calls the functions
354 on this hook with four arguments: FILENAME and VISIT (the same as the
355 corresponding arguments in the call to `insert-file-contents'),
356 CODING-SYSTEM (the actual coding system used to decode the file), and
357 a cons of absolute pathname and length of data inserted (the same
358 thing as will be returned from `insert-file-contents').")
359
360 (defun insert-file-contents (filename &optional visit beg end replace)
361 "Insert contents of file FILENAME after point.
362 Returns list of absolute file name and length of data inserted.
363 If second argument VISIT is non-nil, the buffer's visited filename
364 and last save file modtime are set, and it is marked unmodified.
365 If visiting and the file does not exist, visiting is completed
366 before the error is signaled.
367
368 The optional third and fourth arguments BEG and END
369 specify what portion of the file to insert.
370 If VISIT is non-nil, BEG and END must be nil.
371 If optional fifth argument REPLACE is non-nil,
372 it means replace the current buffer contents (in the accessible portion)
373 with the file contents. This is better than simply deleting and inserting
374 the whole thing because (1) it preserves some marker positions
375 and (2) it puts less data in the undo list.
376
377 The coding system used for decoding the file is determined as follows:
378
379 1. `coding-system-for-read', if non-nil.
380 2. The result of `insert-file-contents-pre-hook', if non-nil.
381 3. The matching value for this filename from
382 `file-coding-system-alist', if any.
383 4. `buffer-file-coding-system-for-read', if non-nil.
384 5. The coding system 'raw-text.
385
386 If a local value for `buffer-file-coding-system' in the current buffer
387 does not exist, it is set to the coding system which was actually used
388 for reading.
389
390 See also `insert-file-contents-access-hook',
391 `insert-file-contents-pre-hook', `insert-file-contents-error-hook',
392 and `insert-file-contents-post-hook'."
393 (let (return-val coding-system used-codesys)
394 ;; OK, first load the file.
395 (condition-case err
396 (progn
397 (run-hook-with-args 'insert-file-contents-access-hook
398 filename visit)
399 ;; determine the coding system to use, as described above.
400 (setq coding-system
401 (or
402 ;; #1.
403 coding-system-for-read
404 ;; #2.
405 (run-hook-with-args-until-success
406 'insert-file-contents-pre-hook
407 filename visit)
408 ;; #3.
409 (find-file-coding-system-for-read-from-filename filename)
410 ;; #4.
411 buffer-file-coding-system-for-read
412 ;; #5.
413 'raw-text))
414 (if (consp coding-system)
415 (setq return-val coding-system)
416 (if (null (find-coding-system coding-system))
417 (progn
418 (message
419 "Invalid coding-system (%s), using 'undecided"
420 coding-system)
421 (setq coding-system 'undecided)))
422 (setq return-val
423 (insert-file-contents-internal filename visit beg end
424 replace coding-system
425 ;; store here!
426 'used-codesys))
427 ))
428 (file-error
429 (run-hook-with-args 'insert-file-contents-error-hook
430 filename visit err)
431 (signal (car err) (cdr err))))
432 (setq coding-system used-codesys)
433 ;; call any `post-read-conversion' for the coding system that
434 ;; was used ...
435 (let ((func
436 (coding-system-property coding-system 'post-read-conversion))
437 (endmark (make-marker)))
438 (set-marker endmark (+ (point) (nth 1 return-val)))
439 (if func
440 (unwind-protect
441 (save-excursion
442 (let (buffer-read-only)
443 (funcall func (point) (marker-position endmark))))
444 (if visit
445 (progn
446 (set-buffer-auto-saved)
447 (set-buffer-modified-p nil)))))
448 (setcar (cdr return-val) (- (marker-position endmark) (point))))
449 ;; now finally set the buffer's `buffer-file-coding-system'.
450 (if (run-hook-with-args-until-success 'insert-file-contents-post-hook
451 filename visit return-val)
452 nil
453 (if (local-variable-p 'buffer-file-coding-system (current-buffer))
454 ;; if buffer-file-coding-system is already local, just
455 ;; set its eol type to what was found, if it wasn't
456 ;; set already.
457 (set-buffer-file-coding-system
458 (subsidiary-coding-system buffer-file-coding-system
459 (coding-system-eol-type coding-system)))
460 ;; otherwise actually set buffer-file-coding-system.
461 (set-buffer-file-coding-system coding-system)))
462 return-val))
463
464 (defvar write-region-pre-hook nil
465 "A special hook to decide the coding system used for writing out a file.
466
467 Before writing a file, `write-region' calls the functions on this hook
468 with arguments START, END, FILENAME, APPEND, VISIT, and CODING-SYSTEM,
469 the same as the corresponding arguments in the call to
470 `write-region'.
471
472 The return value of the functions should be either
473
474 -- nil
475 -- A coding system or a symbol denoting it, indicating the coding system
476 to be used for reading the file
477 -- A list of two elements (absolute pathname and length of data written),
478 which is used as the return value to `write-region'. In this
479 case, `write-region' assumes that the function has written
480 the file for itself and suppresses further writing.
481
482 If any function returns non-nil, the remaining functions are not called.")
483
484 (defvar write-region-post-hook nil
485 "A hook called by `write-region' after a file has been written out.
486
487 The functions on this hook are called with arguments START, END,
488 FILENAME, APPEND, VISIT, and CODING-SYSTEM, the same as the
489 corresponding arguments in the call to `write-region'.")
490
491 (defun write-region (start end filename &optional append visit lockname coding-system)
492 "Write current region into specified file.
493 By default the file's existing contents are replaced by the specified region.
494 When called from a program, takes three arguments:
495 START, END and FILENAME. START and END are buffer positions.
496 Optional fourth argument APPEND if non-nil means
497 append to existing file contents (if any).
498 Optional fifth argument VISIT if t means
499 set last-save-file-modtime of buffer to this file's modtime
500 and mark buffer not modified.
501 If VISIT is a string, it is a second file name;
502 the output goes to FILENAME, but the buffer is marked as visiting VISIT.
503 VISIT is also the file name to lock and unlock for clash detection.
504 If VISIT is neither t nor nil nor a string,
505 that means do not print the \"Wrote file\" message.
506 The optional sixth arg LOCKNAME, if non-nil, specifies the name to
507 use for locking and unlocking, overriding FILENAME and VISIT.
508 Kludgy feature: if START is a string, then that string is written
509 to the file, instead of any buffer contents, and END is ignored.
510 Optional seventh argument CODING-SYSTEM specifies the coding system
511 used to encode the text when it is written out, and defaults to
512 the value of `buffer-file-coding-system' in the current buffer.
513 Interactively, with a prefix arg, you will be prompted for the
514 coding system.
515 See also `write-region-pre-hook' and `write-region-post-hook'."
516 (interactive "r\nFWrite region to file: \ni\ni\ni\nZCoding-system: ")
517 (setq coding-system
518 (or coding-system-for-write
519 (run-hook-with-args-until-success
520 'write-region-pre-hook start end filename append visit lockname)
521 coding-system
522 buffer-file-coding-system
523 (find-file-coding-system-for-write-from-filename filename)
524 ))
525 (if (consp coding-system)
526 coding-system
527 (let ((func
528 (coding-system-property coding-system 'pre-write-conversion)))
529 (if func
530 (let ((curbuf (current-buffer))
531 (tempbuf (generate-new-buffer " *temp-write-buffer*"))
532 (modif (buffer-modified-p)))
533 (unwind-protect
534 (save-excursion
535 (set-buffer tempbuf)
536 (erase-buffer)
537 (insert-buffer-substring curbuf start end)
538 (funcall func (point-min) (point-max))
539 (write-region-internal (point-min) (point-max) filename
540 append
541 (if (eq visit t) nil visit)
542 lockname
543 coding-system))
544 ;; leaving a buffer associated with file will cause problems
545 ;; when next visiting.
546 (kill-buffer tempbuf)
547 (if (or visit (null modif))
548 (progn
549 (set-buffer-auto-saved)
550 (set-buffer-modified-p nil)
551 (if (buffer-file-name) (set-visited-file-modtime))))))
552 (write-region-internal start end filename append visit lockname
553 coding-system)))
554 (run-hook-with-args 'write-region-post-hook
555 start end filename append visit lockname
556 coding-system)))
557
558 ;;; The following was all that remained in mule-files.el, so I moved it
559 ;;; here for neatness. -sb
560 (when (featurep 'mule)
561 (setq-default buffer-file-coding-system 'iso-2022-8))
562
563 ;;; code-files.el ends here