poe/pces-20.el

   1 ;;; -*-byte-compile-dynamic: t;-*-
   2 ;;; pces-20.el --- pces submodule for Emacs 20 and XEmacs with coding-system
   3
   4 ;; Copyright (C) 1997,1998,1999 Free Software Foundation, Inc.
   5
   6 ;; Author: MORIOKA Tomohiko <tomo@m17n.org>
   7 ;; Keywords: emulation, compatibility, Mule
   8
   9 ;; This file is part of APEL (A Portable Emacs Library).
  10
  11 ;; This program is free software; you can redistribute it and/or
  12 ;; modify it under the terms of the GNU General Public License as
  13 ;; published by the Free Software Foundation; either version 2, or (at
  14 ;; your option) any later version.
  15
  16 ;; This program 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 GNU Emacs; 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 ;;    This module requires Emacs 20.0.93, XEmacs 20.3-b5 (with mule)
  29 ;;    or later.
  30
  31 ;;; Code:
  32
  33 ;; (defun-maybe-cond multibyte-string-p (object)
  34 ;;   "Return t if OBJECT is a multibyte string."
  35 ;;   ((featurep 'mule) (stringp object))
  36 ;;   (t                nil))
  37
  38
  39 ;;; @ without code-conversion
  40 ;;;
  41
  42 (defmacro as-binary-process (&rest body)
  43   `(let (selective-display      ; Disable ^M to nl translation.
  44          (coding-system-for-read  'binary)
  45          (coding-system-for-write 'binary))
  46      ,@body))
  47
  48 (defmacro as-binary-input-file (&rest body)
  49   `(let ((coding-system-for-read 'binary))
  50      ,@body))
  51
  52 (defmacro as-binary-output-file (&rest body)
  53   `(let ((coding-system-for-write 'binary))
  54      ,@body))
  55
  56 (defun write-region-as-binary (start end filename
  57                                      &optional append visit lockname)
  58   "Like `write-region', q.v., but don't encode."
  59   (let ((coding-system-for-write 'binary)
  60         jka-compr-compression-info-list jam-zcat-filename-list)
  61     (write-region start end filename append visit lockname)))
  62
  63 (require 'broken)
  64
  65 (broken-facility insert-file-contents-literally-treats-binary
  66   "Function `insert-file-contents-literally' decodes text."
  67   (let* ((str "\r\n")
  68          (coding-system-for-write 'binary)
  69          (coding-system-for-read 'raw-text-dos)
  70          ;; (default-enable-multibyte-characters (multibyte-string-p str))
  71          )
  72     (with-temp-buffer
  73       (insert str)
  74       (write-region (point-min)(point-max) "literal-test-file")
  75       )
  76     (string=
  77      (with-temp-buffer
  78        (let (file-name-handler-alist)
  79          (insert-file-contents-literally "literal-test-file")
  80          )
  81        (buffer-string)
  82        )
  83      str)))
  84
  85 (broken-facility insert-file-contents-literally-treats-file-name-handler
  86   "Function `insert-file-contents' doesn't call file-name-handler."
  87   (let (called)
  88     (with-temp-buffer
  89       (let ((file-name-handler-alist
  90              '(("literal-test-file" . (lambda (operation &rest args)
  91                                         (setq called t)
  92                                         (let (file-name-handler-alist)
  93                                           (apply operation args)
  94                                           ))))))
  95         (insert-file-contents-literally "literal-test-file")
  96         )
  97       (delete-file "literal-test-file")
  98       )
  99     called))
 100
 101 (static-if
 102     (or (broken-p 'insert-file-contents-literally-treats-binary)
 103         (broken-p 'insert-file-contents-literally-treats-file-name-handler))
 104     (defun insert-file-contents-as-binary (filename
 105                                            &optional visit beg end replace)
 106       "Like `insert-file-contents', but only reads in the file literally.
 107 A buffer may be modified in several ways after reading into the buffer,
 108 to Emacs features such as format decoding, character code
 109 conversion, find-file-hooks, automatic uncompression, etc.
 110
 111 This function ensures that none of these modifications will take place."
 112       (let ((format-alist nil)
 113             (after-insert-file-functions nil)
 114             (coding-system-for-read 'binary)
 115             (coding-system-for-write 'binary)
 116             (jka-compr-compression-info-list nil)
 117             (jam-zcat-filename-list nil)
 118             (find-buffer-file-type-function
 119              (if (fboundp 'find-buffer-file-type)
 120                  (symbol-function 'find-buffer-file-type)
 121                nil)))
 122         (unwind-protect
 123             (progn
 124               (fset 'find-buffer-file-type (lambda (filename) t))
 125               (insert-file-contents filename visit beg end replace))
 126           (if find-buffer-file-type-function
 127               (fset 'find-buffer-file-type find-buffer-file-type-function)
 128             (fmakunbound 'find-buffer-file-type)))))
 129   (defalias 'insert-file-contents-as-binary 'insert-file-contents-literally)
 130   )
 131
 132 (defun insert-file-contents-as-raw-text (filename
 133                                          &optional visit beg end replace)
 134   "Like `insert-file-contents', q.v., but don't code and format conversion.
 135 Like `insert-file-contents-literary', but it allows find-file-hooks,
 136 automatic uncompression, etc.
 137 Like `insert-file-contents-as-binary', but it converts line-break
 138 code."
 139   (let ((coding-system-for-read 'raw-text)
 140         format-alist)
 141     ;; Returns list of absolute file name and length of data inserted.
 142     (insert-file-contents filename visit beg end replace)))
 143
 144 (defun insert-file-contents-as-raw-text-CRLF (filename
 145                                               &optional visit beg end replace)
 146   "Like `insert-file-contents', q.v., but don't code and format conversion.
 147 Like `insert-file-contents-literary', but it allows find-file-hooks,
 148 automatic uncompression, etc.
 149 Like `insert-file-contents-as-binary', but it converts line-break code
 150 from CRLF to LF."
 151   (let ((coding-system-for-read 'raw-text-dos)
 152         format-alist)
 153     ;; Returns list of absolute file name and length of data inserted.
 154     (insert-file-contents filename visit beg end replace)))
 155
 156 (defun write-region-as-raw-text-CRLF (start end filename
 157                                             &optional append visit lockname)
 158   "Like `write-region', q.v., but write as network representation."
 159   (let ((coding-system-for-write 'raw-text-dos))
 160     (write-region start end filename append visit lockname)))
 161
 162 (defun find-file-noselect-as-binary (filename &optional nowarn rawfile)
 163   "Like `find-file-noselect', q.v., but don't code and format conversion."
 164   (let ((coding-system-for-read 'binary)
 165         format-alist)
 166     (find-file-noselect filename nowarn rawfile)))
 167
 168 (defun find-file-noselect-as-raw-text (filename &optional nowarn rawfile)
 169   "Like `find-file-noselect', q.v., but it does not code and format conversion
 170 except for line-break code."
 171   (let ((coding-system-for-read 'raw-text)
 172         format-alist)
 173     (find-file-noselect filename nowarn rawfile)))
 174
 175 (defun find-file-noselect-as-raw-text-CRLF (filename &optional nowarn rawfile)
 176   "Like `find-file-noselect', q.v., but it does not code and format conversion
 177 except for line-break code."
 178   (let ((coding-system-for-read 'raw-text-dos)
 179         format-alist)
 180     (find-file-noselect filename nowarn rawfile)))
 181
 182 (defun save-buffer-as-binary (&optional args)
 183   "Like `save-buffer', q.v., but don't encode."
 184   (let ((coding-system-for-write 'binary))
 185     (save-buffer args)))
 186
 187 (defun save-buffer-as-raw-text-CRLF (&optional args)
 188   "Like `save-buffer', q.v., but save as network representation."
 189   (let ((coding-system-for-write 'raw-text-dos))
 190     (save-buffer args)))
 191
 192 (defun open-network-stream-as-binary (name buffer host service)
 193   "Like `open-network-stream', q.v., but don't code conversion."
 194   (let ((coding-system-for-read 'binary)
 195         (coding-system-for-write 'binary))
 196     (open-network-stream name buffer host service)))
 197
 198
 199 ;;; @ with code-conversion
 200 ;;;
 201
 202 (defun insert-file-contents-as-coding-system
 203   (coding-system filename &optional visit beg end replace)
 204   "Like `insert-file-contents', q.v., but CODING-SYSTEM the first arg will
 205 be applied to `coding-system-for-read'."
 206   (let ((coding-system-for-read coding-system)
 207         format-alist)
 208     (insert-file-contents filename visit beg end replace)))
 209
 210 (defun write-region-as-coding-system
 211   (coding-system start end filename &optional append visit lockname)
 212   "Like `write-region', q.v., but CODING-SYSTEM the first arg will be
 213 applied to `coding-system-for-write'."
 214   (let ((coding-system-for-write coding-system)
 215         jka-compr-compression-info-list jam-zcat-filename-list)
 216     (write-region start end filename append visit lockname)))
 217
 218 (defun find-file-noselect-as-coding-system
 219   (coding-system filename &optional nowarn rawfile)
 220   "Like `find-file-noselect', q.v., but CODING-SYSTEM the first arg will
 221 be applied to `coding-system-for-read'."
 222   (let ((coding-system-for-read coding-system)
 223         format-alist)
 224     (find-file-noselect filename nowarn rawfile)))
 225
 226 (defun save-buffer-as-coding-system (coding-system &optional args)
 227   "Like `save-buffer', q.v., but CODING-SYSTEM the first arg will be
 228 applied to `coding-system-for-write'."
 229   (let ((coding-system-for-write coding-system))
 230     (save-buffer args)))
 231
 232
 233 ;;; @ end
 234 ;;;
 235
 236 (require 'product)
 237 (product-provide (provide 'pces-20) (require 'apel-ver))
 238
 239 ;;; pces-20.el ends here