e3d1f881c8f05c87fe0b333769afdfa463e20ca4
[elisp/apel.git] / emu-mule.el
1 ;;; emu-mule.el --- emu module for Mule 1.* and Mule 2.*
2
3 ;; Copyright (C) 1995,1996,1997,1998 MORIOKA Tomohiko
4
5 ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
6 ;;         Katsumi Yamaoka <yamaoka@jpl.org>
7 ;; Keywords: emulation, compatibility, Mule
8
9 ;; This file is part of emu.
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 ;;; @ version specific features
29 ;;;
30
31 (cond (running-emacs-19
32        (require 'emu-e19)
33        
34        ;; Suggested by SASAKI Osamu <osamu@shuugr.bekkoame.or.jp>
35        ;; (cf. [os2-emacs-ja:78])
36        (defun fontset-pixel-size (fontset)
37          (let* ((font (get-font-info
38                        (aref (cdr (get-fontset-info fontset)) 0)))
39                 (open (aref font 4)))
40            (if (= open 1)
41                (aref font 5)
42              (if (= open 0)
43                  (let ((pat (aref font 1)))
44                    (if (string-match "-[0-9]+-" pat)
45                        (string-to-number
46                         (substring
47                          pat (1+ (match-beginning 0)) (1- (match-end 0))))
48                      0)))
49              )))
50        )
51       (running-emacs-18
52        (require 'emu-18)
53        (defun make-overlay (beg end &optional buffer type))
54        (defun overlay-put (overlay prop value))
55        ))
56
57
58 ;;; @ character set
59 ;;;
60
61 (defalias 'make-char 'make-character)
62
63 (defalias 'find-non-ascii-charset-string 'find-charset-string)
64 (defalias 'find-non-ascii-charset-region 'find-charset-region)
65
66 (defalias 'charset-bytes        'char-bytes)
67 (defalias 'charset-description  'char-description)
68 (defalias 'charset-registry     'char-registry)
69 (defalias 'charset-columns      'char-width)
70 (defalias 'charset-direction    'char-direction)
71
72 (defun charset-chars (charset)
73   "Return the number of characters per dimension of CHARSET."
74   (if (= (logand (nth 2 (character-set charset)) 1) 1)
75       96
76     94))
77
78
79 ;;; @ coding system
80 ;;;
81
82 (defun encode-coding-region (start end coding-system)
83   "Encode the text between START and END to CODING-SYSTEM.
84 \[EMACS 20 emulating function]"
85   (code-convert-region start end *internal* coding-system)
86   )
87
88 (defun decode-coding-region (start end coding-system)
89   "Decode the text between START and END which is encoded in CODING-SYSTEM.
90 \[EMACS 20 emulating function]"
91   (code-convert-region start end coding-system *internal*)
92   )
93
94 (defun encode-coding-string (str coding-system)
95   "Encode the STRING to CODING-SYSTEM.
96 \[EMACS 20 emulating function]"
97   (code-convert-string str *internal* coding-system)
98   )
99
100 (defun decode-coding-string (str coding-system)
101   "Decode the string STR which is encoded in CODING-SYSTEM.
102 \[EMACS 20 emulating function]"
103   (let ((len (length str))
104         ret)
105     (while (and
106             (< 0 len)
107             (null
108              (setq ret
109                    (code-convert-string (substring str 0 len)
110                                         coding-system *internal*))
111              ))
112       (setq len (1- len))
113       )
114     (concat ret (substring str len))
115     ))
116
117 (defalias 'detect-coding-region 'code-detect-region)
118
119 (defalias 'set-buffer-file-coding-system 'set-file-coding-system)
120
121 (defmacro as-binary-process (&rest body)
122   (` (let (selective-display    ; Disable ^M to nl translation.
123            ;; Mule
124            mc-flag      
125            (default-process-coding-system (cons *noconv* *noconv*))
126            program-coding-system-alist)
127        (,@ body)
128        )))
129
130 (defmacro as-binary-input-file (&rest body)
131   (` (let (mc-flag
132            (file-coding-system-for-read *noconv*)
133            )
134        (,@ body)
135        )))
136
137 (defmacro as-binary-output-file (&rest body)
138   (` (let (mc-flag
139            (file-coding-system *noconv*)
140            )
141        (,@ body)
142        )))
143
144 (defalias 'set-process-input-coding-system 'set-process-coding-system)
145
146
147 ;;; @ binary access
148 ;;;
149
150 (defun insert-file-contents-as-binary (filename
151                                        &optional visit beg end replace)
152   "Like `insert-file-contents', q.v., but don't code and format conversion.
153 Like `insert-file-contents-literary', but it allows find-file-hooks,
154 automatic uncompression, etc.
155
156 Namely this function ensures that only format decoding and character
157 code conversion will not take place."
158   (let (mc-flag
159         (file-coding-system *noconv*))
160     (insert-file-contents filename visit beg end replace)
161     ))
162
163 (defalias 'insert-binary-file-contents 'insert-file-contents-as-binary)
164 (make-obsolete 'insert-binary-file-contents 'insert-file-contents-as-binary)
165
166 (defun insert-file-contents-as-raw-text (filename
167                                          &optional visit beg end replace)
168   "Like `insert-file-contents', q.v., but don't code and format conversion.
169 Like `insert-file-contents-literary', but it allows find-file-hooks,
170 automatic uncompression, etc.
171 Like `insert-file-contents-as-binary', but it converts line-break
172 code."
173   (save-excursion
174     (save-restriction
175       (narrow-to-region (point)(point))
176       (insert-file-contents-as-binary filename visit beg end replace)
177       (goto-char (point-min))
178       (while (re-search-forward "\r$" nil t)
179         (replace-match "")
180         ))))
181
182 (defun insert-binary-file-contents-literally (filename
183                                               &optional visit beg end replace)
184   "Like `insert-file-contents-literally', q.v., but don't code conversion.
185 A buffer may be modified in several ways after reading into the buffer due
186 to advanced Emacs features, such as file-name-handlers, format decoding,
187 find-file-hooks, etc.
188   This function ensures that none of these modifications will take place."
189   (let (mc-flag
190         (file-coding-system *noconv*))
191     (insert-file-contents-literally filename visit beg end replace)
192     ))
193
194 (if running-emacs-19_29-or-later
195     ;; for MULE 2.3 based on Emacs 19.34.
196     (defun write-region-as-binary (start end filename
197                                          &optional append visit lockname)
198       "Like `write-region', q.v., but don't code conversion."
199       (let (mc-flag
200             (file-coding-system *noconv*))
201         (write-region start end filename append visit lockname)
202         ))
203   ;; for MULE 2.3 based on Emacs 19.28.
204   (defun write-region-as-binary (start end filename
205                                        &optional append visit lockname)
206     "Like `write-region', q.v., but don't code conversion."
207     (let (mc-flag
208           (file-coding-system *noconv*))
209       (write-region start end filename append visit)
210       ))
211   )
212
213
214 ;;; @ MIME charset
215 ;;;
216
217 (defun encode-mime-charset-region (start end charset)
218   "Encode the text between START and END as MIME CHARSET."
219   (let ((cs (mime-charset-to-coding-system charset)))
220     (if cs
221         (code-convert start end *internal* cs)
222       )))
223
224 (defun decode-mime-charset-region (start end charset)
225   "Decode the text between START and END as MIME CHARSET."
226   (let ((cs (mime-charset-to-coding-system charset)))
227     (if cs
228         (code-convert start end cs *internal*)
229       )))
230
231 (defun encode-mime-charset-string (string charset)
232   "Encode the STRING as MIME CHARSET."
233   (let ((cs (mime-charset-to-coding-system charset)))
234     (if cs
235         (code-convert-string string *internal* cs)
236       string)))
237
238 (defun decode-mime-charset-string (string charset)
239   "Decode the STRING which is encoded in MIME CHARSET."
240   (let ((cs (mime-charset-to-coding-system charset)))
241     (if cs
242         (decode-coding-string string cs)
243       string)))
244
245 (defun write-region-as-mime-charset (charset start end filename)
246   "Like `write-region', q.v., but code-convert by MIME CHARSET."
247   (let ((file-coding-system
248          (or (mime-charset-to-coding-system charset)
249              *noconv*)))
250     (write-region start end filename append visit)
251     ))
252
253
254 ;;; @@ to coding-system
255 ;;;
256
257 (defvar mime-charset-coding-system-alist
258   '((iso-8859-1      . *ctext*)
259     (x-ctext         . *ctext*)
260     (gb2312          . *euc-china*)
261     (koi8-r          . *koi8*)
262     (iso-2022-jp-2   . *iso-2022-ss2-7*)
263     (x-iso-2022-jp-2 . *iso-2022-ss2-7*)
264     (shift_jis       . *sjis*)
265     (x-shiftjis      . *sjis*)
266     ))
267
268 (defun mime-charset-to-coding-system (charset &optional lbt)
269   (if (stringp charset)
270       (setq charset (intern (downcase charset)))
271     )
272   (let ((cs
273          (or (cdr (assq charset mime-charset-coding-system-alist))
274              (let ((cs (intern (concat "*" (symbol-name charset) "*"))))
275                (and (coding-system-p cs) cs)
276                ))))
277     (if (or (null lbt)
278             (null cs))
279         cs
280       (intern (concat (symbol-name cs) (symbol-name lbt)))
281       )))
282
283
284 ;;; @@ detection
285 ;;;
286
287 (defvar charsets-mime-charset-alist
288   (let ((alist
289          '(((lc-ascii)                                  . us-ascii)
290            ((lc-ascii lc-ltn1)                          . iso-8859-1)
291            ((lc-ascii lc-ltn2)                          . iso-8859-2)
292            ((lc-ascii lc-ltn3)                          . iso-8859-3)
293            ((lc-ascii lc-ltn4)                          . iso-8859-4)
294 ;;;        ((lc-ascii lc-crl)                           . iso-8859-5)
295            ((lc-ascii lc-crl)                           . koi8-r)
296            ((lc-ascii lc-arb)                           . iso-8859-6)
297            ((lc-ascii lc-grk)                           . iso-8859-7)
298            ((lc-ascii lc-hbw)                           . iso-8859-8)
299            ((lc-ascii lc-ltn5)                          . iso-8859-9)
300            ((lc-ascii lc-roman lc-jpold lc-jp)          . iso-2022-jp)
301            ((lc-ascii lc-kr)                            . euc-kr)
302            ((lc-ascii lc-cn)                            . gb2312)
303            ((lc-ascii lc-big5-1 lc-big5-2)              . big5)
304            ((lc-ascii lc-roman lc-ltn1 lc-grk
305                       lc-jpold lc-cn lc-jp lc-kr
306                       lc-jp2)                           . iso-2022-jp-2)
307            ((lc-ascii lc-roman lc-ltn1 lc-grk
308                       lc-jpold lc-cn lc-jp lc-kr lc-jp2
309                       lc-cns1 lc-cns2)                  . iso-2022-int-1)
310            ((lc-ascii lc-roman
311                       lc-ltn1 lc-ltn2 lc-crl lc-grk
312                       lc-jpold lc-cn lc-jp lc-kr lc-jp2
313                       lc-cns1 lc-cns2 lc-cns3 lc-cns4
314                       lc-cns5 lc-cns6 lc-cns7)          . iso-2022-int-1)
315            ))
316         dest)
317     (while alist
318       (catch 'not-found
319         (let ((pair (car alist)))
320           (setq dest
321                 (append dest
322                         (list
323                          (cons (mapcar (function
324                                         (lambda (cs)
325                                           (if (boundp cs)
326                                               (symbol-value cs)
327                                             (throw 'not-found nil)
328                                             )))
329                                        (car pair))
330                                (cdr pair)))))))
331       (setq alist (cdr alist)))
332     dest))
333
334 (defvar default-mime-charset 'x-ctext
335   "Default value of MIME-charset.
336 It is used when MIME-charset is not specified.
337 It must be symbol.")
338
339 (defun detect-mime-charset-region (start end)
340   "Return MIME charset for region between START and END."
341   (charsets-to-mime-charset
342    (cons lc-ascii (find-charset-region start end))))
343
344
345 ;;; @ buffer representation
346 ;;;
347
348 (defsubst-maybe set-buffer-multibyte (flag)
349   "Set the multibyte flag of the current buffer to FLAG.
350 If FLAG is t, this makes the buffer a multibyte buffer.
351 If FLAG is nil, this makes the buffer a single-byte buffer.
352 The buffer contents remain unchanged as a sequence of bytes
353 but the contents viewed as characters do change.
354 \[Emacs 20.3 emulating function]"
355   (setq mc-flag flag)
356   )
357
358
359 ;;; @ character
360 ;;;
361
362 (defalias 'char-charset 'char-leading-char)
363
364 (defmacro char-next-index (char index)
365   "Return index of character succeeding CHAR whose index is INDEX."
366   (` (+ (, index) (char-bytes (, char)))))
367
368 ;;; @@ obsoleted aliases
369 ;;;
370 ;;; You should not use them.
371
372 (defalias 'char-length 'char-bytes)
373 ;;(defalias 'char-columns 'char-width)
374
375
376 ;;; @ string
377 ;;;
378
379 (defalias 'string-columns 'string-width)
380
381 (defalias 'string-to-int-list 'string-to-char-list)
382
383 (or (fboundp 'truncate-string)
384 ;;; Imported from Mule-2.3
385 (defun truncate-string (str width &optional start-column)
386   "Truncate STR to fit in WIDTH columns.
387 Optional non-nil arg START-COLUMN specifies the starting column.
388 \[emu-mule.el; Mule 2.3 emulating function]"
389   (or start-column
390       (setq start-column 0))
391   (let ((max-width (string-width str))
392         (len (length str))
393         (from 0)
394         (column 0)
395         to-prev to ch)
396     (if (>= width max-width)
397         (setq width max-width))
398     (if (>= start-column width)
399         ""
400       (while (< column start-column)
401         (setq ch (aref str from)
402               column (+ column (char-width ch))
403               from (+ from (char-bytes ch))))
404       (if (< width max-width)
405           (progn
406             (setq to from)
407             (while (<= column width)
408               (setq ch (aref str to)
409                     column (+ column (char-width ch))
410                     to-prev to
411                     to (+ to (char-bytes ch))))
412             (setq to to-prev)))
413       (substring str from to))))
414 ;;;
415   )
416
417 (defalias 'looking-at-as-unibyte 'looking-at)
418
419
420 ;;; @ regulation
421 ;;;
422
423 (defun regulate-latin-char (chr)
424   (cond ((and (<= ?\e$B#A\e(B chr)(<= chr ?\e$B#Z\e(B))
425          (+ (- chr ?\e$B#A\e(B) ?A)
426          )
427         ((and (<= ?\e$B#a\e(B chr)(<= chr ?\e$B#z\e(B))
428          (+ (- chr ?\e$B#a\e(B) ?a)
429          )
430         ((eq chr ?\e$B!%\e(B) ?.)
431         ((eq chr ?\e$B!$\e(B) ?,)
432         (t chr)
433         ))
434
435 (defun regulate-latin-string (str)
436   (let ((len (length str))
437         (i 0)
438         chr (dest ""))
439     (while (< i len)
440       (setq chr (sref str i))
441       (setq dest (concat dest
442                          (char-to-string (regulate-latin-char chr))))
443       (setq i (+ i (char-bytes chr)))
444       )
445     dest))
446
447
448 ;;; @ end
449 ;;;
450
451 (provide 'emu-mule)
452
453 ;;; emu-mule.el ends here