1 | ;;; mcs-20.el --- MIME charset implementation for Emacs 20 and XEmacs/mule |
---|
2 | |
---|
3 | ;; Copyright (C) 1997,1998,1999,2000 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 | ;;; Commentary: |
---|
26 | |
---|
27 | ;; This module requires Emacs 20.0.93, XEmacs 20.3-b5 (with mule) |
---|
28 | ;; or later. |
---|
29 | |
---|
30 | ;;; Code: |
---|
31 | |
---|
32 | (require 'custom) |
---|
33 | (eval-when-compile (require 'wid-edit)) |
---|
34 | |
---|
35 | (if (featurep 'xemacs) |
---|
36 | (require 'mcs-xm) |
---|
37 | (require 'mcs-e20)) |
---|
38 | |
---|
39 | |
---|
40 | ;;; @ MIME charset |
---|
41 | ;;; |
---|
42 | |
---|
43 | (defcustom mime-charset-coding-system-alist |
---|
44 | (let ((rest |
---|
45 | '((us-ascii . raw-text) |
---|
46 | (gb2312 . cn-gb-2312) |
---|
47 | (cn-gb . cn-gb-2312) |
---|
48 | (iso-2022-jp-2 . iso-2022-7bit-ss2) |
---|
49 | (iso-2022-jp-3 . iso-2022-7bit-ss2) |
---|
50 | (tis-620 . tis620) |
---|
51 | (windows-874 . tis-620) |
---|
52 | (cp874 . tis-620) |
---|
53 | (x-ctext . ctext) |
---|
54 | (unknown . undecided) |
---|
55 | (x-unknown . undecided) |
---|
56 | )) |
---|
57 | dest) |
---|
58 | (while rest |
---|
59 | (let ((pair (car rest))) |
---|
60 | (or (find-coding-system (car pair)) |
---|
61 | (setq dest (cons pair dest)) |
---|
62 | )) |
---|
63 | (setq rest (cdr rest)) |
---|
64 | ) |
---|
65 | dest) |
---|
66 | "Alist MIME CHARSET vs CODING-SYSTEM. |
---|
67 | MIME CHARSET and CODING-SYSTEM must be symbol." |
---|
68 | :group 'i18n |
---|
69 | :type '(repeat (cons symbol coding-system))) |
---|
70 | |
---|
71 | (defcustom mime-charset-to-coding-system-default-method |
---|
72 | nil |
---|
73 | "Function called when suitable coding-system is not found from MIME-charset. |
---|
74 | It must be nil or function. |
---|
75 | If it is a function, interface must be (CHARSET LBT CODING-SYSTEM)." |
---|
76 | :group 'i18n |
---|
77 | :type '(choice function (const nil))) |
---|
78 | |
---|
79 | (defun mime-charset-to-coding-system (charset &optional lbt) |
---|
80 | "Return coding-system corresponding with CHARSET. |
---|
81 | CHARSET is a symbol whose name is MIME charset. |
---|
82 | If optional argument LBT (`CRLF', `LF', `CR', `unix', `dos' or `mac') |
---|
83 | is specified, it is used as line break code type of coding-system." |
---|
84 | (if (stringp charset) |
---|
85 | (setq charset (intern (downcase charset))) |
---|
86 | ) |
---|
87 | (let ((cs (assq charset mime-charset-coding-system-alist))) |
---|
88 | (setq cs |
---|
89 | (if cs |
---|
90 | (cdr cs) |
---|
91 | charset)) |
---|
92 | (if lbt |
---|
93 | (setq cs (intern (format "%s-%s" cs |
---|
94 | (cond ((eq lbt 'CRLF) 'dos) |
---|
95 | ((eq lbt 'LF) 'unix) |
---|
96 | ((eq lbt 'CR) 'mac) |
---|
97 | (t lbt))))) |
---|
98 | ) |
---|
99 | (if (find-coding-system cs) |
---|
100 | cs |
---|
101 | (if mime-charset-to-coding-system-default-method |
---|
102 | (funcall mime-charset-to-coding-system-default-method |
---|
103 | charset lbt cs) |
---|
104 | )))) |
---|
105 | |
---|
106 | (defalias 'mime-charset-p 'mime-charset-to-coding-system) |
---|
107 | |
---|
108 | (defvar widget-mime-charset-prompt-value-history nil |
---|
109 | "History of input to `widget-mime-charset-prompt-value'.") |
---|
110 | |
---|
111 | (define-widget 'mime-charset 'coding-system |
---|
112 | "A mime-charset." |
---|
113 | :format "%{%t%}: %v" |
---|
114 | :tag "MIME-charset" |
---|
115 | :prompt-history 'widget-mime-charset-prompt-value-history |
---|
116 | :prompt-value 'widget-mime-charset-prompt-value |
---|
117 | :action 'widget-mime-charset-action) |
---|
118 | |
---|
119 | (defun widget-mime-charset-prompt-value (widget prompt value unbound) |
---|
120 | ;; Read mime-charset from minibuffer. |
---|
121 | (intern |
---|
122 | (completing-read (format "%s (default %s) " prompt value) |
---|
123 | (mapcar (function |
---|
124 | (lambda (sym) |
---|
125 | (list (symbol-name sym)))) |
---|
126 | (mime-charset-list))))) |
---|
127 | |
---|
128 | (defun widget-mime-charset-action (widget &optional event) |
---|
129 | ;; Read a mime-charset from the minibuffer. |
---|
130 | (let ((answer |
---|
131 | (widget-mime-charset-prompt-value |
---|
132 | widget |
---|
133 | (widget-apply widget :menu-tag-get) |
---|
134 | (widget-value widget) |
---|
135 | t))) |
---|
136 | (widget-value-set widget answer) |
---|
137 | (widget-apply widget :notify widget event) |
---|
138 | (widget-setup))) |
---|
139 | |
---|
140 | (defcustom default-mime-charset 'x-unknown |
---|
141 | "Default value of MIME-charset. |
---|
142 | It is used when MIME-charset is not specified. |
---|
143 | It must be symbol." |
---|
144 | :group 'i18n |
---|
145 | :type 'mime-charset) |
---|
146 | |
---|
147 | (defun detect-mime-charset-region (start end) |
---|
148 | "Return MIME charset for region between START and END." |
---|
149 | (find-mime-charset-by-charsets (find-charset-region start end) |
---|
150 | 'region start end)) |
---|
151 | |
---|
152 | (defun write-region-as-mime-charset (charset start end filename |
---|
153 | &optional append visit lockname) |
---|
154 | "Like `write-region', q.v., but encode by MIME CHARSET." |
---|
155 | (let ((coding-system-for-write |
---|
156 | (or (mime-charset-to-coding-system charset) |
---|
157 | 'binary))) |
---|
158 | (write-region start end filename append visit lockname))) |
---|
159 | |
---|
160 | |
---|
161 | ;;; @ end |
---|
162 | ;;; |
---|
163 | |
---|
164 | (require 'product) |
---|
165 | (product-provide (provide 'mcs-20) (require 'apel-ver)) |
---|
166 | |
---|
167 | ;;; mcs-20.el ends here |
---|