git.chise.org Git - chise/xemacs-chise.git-/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 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 1 3001))
 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