Mercurial > hg > xemacs-beta

comparison lisp/code-files.el @ 259:11cf20601dec r20-5b28

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