git.chise.org Git - chise/xemacs-chise.git.1/blob - 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 is 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!
 204
 205 ;(defun convert-mbox-coding-system (filename visit start end)
 206 ;...
 207
 208 (defun find-coding-system-magic-cookie ()
 209   "Look for the coding-system magic cookie in the current buffer.
 210 The coding-system magic cookie is the exact string
 211 \";;;###coding system: \" followed by a valid coding system symbol,
 212 somewhere within the first 3000 characters of the file.  If found,
 213 the coding system symbol is returned; otherwise nil is returned.
 214 Note that it is extremely unlikely that such a string would occur
 215 coincidentally as the result of encoding some characters in a non-ASCII
 216 charset, and that the spaces make it even less likely since the space
 217 character is not a valid octet in any ISO 2022 encoding of most non-ASCII
 218 charsets."
 219   (save-excursion
 220     (goto-char (point-min))
 221     (or (and (looking-at
 222               "^[^\n]*-\\*-[^\n]*coding: \\([^ \t\n;]+\\)[^\n]*-\\*-")
 223              (let ((codesys (intern (buffer-substring
 224                                      (match-beginning 1)(match-end 1)))))
 225                (if (find-coding-system codesys) codesys)))
 226         ;; (save-excursion
 227         ;;   (let (start end)
 228         ;;     (and (re-search-forward "^;+[ \t]*Local Variables:" nil t)
 229         ;;          (setq start (match-end 0))
 230         ;;          (re-search-forward "\n;+[ \t]*End:")
 231         ;;          (setq end (match-beginning 0))
 232         ;;          (save-restriction
 233         ;;            (narrow-to-region start end)
 234         ;;            (goto-char start)
 235         ;;            (re-search-forward "^;;; coding: \\([^\n]+\\)$" nil t)
 236         ;;            )
 237         ;;          (let ((codesys
 238         ;;                 (intern (buffer-substring
 239         ;;                          (match-beginning 1)(match-end 1)))))
 240         ;;            (if (find-coding-system codesys) codesys))
 241         ;;          )))
 242         (let ((case-fold-search nil))
 243           (if (search-forward
 244                ";;;###coding system: " (+ (point-min) 3000) t)
 245               (let ((start (point))
 246                     (end (progn
 247                            (skip-chars-forward "^ \t\n\r")
 248                            (point))))
 249                 (if (> end start)
 250                     (let ((codesys (intern (buffer-substring start end))))
 251                       (if (find-coding-system codesys) codesys)))
 252                 )))
 253         )))
 254
 255 (defun load (file &optional noerror nomessage nosuffix)
 256   "Execute a file of Lisp code named FILE.
 257 First tries FILE with .elc appended, then tries with .el,
 258  then tries FILE unmodified.  Searches directories in load-path.
 259 If optional second arg NOERROR is non-nil,
 260  report no error if FILE doesn't exist.
 261 Print messages at start and end of loading unless
 262  optional third arg NOMESSAGE is non-nil.
 263 If optional fourth arg NOSUFFIX is non-nil, don't try adding
 264  suffixes .elc or .el to the specified name FILE.
 265 Return t if file exists."
 266   (let* ((filename (substitute-in-file-name file))
 267          (handler (find-file-name-handler filename 'load))
 268          (path nil))
 269     (if handler
 270         (funcall handler 'load filename noerror nomessage nosuffix)
 271       (if (or (<= (length filename) 0)
 272               (null (setq path
 273                           (locate-file filename load-path
 274                                        (and (not nosuffix) '(".elc" ".el" ""))))))
 275           (and (null noerror)
 276                (signal 'file-error (list "Cannot open load file" filename)))
 277         ;; now use the internal load to actually load the file.
 278         (load-internal
 279          file noerror nomessage nosuffix
 280          (let ((elc ; use string= instead of string-match to keep match-data.
 281                 (string= ".elc" (downcase (substring path -4)))))
 282            (or (and (not elc) coding-system-for-read) ; prefer for source file
 283                ;; find magic-cookie
 284                (save-excursion
 285                  (set-buffer (get-buffer-create " *load*"))
 286                  (erase-buffer)
 287                  (let ((coding-system-for-read 'raw-text))
 288                    (insert-file-contents path nil 1 3001))
 289                  (find-coding-system-magic-cookie))
 290                (if elc
 291                    ;; if reading a byte-compiled file and we didn't find
 292                    ;; a coding-system magic cookie, then use `binary'.
 293                    ;; We need to guarantee that we never do autodetection
 294                    ;; on byte-compiled files because confusion here would
 295                    ;; be a very bad thing.  Pre-existing byte-compiled
 296                    ;; files are always in the `binary' coding system.
 297                    ;; Also, byte-compiled files always use `lf' to terminate
 298                    ;; a line; don't risk confusion here either.
 299                    'binary
 300                  (or (find-file-coding-system-for-read-from-filename path)
 301                      ;; looking up in `file-coding-system-alist'.
 302                      ;; otherwise use `buffer-file-coding-system-for-read',
 303                      ;; as normal
 304                      buffer-file-coding-system-for-read)
 305                  )))
 306          )))))
 307
 308 (defvar insert-file-contents-access-hook nil
 309   "A hook to make a file accessible before reading it.
 310 `insert-file-contents' calls this hook before doing anything else.
 311 Called with two arguments: FILENAME and VISIT, the same as the
 312 corresponding arguments in the call to `insert-file-contents'.")
 313
 314 (defvar insert-file-contents-pre-hook nil
 315   "A special hook to decide the coding system used for reading in a file.
 316
 317 Before reading a file, `insert-file-contents' calls the functions on
 318 this hook with arguments FILENAME and VISIT, the same as the
 319 corresponding arguments in the call to `insert-file-contents'.  In
 320 these functions, you may refer to the global variable
 321 `buffer-file-coding-system-for-read'.
 322
 323 The return value of the functions should be either
 324
 325 -- nil
 326 -- A coding system or a symbol denoting it, indicating the coding system
 327    to be used for reading the file
 328 -- A list of two elements (absolute pathname and length of data inserted),
 329    which is used as the return value to `insert-file-contents'.  In this
 330    case, `insert-file-contents' assumes that the function has inserted
 331    the file for itself and suppresses further reading.
 332
 333 If any function returns non-nil, the remaining functions are not called.")
 334
 335 (defvar insert-file-contents-error-hook nil
 336   "A hook to set `buffer-file-coding-system' when a read error has occurred.
 337
 338 When a file error (e.g. nonexistent file) occurs while read a file,
 339 `insert-file-contents' calls the functions on this hook with three
 340 arguments: FILENAME and VISIT (the same as the corresponding arguments
 341 in the call to `insert-file-contents') and a cons (SIGNALED-CONDITIONS
 342 . SIGNAL-DATA).
 343
 344 After calling this hook, the error is signalled for real and
 345 propagates to the caller of `insert-file-contents'.")
 346
 347 (defvar insert-file-contents-post-hook nil
 348   "A hook to set `buffer-file-coding-system' for the current buffer.
 349
 350 After successful reading, `insert-file-contents' calls the functions
 351 on this hook with four arguments: FILENAME and VISIT (the same as the
 352 corresponding arguments in the call to `insert-file-contents'),
 353 CODING-SYSTEM (the actual coding system used to decode the file), and
 354 a cons of absolute pathname and length of data inserted (the same
 355 thing as will be returned from `insert-file-contents').")
 356
 357 (defun insert-file-contents (filename &optional visit start end replace)
 358   "Insert contents of file FILENAME after point.
 359 Returns list of absolute file name and length of data inserted.
 360 If second argument VISIT is non-nil, the buffer's visited filename
 361 and last save file modtime are set, and it is marked unmodified.
 362 If visiting and the file does not exist, visiting is completed
 363 before the error is signaled.
 364
 365 The optional third and fourth arguments START and END
 366 specify what portion of the file to insert.
 367 If VISIT is non-nil, START and END must be nil.
 368 If optional fifth argument REPLACE is non-nil,
 369 it means replace the current buffer contents (in the accessible portion)
 370 with the file contents.  This is better than simply deleting and inserting
 371 the whole thing because (1) it preserves some marker positions
 372 and (2) it puts less data in the undo list.
 373
 374 The coding system used for decoding the file is determined as follows:
 375
 376 1. `coding-system-for-read', if non-nil.
 377 2. The result of `insert-file-contents-pre-hook', if non-nil.
 378 3. The matching value for this filename from
 379    `file-coding-system-alist', if any.
 380 4. `buffer-file-coding-system-for-read', if non-nil.
 381 5. The coding system 'raw-text.
 382
 383 If a local value for `buffer-file-coding-system' in the current buffer
 384 does not exist, it is set to the coding system which was actually used
 385 for reading.
 386
 387 See also `insert-file-contents-access-hook',
 388 `insert-file-contents-pre-hook', `insert-file-contents-error-hook',
 389 and `insert-file-contents-post-hook'."
 390   (let (return-val coding-system used-codesys)
 391     ;; OK, first load the file.
 392     (condition-case err
 393         (progn
 394           (run-hook-with-args 'insert-file-contents-access-hook
 395                               filename visit)
 396           ;; determine the coding system to use, as described above.
 397           (setq coding-system
 398                 (or
 399                  ;; #1.
 400                  coding-system-for-read
 401                  ;; #2.
 402                  (run-hook-with-args-until-success
 403                   'insert-file-contents-pre-hook
 404                   filename visit)
 405                  ;; #3.
 406                  (find-file-coding-system-for-read-from-filename filename)
 407                  ;; #4.
 408                  buffer-file-coding-system-for-read
 409                  ;; #5.
 410                  'raw-text))
 411           (if (consp coding-system)
 412               (setq return-val coding-system)
 413             (if (null (find-coding-system coding-system))
 414                 (progn
 415                   (message
 416                    "Invalid coding-system (%s), using 'undecided"
 417                    coding-system)
 418                   (setq coding-system 'undecided)))
 419             (setq return-val
 420                   (insert-file-contents-internal filename visit start end
 421                                                  replace coding-system
 422                                                  ;; store here!
 423                                                  'used-codesys))
 424             ))
 425       (file-error
 426        (run-hook-with-args 'insert-file-contents-error-hook
 427                            filename visit err)
 428        (signal (car err) (cdr err))))
 429     (setq coding-system used-codesys)
 430     ;; call any `post-read-conversion' for the coding system that
 431     ;; was used ...
 432     (let ((func
 433            (coding-system-property coding-system 'post-read-conversion))
 434           (endmark (make-marker)))
 435       (set-marker endmark (+ (point) (nth 1 return-val)))
 436       (if func
 437           (unwind-protect
 438               (save-excursion
 439                 (let (buffer-read-only)
 440                   (funcall func (point) (marker-position endmark))))
 441             (if visit
 442                 (progn
 443                   (set-buffer-auto-saved)
 444                   (set-buffer-modified-p nil)))))
 445       (setcar (cdr return-val) (- (marker-position endmark) (point))))
 446     ;; now finally set the buffer's `buffer-file-coding-system'.
 447     (if (run-hook-with-args-until-success 'insert-file-contents-post-hook
 448                                           filename visit return-val)
 449         nil
 450       (if (local-variable-p 'buffer-file-coding-system (current-buffer))
 451           ;; if buffer-file-coding-system is already local, just
 452           ;; set its eol type to what was found, if it wasn't
 453           ;; set already.
 454           (set-buffer-file-coding-system
 455            (subsidiary-coding-system buffer-file-coding-system
 456                                      (coding-system-eol-type coding-system)))
 457         ;; otherwise actually set buffer-file-coding-system.
 458         (set-buffer-file-coding-system coding-system)))
 459     return-val))
 460
 461 (defvar write-region-pre-hook nil
 462   "A special hook to decide the coding system used for writing out a file.
 463
 464 Before writing a file, `write-region' calls the functions on this hook
 465 with arguments START, END, FILENAME, APPEND, VISIT, and CODING-SYSTEM,
 466 the same as the corresponding arguments in the call to
 467 `write-region'.
 468
 469 The return value of the functions should be either
 470
 471 -- nil
 472 -- A coding system or a symbol denoting it, indicating the coding system
 473    to be used for reading the file
 474 -- A list of two elements (absolute pathname and length of data written),
 475    which is used as the return value to `write-region'.  In this
 476    case, `write-region' assumes that the function has written
 477    the file for itself and suppresses further writing.
 478
 479 If any function returns non-nil, the remaining functions are not called.")
 480
 481 (defvar write-region-post-hook nil
 482   "A hook called by `write-region' after a file has been written out.
 483
 484 The functions on this hook are called with arguments START, END,
 485 FILENAME, APPEND, VISIT, and CODING-SYSTEM, the same as the
 486 corresponding arguments in the call to `write-region'.")
 487
 488 (defun write-region (start end filename &optional append visit lockname coding-system)
 489   "Write current region into specified file.
 490 By default the file's existing contents are replaced by the specified region.
 491 When called from a program, takes three arguments:
 492 START, END and FILENAME.  START and END are buffer positions.
 493 Optional fourth argument APPEND if non-nil means
 494   append to existing file contents (if any).
 495 Optional fifth argument VISIT if t means
 496   set last-save-file-modtime of buffer to this file's modtime
 497   and mark buffer not modified.
 498 If VISIT is a string, it is a second file name;
 499   the output goes to FILENAME, but the buffer is marked as visiting VISIT.
 500   VISIT is also the file name to lock and unlock for clash detection.
 501 If VISIT is neither t nor nil nor a string,
 502   that means do not print the \"Wrote file\" message.
 503 The optional sixth arg LOCKNAME, if non-nil, specifies the name to
 504   use for locking and unlocking, overriding FILENAME and VISIT.
 505 Kludgy feature: if START is a string, then that string is written
 506 to the file, instead of any buffer contents, and END is ignored.
 507 Optional seventh argument CODING-SYSTEM specifies the coding system
 508   used to encode the text when it is written out, and defaults to
 509   the value of `buffer-file-coding-system' in the current buffer.
 510   Interactively, with a prefix arg, you will be prompted for the
 511   coding system.
 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 start end filename append visit lockname)
 518             coding-system
 519             buffer-file-coding-system
 520             (find-file-coding-system-for-write-from-filename filename)
 521             ))
 522   (if (consp coding-system)
 523       coding-system
 524     (let ((func
 525            (coding-system-property coding-system 'pre-write-conversion)))
 526       (if func
 527           (let ((curbuf (current-buffer))
 528                 (tempbuf (generate-new-buffer " *temp-write-buffer*"))
 529                 (modif (buffer-modified-p)))
 530             (unwind-protect
 531                 (save-excursion
 532                   (set-buffer tempbuf)
 533                   (erase-buffer)
 534                   (insert-buffer-substring curbuf start end)
 535                   (funcall func (point-min) (point-max))
 536                   (write-region-internal (point-min) (point-max) filename
 537                                          append
 538                                          (if (eq visit t) nil visit)
 539                                          lockname
 540                                          coding-system))
 541               ;; leaving a buffer associated with file will cause problems
 542               ;; when next visiting.
 543               (kill-buffer tempbuf)
 544               (if (or visit (null modif))
 545                   (progn
 546                     (set-buffer-auto-saved)
 547                     (set-buffer-modified-p nil)
 548                     (if (buffer-file-name) (set-visited-file-modtime))))))
 549         (write-region-internal start end filename append visit lockname
 550                                coding-system)))
 551     (run-hook-with-args 'write-region-post-hook
 552                         start end filename append visit lockname
 553                         coding-system)))
 554
 555 ;;; code-files.el ends here