[7238] | 1 | ;;; pces-om.el --- pces implementation for Mule 1.* and Mule 2.* |
---|
| 2 | |
---|
| 3 | ;; Copyright (C) 1995,1996,1997,1998,1999 Free Software Foundation, Inc. |
---|
| 4 | |
---|
| 5 | ;; Author: MORIOKA Tomohiko <tomo@m17n.org> |
---|
| 6 | ;; Katsumi Yamaoka <yamaoka@jpl.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 | ;;; Code: |
---|
| 27 | |
---|
| 28 | (require 'poe) |
---|
| 29 | |
---|
| 30 | |
---|
| 31 | ;;; @ version specific features |
---|
| 32 | ;;; |
---|
| 33 | |
---|
| 34 | (cond ((= emacs-major-version 19) |
---|
| 35 | (define-ccl-program poem-ccl-decode-raw-text |
---|
| 36 | '(1 |
---|
| 37 | ((r2 = 0) |
---|
| 38 | (read r0) |
---|
| 39 | (loop |
---|
| 40 | (if (r0 == ?\x0d) |
---|
| 41 | ((r2 = 1) |
---|
| 42 | (read-if (r1 == ?\x0a) |
---|
| 43 | ((r0 = ?\x0a) |
---|
| 44 | (r2 = 0) |
---|
| 45 | (write-read-repeat r0)) |
---|
| 46 | ((write r0) |
---|
| 47 | (r0 = (r1 + 0)) |
---|
| 48 | (repeat)))) |
---|
| 49 | ((r2 = 0) |
---|
| 50 | (write-read-repeat r0))))) |
---|
| 51 | ;; This EOF BLOCK won't work out in practice. So the last datum |
---|
| 52 | ;; might be lost if it's value is ?\x0d. |
---|
| 53 | (if r2 |
---|
| 54 | (write r0)) |
---|
| 55 | ) |
---|
| 56 | "Convert line-break code from CRLF to LF.") |
---|
| 57 | |
---|
| 58 | (define-ccl-program poem-ccl-encode-raw-text |
---|
| 59 | '(1 |
---|
| 60 | ((read r0) |
---|
| 61 | (loop (write-read-repeat r0)))) |
---|
| 62 | "Pass through without any conversions.") |
---|
| 63 | |
---|
| 64 | (define-ccl-program poem-ccl-encode-raw-text-CRLF |
---|
| 65 | '(2 |
---|
| 66 | ((loop |
---|
| 67 | (read-if (r0 == ?\x0a) |
---|
| 68 | (write "\x0d\x0a") |
---|
| 69 | (write r0)) |
---|
| 70 | (repeat)))) |
---|
| 71 | "Convert line-break code from LF to CRLF.") |
---|
| 72 | |
---|
| 73 | (make-coding-system |
---|
| 74 | 'raw-text 4 ?= |
---|
| 75 | "No conversion" |
---|
| 76 | nil |
---|
| 77 | (cons poem-ccl-decode-raw-text poem-ccl-encode-raw-text)) |
---|
| 78 | |
---|
| 79 | (make-coding-system |
---|
| 80 | 'raw-text-dos 4 ?= |
---|
| 81 | "No conversion" |
---|
| 82 | nil |
---|
| 83 | (cons poem-ccl-decode-raw-text poem-ccl-encode-raw-text-CRLF)) |
---|
| 84 | ) |
---|
| 85 | (t |
---|
| 86 | (defun poem-decode-raw-text (from to) |
---|
| 87 | (save-restriction |
---|
| 88 | (narrow-to-region from to) |
---|
| 89 | (goto-char (point-min)) |
---|
| 90 | (while (re-search-forward "\r$" nil t) |
---|
| 91 | (replace-match "") |
---|
| 92 | ))) |
---|
| 93 | (defun poem-encode-raw-text-CRLF (from to) |
---|
| 94 | (save-restriction |
---|
| 95 | (narrow-to-region from to) |
---|
| 96 | (goto-char (point-min)) |
---|
| 97 | (while (re-search-forward "\\(\\=\\|[^\r]\\)\n" nil t) |
---|
| 98 | (replace-match "\\1\r\n") |
---|
| 99 | ))) |
---|
| 100 | |
---|
| 101 | (make-coding-system 'raw-text nil ?= "No conversion") |
---|
| 102 | (put 'raw-text 'post-read-conversion 'poem-decode-raw-text) |
---|
| 103 | |
---|
| 104 | (make-coding-system 'raw-text-dos nil ?= "No conversion") |
---|
| 105 | (put 'raw-text-dos 'post-read-conversion 'poem-decode-raw-text) |
---|
| 106 | (put 'raw-text-dos 'pre-write-conversion 'poem-encode-raw-text-CRLF) |
---|
| 107 | )) |
---|
| 108 | |
---|
| 109 | |
---|
| 110 | ;;; @ coding system |
---|
| 111 | ;;; |
---|
| 112 | |
---|
| 113 | (defun-maybe find-coding-system (obj) |
---|
| 114 | "Return OBJ if it is a coding-system." |
---|
| 115 | (if (coding-system-p obj) |
---|
| 116 | obj)) |
---|
| 117 | |
---|
| 118 | (defun encode-coding-region (start end coding-system) |
---|
| 119 | "Encode the text between START and END to CODING-SYSTEM. |
---|
| 120 | \[EMACS 20 emulating function]" |
---|
| 121 | ;; If `coding-system' is nil, do nothing. |
---|
| 122 | (code-convert-region start end *internal* coding-system)) |
---|
| 123 | |
---|
| 124 | (defun decode-coding-region (start end coding-system) |
---|
| 125 | "Decode the text between START and END which is encoded in CODING-SYSTEM. |
---|
| 126 | \[EMACS 20 emulating function]" |
---|
| 127 | ;; If `coding-system' is nil, do nothing. |
---|
| 128 | (code-convert-region start end coding-system *internal*)) |
---|
| 129 | |
---|
| 130 | ;; XXX: Should we support optional NOCOPY argument? (only in Emacs 20.x) |
---|
| 131 | (defun encode-coding-string (str coding-system) |
---|
| 132 | "Encode the STRING to CODING-SYSTEM. |
---|
| 133 | \[EMACS 20 emulating function]" |
---|
| 134 | (if coding-system |
---|
| 135 | (code-convert-string str *internal* coding-system) |
---|
| 136 | ;;(code-convert-string str *internal* nil) returns nil instead of str. |
---|
| 137 | str)) |
---|
| 138 | |
---|
| 139 | ;; XXX: Should we support optional NOCOPY argument? (only in Emacs 20.x) |
---|
| 140 | (defun decode-coding-string (str coding-system) |
---|
| 141 | "Decode the string STR which is encoded in CODING-SYSTEM. |
---|
| 142 | \[EMACS 20 emulating function]" |
---|
| 143 | (if coding-system |
---|
| 144 | (let ((len (length str)) |
---|
| 145 | ret) |
---|
| 146 | (while (and (< 0 len) |
---|
| 147 | (null (setq ret |
---|
| 148 | (code-convert-string |
---|
| 149 | (substring str 0 len) |
---|
| 150 | coding-system *internal*)))) |
---|
| 151 | (setq len (1- len))) |
---|
| 152 | (concat ret (substring str len))) |
---|
| 153 | str)) |
---|
| 154 | |
---|
| 155 | (defalias 'detect-coding-region 'code-detect-region) |
---|
| 156 | |
---|
| 157 | (defalias 'set-buffer-file-coding-system 'set-file-coding-system) |
---|
| 158 | |
---|
| 159 | |
---|
| 160 | ;;; @ with code-conversion |
---|
| 161 | ;;; |
---|
| 162 | |
---|
| 163 | (cond |
---|
| 164 | ((and (>= emacs-major-version 19) (>= emacs-minor-version 23)) |
---|
| 165 | ;; Mule 2.0 or later. |
---|
| 166 | (defun insert-file-contents-as-coding-system |
---|
| 167 | (coding-system filename &optional visit beg end replace) |
---|
| 168 | "Like `insert-file-contents', q.v., but CODING-SYSTEM the first arg will |
---|
| 169 | be applied to `file-coding-system-for-read'." |
---|
| 170 | (let ((file-coding-system-for-read coding-system)) |
---|
| 171 | (insert-file-contents filename visit beg end replace)))) |
---|
| 172 | (t |
---|
| 173 | ;; Mule 1.1 or earlier. |
---|
| 174 | (defun insert-file-contents-as-coding-system |
---|
| 175 | (coding-system filename &optional visit beg end replace) |
---|
| 176 | "Like `insert-file-contents', q.v., but CODING-SYSTEM the first arg will |
---|
| 177 | be applied to `file-coding-system-for-read'." |
---|
| 178 | (let ((file-coding-system-for-read coding-system)) |
---|
| 179 | (insert-file-contents filename visit))))) |
---|
| 180 | |
---|
| 181 | (cond |
---|
| 182 | ((and (>= emacs-major-version 19) (>= emacs-minor-version 29)) |
---|
| 183 | ;; for MULE 2.3 based on Emacs 19.34. |
---|
| 184 | (defun write-region-as-coding-system |
---|
| 185 | (coding-system start end filename &optional append visit lockname) |
---|
| 186 | "Like `write-region', q.v., but CODING-SYSTEM the first arg will be |
---|
| 187 | applied to `file-coding-system'." |
---|
| 188 | (let ((file-coding-system coding-system) |
---|
| 189 | jka-compr-compression-info-list jam-zcat-filename-list) |
---|
| 190 | (write-region start end filename append visit lockname))) |
---|
| 191 | |
---|
| 192 | (defun find-file-noselect-as-coding-system |
---|
| 193 | (coding-system filename &optional nowarn rawfile) |
---|
| 194 | "Like `find-file-noselect', q.v., but CODING-SYSTEM the first arg will |
---|
| 195 | be applied to `file-coding-system-for-read'." |
---|
| 196 | (let ((file-coding-system-for-read coding-system)) |
---|
| 197 | (find-file-noselect filename nowarn rawfile))) |
---|
| 198 | ) |
---|
| 199 | (t |
---|
| 200 | ;; for MULE 2.3 based on Emacs 19.28 or MULE 1.*. |
---|
| 201 | (defun write-region-as-coding-system |
---|
| 202 | (coding-system start end filename &optional append visit lockname) |
---|
| 203 | "Like `write-region', q.v., but CODING-SYSTEM the first arg will be |
---|
| 204 | applied to `file-coding-system'." |
---|
| 205 | (let ((file-coding-system coding-system) |
---|
| 206 | jka-compr-compression-info-list jam-zcat-filename-list) |
---|
| 207 | (write-region start end filename append visit))) |
---|
| 208 | |
---|
| 209 | (defun find-file-noselect-as-coding-system |
---|
| 210 | (coding-system filename &optional nowarn rawfile) |
---|
| 211 | "Like `find-file-noselect', q.v., but CODING-SYSTEM the first arg will |
---|
| 212 | be applied to `file-coding-system-for-read'." |
---|
| 213 | (let ((file-coding-system-for-read coding-system)) |
---|
| 214 | (find-file-noselect filename nowarn))) |
---|
| 215 | )) |
---|
| 216 | |
---|
| 217 | (defun save-buffer-as-coding-system (coding-system &optional args) |
---|
| 218 | "Like `save-buffer', q.v., but CODING-SYSTEM the first arg will be |
---|
| 219 | applied to `coding-system-for-write'." |
---|
| 220 | (let ((file-coding-system coding-system)) |
---|
| 221 | (save-buffer args))) |
---|
| 222 | |
---|
| 223 | |
---|
| 224 | ;;; @ without code-conversion |
---|
| 225 | ;;; |
---|
| 226 | |
---|
| 227 | (make-coding-system 'binary nil ?= "No conversion") |
---|
| 228 | |
---|
| 229 | (defmacro as-binary-process (&rest body) |
---|
| 230 | (` (let (selective-display ; Disable ^M to nl translation. |
---|
| 231 | ;; Mule |
---|
| 232 | mc-flag |
---|
| 233 | (default-process-coding-system (cons *noconv* *noconv*)) |
---|
| 234 | program-coding-system-alist) |
---|
| 235 | (,@ body)))) |
---|
| 236 | |
---|
| 237 | (defmacro as-binary-input-file (&rest body) |
---|
| 238 | (` (let (mc-flag |
---|
| 239 | (file-coding-system-for-read *noconv*) |
---|
| 240 | ) |
---|
| 241 | (,@ body)))) |
---|
| 242 | |
---|
| 243 | (defmacro as-binary-output-file (&rest body) |
---|
| 244 | (` (let (mc-flag |
---|
| 245 | (file-coding-system *noconv*) |
---|
| 246 | ) |
---|
| 247 | (,@ body)))) |
---|
| 248 | |
---|
| 249 | (defalias 'set-process-input-coding-system 'set-process-coding-system) |
---|
| 250 | |
---|
| 251 | (cond |
---|
| 252 | ((and (>= emacs-major-version 19) (>= emacs-minor-version 23)) |
---|
| 253 | ;; Mule 2.0 or later. |
---|
| 254 | (defun insert-file-contents-as-binary (filename |
---|
| 255 | &optional visit beg end replace) |
---|
| 256 | "Like `insert-file-contents', q.v., but don't code and format conversion. |
---|
| 257 | Like `insert-file-contents-literary', but it allows find-file-hooks, |
---|
| 258 | automatic uncompression, etc. |
---|
| 259 | |
---|
| 260 | Namely this function ensures that only format decoding and character |
---|
| 261 | code conversion will not take place." |
---|
| 262 | (as-binary-input-file |
---|
| 263 | ;; Returns list absolute file name and length of data inserted. |
---|
| 264 | (insert-file-contents filename visit beg end replace)))) |
---|
| 265 | (t |
---|
| 266 | ;; Mule 1.1 or earlier. |
---|
| 267 | (defun insert-file-contents-as-binary (filename |
---|
| 268 | &optional visit beg end replace) |
---|
| 269 | "Like `insert-file-contents', q.v., but don't code and format conversion. |
---|
| 270 | Like `insert-file-contents-literary', but it allows find-file-hooks, |
---|
| 271 | automatic uncompression, etc. |
---|
| 272 | |
---|
| 273 | Namely this function ensures that only format decoding and character |
---|
| 274 | code conversion will not take place." |
---|
| 275 | (as-binary-input-file |
---|
| 276 | ;; Returns list absolute file name and length of data inserted. |
---|
| 277 | (insert-file-contents filename visit))))) |
---|
| 278 | |
---|
| 279 | (defun insert-file-contents-as-raw-text (filename |
---|
| 280 | &optional visit beg end replace) |
---|
| 281 | "Like `insert-file-contents', q.v., but don't code and format conversion. |
---|
| 282 | Like `insert-file-contents-literary', but it allows find-file-hooks, |
---|
| 283 | automatic uncompression, etc. |
---|
| 284 | Like `insert-file-contents-as-binary', but it converts line-break |
---|
| 285 | code." |
---|
| 286 | ;; Returns list absolute file name and length of data inserted. |
---|
| 287 | (insert-file-contents-as-coding-system 'raw-text |
---|
| 288 | filename visit beg end replace)) |
---|
| 289 | |
---|
| 290 | (defalias 'insert-file-contents-as-raw-text-CRLF |
---|
| 291 | 'insert-file-contents-as-raw-text) |
---|
| 292 | |
---|
| 293 | (defun write-region-as-binary (start end filename |
---|
| 294 | &optional append visit lockname) |
---|
| 295 | "Like `write-region', q.v., but don't code conversion." |
---|
| 296 | (write-region-as-coding-system 'binary |
---|
| 297 | start end filename append visit lockname)) |
---|
| 298 | |
---|
| 299 | (defun write-region-as-raw-text-CRLF (start end filename |
---|
| 300 | &optional append visit lockname) |
---|
| 301 | "Like `write-region', q.v., but don't code conversion." |
---|
| 302 | (write-region-as-coding-system 'raw-text-dos |
---|
| 303 | start end filename append visit lockname)) |
---|
| 304 | |
---|
| 305 | (defun find-file-noselect-as-binary (filename &optional nowarn rawfile) |
---|
| 306 | "Like `find-file-noselect', q.v., but don't code and format conversion." |
---|
| 307 | (find-file-noselect-as-coding-system 'binary filename nowarn rawfile)) |
---|
| 308 | |
---|
| 309 | (defun find-file-noselect-as-raw-text (filename &optional nowarn rawfile) |
---|
| 310 | "Like `find-file-noselect', q.v., but it does not code and format |
---|
| 311 | conversion except for line-break code." |
---|
| 312 | (find-file-noselect-as-coding-system 'raw-text filename nowarn rawfile)) |
---|
| 313 | |
---|
| 314 | (defalias 'find-file-noselect-as-raw-text-CRLF |
---|
| 315 | 'find-file-noselect-as-raw-text) |
---|
| 316 | |
---|
| 317 | (defun save-buffer-as-binary (&optional args) |
---|
| 318 | "Like `save-buffer', q.v., but don't encode." |
---|
| 319 | (let ((file-coding-system 'binary)) |
---|
| 320 | (save-buffer args))) |
---|
| 321 | |
---|
| 322 | (defun save-buffer-as-raw-text-CRLF (&optional args) |
---|
| 323 | "Like `save-buffer', q.v., but save as network representation." |
---|
| 324 | (let ((file-coding-system 'raw-text-dos)) |
---|
| 325 | (save-buffer args))) |
---|
| 326 | |
---|
| 327 | (defun open-network-stream-as-binary (name buffer host service) |
---|
| 328 | "Like `open-network-stream', q.v., but don't code conversion." |
---|
| 329 | (let ((process (open-network-stream name buffer host service))) |
---|
| 330 | (set-process-coding-system process *noconv* *noconv*) |
---|
| 331 | process)) |
---|
| 332 | |
---|
| 333 | |
---|
| 334 | ;;; @ end |
---|
| 335 | ;;; |
---|
| 336 | |
---|
| 337 | (require 'product) |
---|
| 338 | (product-provide (provide 'pces-om) (require 'apel-ver)) |
---|
| 339 | |
---|
| 340 | ;;; pces-om.el ends here |
---|