[7238] | 1 | ;;; pces-nemacs.el --- pces implementation for Nemacs |
---|
| 2 | |
---|
| 3 | ;; Copyright (C) 1995,1996,1997,1998,1999 Free Software Foundation, Inc. |
---|
| 4 | |
---|
| 5 | ;; Author: MORIOKA Tomohiko <tomo@m17n.org> |
---|
| 6 | ;; Keywords: emulation, compatibility, Mule |
---|
| 7 | |
---|
| 8 | ;; This file is part of APEL (A Portable Emacs Library). |
---|
| 9 | |
---|
| 10 | ;; This program is free software; you can redistribute it and/or |
---|
| 11 | ;; modify it under the terms of the GNU General Public License as |
---|
| 12 | ;; published by the Free Software Foundation; either version 2, or (at |
---|
| 13 | ;; your option) any later version. |
---|
| 14 | |
---|
| 15 | ;; This program is distributed in the hope that it will be useful, but |
---|
| 16 | ;; WITHOUT ANY WARRANTY; without even the implied warranty of |
---|
| 17 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
---|
| 18 | ;; General Public License for more details. |
---|
| 19 | |
---|
| 20 | ;; You should have received a copy of the GNU General Public License |
---|
| 21 | ;; along with GNU Emacs; see the file COPYING. If not, write to the |
---|
| 22 | ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, |
---|
| 23 | ;; Boston, MA 02111-1307, USA. |
---|
| 24 | |
---|
| 25 | ;;; Code: |
---|
| 26 | |
---|
| 27 | ;;; @ coding system |
---|
| 28 | ;;; |
---|
| 29 | |
---|
| 30 | (defvar coding-system-kanji-code-alist |
---|
| 31 | '((binary . 0) |
---|
| 32 | (raw-text . 0) |
---|
| 33 | (shift_jis . 1) |
---|
| 34 | (iso-2022-jp . 2) |
---|
| 35 | (ctext . 2) |
---|
| 36 | (euc-jp . 3) |
---|
| 37 | )) |
---|
| 38 | |
---|
| 39 | (defun decode-coding-string (string coding-system) |
---|
| 40 | "Decode the STRING which is encoded in CODING-SYSTEM. |
---|
| 41 | \[emu-nemacs.el; EMACS 20 emulating function]" |
---|
| 42 | (let ((code (if (integerp coding-system) |
---|
| 43 | coding-system |
---|
| 44 | (cdr (assq coding-system coding-system-kanji-code-alist))))) |
---|
| 45 | (if (eq code 3) |
---|
| 46 | string |
---|
| 47 | (convert-string-kanji-code string code 3) |
---|
| 48 | ))) |
---|
| 49 | |
---|
| 50 | (defun encode-coding-string (string coding-system) |
---|
| 51 | "Encode the STRING to CODING-SYSTEM. |
---|
| 52 | \[emu-nemacs.el; EMACS 20 emulating function]" |
---|
| 53 | (let ((code (if (integerp coding-system) |
---|
| 54 | coding-system |
---|
| 55 | (cdr (assq coding-system coding-system-kanji-code-alist))))) |
---|
| 56 | (if (eq code 3) |
---|
| 57 | string |
---|
| 58 | (convert-string-kanji-code string 3 code) |
---|
| 59 | ))) |
---|
| 60 | |
---|
| 61 | (defun decode-coding-region (start end coding-system) |
---|
| 62 | "Decode the text between START and END which is encoded in CODING-SYSTEM. |
---|
| 63 | \[emu-nemacs.el; EMACS 20 emulating function]" |
---|
| 64 | (let ((code (if (integerp coding-system) |
---|
| 65 | coding-system |
---|
| 66 | (cdr (assq coding-system coding-system-kanji-code-alist))))) |
---|
| 67 | (save-excursion |
---|
| 68 | (save-restriction |
---|
| 69 | (narrow-to-region start end) |
---|
| 70 | (convert-region-kanji-code start end code 3) |
---|
| 71 | )))) |
---|
| 72 | |
---|
| 73 | (defun encode-coding-region (start end coding-system) |
---|
| 74 | "Encode the text between START and END to CODING-SYSTEM. |
---|
| 75 | \[emu-nemacs.el; EMACS 20 emulating function]" |
---|
| 76 | (let ((code (if (integerp coding-system) |
---|
| 77 | coding-system |
---|
| 78 | (cdr (assq coding-system coding-system-kanji-code-alist))))) |
---|
| 79 | (save-excursion |
---|
| 80 | (save-restriction |
---|
| 81 | (narrow-to-region start end) |
---|
| 82 | (convert-region-kanji-code start end 3 code) |
---|
| 83 | )))) |
---|
| 84 | |
---|
| 85 | (defun detect-coding-region (start end) |
---|
| 86 | "Detect coding-system of the text in the region between START and END. |
---|
| 87 | \[emu-nemacs.el; Emacs 20 emulating function]" |
---|
| 88 | (if (save-excursion |
---|
| 89 | (save-restriction |
---|
| 90 | (narrow-to-region start end) |
---|
| 91 | (goto-char start) |
---|
| 92 | (re-search-forward "[\200-\377]" nil t))) |
---|
| 93 | 'euc-jp |
---|
| 94 | )) |
---|
| 95 | |
---|
| 96 | (defalias 'set-buffer-file-coding-system 'set-kanji-fileio-code) |
---|
| 97 | |
---|
| 98 | |
---|
| 99 | ;;; @ without code-conversion |
---|
| 100 | ;;; |
---|
| 101 | |
---|
| 102 | (defmacro as-binary-process (&rest body) |
---|
| 103 | (` (let (selective-display ; Disable ^M to nl translation. |
---|
| 104 | ;; NEmacs |
---|
| 105 | kanji-flag |
---|
| 106 | (default-kanji-process-code 0) |
---|
| 107 | program-kanji-code-alist) |
---|
| 108 | (,@ body)))) |
---|
| 109 | |
---|
| 110 | (defmacro as-binary-input-file (&rest body) |
---|
| 111 | (` (let (kanji-flag default-kanji-flag) |
---|
| 112 | (,@ body)))) |
---|
| 113 | |
---|
| 114 | (defmacro as-binary-output-file (&rest body) |
---|
| 115 | (` (let (kanji-flag) |
---|
| 116 | (,@ body)))) |
---|
| 117 | |
---|
| 118 | (defun write-region-as-binary (start end filename |
---|
| 119 | &optional append visit lockname) |
---|
| 120 | "Like `write-region', q.v., but don't code conversion. [emu-nemacs.el]" |
---|
| 121 | (as-binary-output-file |
---|
| 122 | (write-region start end filename append visit))) |
---|
| 123 | |
---|
| 124 | (defun insert-file-contents-as-binary (filename |
---|
| 125 | &optional visit beg end replace) |
---|
| 126 | "Like `insert-file-contents', q.v., but don't character code conversion. |
---|
| 127 | \[emu-nemacs.el]" |
---|
| 128 | (as-binary-input-file |
---|
| 129 | ;; Returns list absolute file name and length of data inserted. |
---|
| 130 | (insert-file-contents filename visit))) |
---|
| 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 character code conversion. |
---|
| 135 | It converts line-break code from CRLF to LF. [emu-nemacs.el]" |
---|
| 136 | (save-restriction |
---|
| 137 | (narrow-to-region (point) (point)) |
---|
| 138 | (let ((return (as-binary-input-file |
---|
| 139 | (insert-file-contents filename visit)))) |
---|
| 140 | (while (search-forward "\r\n" nil t) |
---|
| 141 | (replace-match "\n")) |
---|
| 142 | (goto-char (point-min)) |
---|
| 143 | ;; Returns list absolute file name and length of data inserted. |
---|
| 144 | (list (car return) (- (point-max) (point-min)))))) |
---|
| 145 | |
---|
| 146 | (defalias 'insert-file-contents-as-raw-text-CRLF |
---|
| 147 | 'insert-file-contents-as-raw-text) |
---|
| 148 | |
---|
| 149 | (defun write-region-as-raw-text-CRLF (start end filename |
---|
| 150 | &optional append visit lockname) |
---|
| 151 | "Like `write-region', q.v., but don't code conversion. [emu-nemacs.el]" |
---|
| 152 | (let ((the-buf (current-buffer))) |
---|
| 153 | (with-temp-buffer |
---|
| 154 | (insert-buffer-substring the-buf start end) |
---|
| 155 | (goto-char (point-min)) |
---|
| 156 | (while (re-search-forward "\\(\\=\\|[^\r]\\)\n" nil t) |
---|
| 157 | (replace-match "\\1\r\n")) |
---|
| 158 | (write-region-as-binary (point-min)(point-max) |
---|
| 159 | filename append visit)))) |
---|
| 160 | |
---|
| 161 | (defun find-file-noselect-as-binary (filename &optional nowarn rawfile) |
---|
| 162 | "Like `find-file-noselect', q.v., but don't code conversion. |
---|
| 163 | \[emu-nemacs.el]" |
---|
| 164 | (as-binary-input-file (find-file-noselect filename nowarn))) |
---|
| 165 | |
---|
| 166 | (defun find-file-noselect-as-raw-text (filename &optional nowarn rawfile) |
---|
| 167 | "Like `find-file-noselect', q.v., but it does not code conversion |
---|
| 168 | except for line-break code. [emu-nemacs.el]" |
---|
| 169 | (let ((buf (get-file-buffer filename)) |
---|
| 170 | cur) |
---|
| 171 | (if buf |
---|
| 172 | (prog1 |
---|
| 173 | buf |
---|
| 174 | (or nowarn |
---|
| 175 | (verify-visited-file-modtime buf) |
---|
| 176 | (cond ((not (file-exists-p filename)) |
---|
| 177 | (error "File %s no longer exists!" filename)) |
---|
| 178 | ((yes-or-no-p |
---|
| 179 | (if (buffer-modified-p buf) |
---|
| 180 | "File has changed since last visited or saved. Flush your changes? " |
---|
| 181 | "File has changed since last visited or saved. Read from disk? ")) |
---|
| 182 | (setq cur (current-buffer)) |
---|
| 183 | (set-buffer buf) |
---|
| 184 | (revert-buffer t t) |
---|
| 185 | (save-excursion |
---|
| 186 | (goto-char (point-min)) |
---|
| 187 | (while (search-forward "\r\n" nil t) |
---|
| 188 | (replace-match "\n"))) |
---|
| 189 | (set-buffer-modified-p nil) |
---|
| 190 | (set-buffer cur))))) |
---|
| 191 | (save-excursion |
---|
| 192 | (prog1 |
---|
| 193 | (set-buffer |
---|
| 194 | (find-file-noselect-as-binary filename nowarn rawfile)) |
---|
| 195 | (while (search-forward "\r\n" nil t) |
---|
| 196 | (replace-match "\n")) |
---|
| 197 | (goto-char (point-min)) |
---|
| 198 | (set-buffer-modified-p nil)))))) |
---|
| 199 | |
---|
| 200 | (defalias 'find-file-noselect-as-raw-text-CRLF |
---|
| 201 | 'find-file-noselect-as-raw-text) |
---|
| 202 | |
---|
| 203 | (defun open-network-stream-as-binary (name buffer host service) |
---|
| 204 | "Like `open-network-stream', q.v., but don't code conversion. |
---|
| 205 | \[emu-nemacs.el]" |
---|
| 206 | (let ((process (open-network-stream name buffer host service))) |
---|
| 207 | (set-process-kanji-code process 0) |
---|
| 208 | process)) |
---|
| 209 | |
---|
| 210 | (defun save-buffer-as-binary (&optional args) |
---|
| 211 | "Like `save-buffer', q.v., but don't encode. [emu-nemacs.el]" |
---|
| 212 | (as-binary-output-file |
---|
| 213 | (save-buffer args))) |
---|
| 214 | |
---|
| 215 | (defun save-buffer-as-raw-text-CRLF (&optional args) |
---|
| 216 | "Like `save-buffer', q.v., but save as network representation. |
---|
| 217 | \[emu-nemacs.el]" |
---|
| 218 | (if (buffer-modified-p) |
---|
| 219 | (save-restriction |
---|
| 220 | (widen) |
---|
| 221 | (let ((the-buf (current-buffer)) |
---|
| 222 | (filename (buffer-file-name))) |
---|
| 223 | (if filename |
---|
| 224 | (prog1 |
---|
| 225 | (with-temp-buffer |
---|
| 226 | (insert-buffer the-buf) |
---|
| 227 | (goto-char (point-min)) |
---|
| 228 | (while (re-search-forward "\\(\\=\\|[^\r]\\)\n" nil t) |
---|
| 229 | (replace-match "\\1\r\n")) |
---|
| 230 | (setq buffer-file-name filename) |
---|
| 231 | (save-buffer-as-binary args)) |
---|
| 232 | (set-buffer-modified-p nil) |
---|
| 233 | (clear-visited-file-modtime))))))) |
---|
| 234 | |
---|
| 235 | |
---|
| 236 | ;;; @ with code-conversion |
---|
| 237 | ;;; |
---|
| 238 | |
---|
| 239 | (defun insert-file-contents-as-coding-system |
---|
| 240 | (coding-system filename &optional visit beg end replace) |
---|
| 241 | "Like `insert-file-contents', q.v., but CODING-SYSTEM the first arg will |
---|
| 242 | be applied to `kanji-fileio-code'. [emu-nemacs.el]" |
---|
| 243 | (let ((kanji-fileio-code coding-system) |
---|
| 244 | kanji-expected-code) |
---|
| 245 | (insert-file-contents filename visit))) |
---|
| 246 | |
---|
| 247 | (defun write-region-as-coding-system |
---|
| 248 | (coding-system start end filename &optional append visit lockname) |
---|
| 249 | "Like `write-region', q.v., but CODING-SYSTEM the first arg will be |
---|
| 250 | applied to `kanji-fileio-code'. [emu-nemacs.el]" |
---|
| 251 | (let ((kanji-fileio-code coding-system) |
---|
| 252 | jka-compr-compression-info-list jam-zcat-filename-list) |
---|
| 253 | (write-region start end filename append visit))) |
---|
| 254 | |
---|
| 255 | (defun find-file-noselect-as-coding-system |
---|
| 256 | (coding-system filename &optional nowarn rawfile) |
---|
| 257 | "Like `find-file-noselect', q.v., but CODING-SYSTEM the first arg will |
---|
| 258 | be applied to `kanji-fileio-code'. [emu-nemacs.el]" |
---|
| 259 | (let ((default-kanji-fileio-code coding-system) |
---|
| 260 | kanji-fileio-code kanji-expected-code) |
---|
| 261 | (find-file-noselect filename nowarn))) |
---|
| 262 | |
---|
| 263 | (defun save-buffer-as-coding-system (coding-system &optional args) |
---|
| 264 | "Like `save-buffer', q.v., but CODING-SYSTEM the first arg will be |
---|
| 265 | applied to `kanji-fileio-code'. [emu-nemacs.el]" |
---|
| 266 | (let ((kanji-fileio-code coding-system)) |
---|
| 267 | (save-buffer args))) |
---|
| 268 | |
---|
| 269 | |
---|
| 270 | ;;; @ end |
---|
| 271 | ;;; |
---|
| 272 | |
---|
| 273 | (require 'product) |
---|
| 274 | (product-provide (provide 'pces-nemacs) (require 'apel-ver)) |
---|
| 275 | |
---|
| 276 | ;;; pces-nemacs.el ends here |
---|