;;; mcs-20.el --- MIME charset implementation for Emacs 20 and XEmacs/mule
-;; Copyright (C) 1997,1998 Free Software Foundation, Inc.
+;; Copyright (C) 1997,1998,1999,2000 Free Software Foundation, Inc.
-;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
+;; Author: MORIOKA Tomohiko <tomo@m17n.org>
;; Keywords: emulation, compatibility, Mule
;; This file is part of APEL (A Portable Emacs Library).
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
;;; Commentary:
;;; Code:
-(require 'poem)
(require 'custom)
(eval-when-compile (require 'wid-edit))
+(if (featurep 'xemacs)
+ (require 'mcs-xm)
+ (require 'mcs-e20))
+
;;; @ MIME charset
;;;
(defcustom mime-charset-coding-system-alist
- `,(let ((rest
- '((us-ascii . raw-text)
- (gb2312 . cn-gb-2312)
- (iso-2022-jp-2 . iso-2022-7bit-ss2)
- (x-ctext . ctext)
- (unknown . undecided)
- (x-unknown . undecided)
- ))
- dest)
- (while rest
- (let ((pair (car rest)))
- (or (find-coding-system (car pair))
- (setq dest (cons pair dest))
- ))
- (setq rest (cdr rest))
- )
- dest)
+ (let ((rest
+ '((us-ascii . raw-text)
+ (gb2312 . cn-gb-2312)
+ (cn-gb . cn-gb-2312)
+ (iso-2022-jp-2 . iso-2022-7bit-ss2)
+ (iso-2022-jp-3 . iso-2022-7bit-ss2)
+ (tis-620 . tis620)
+ (windows-874 . tis-620)
+ (cp874 . tis-620)
+ (x-ctext . ctext)
+ (unknown . undecided)
+ (x-unknown . undecided)
+ ))
+ dest)
+ (while rest
+ (let ((pair (car rest)))
+ (or (find-coding-system (car pair))
+ (setq dest (cons pair dest))
+ ))
+ (setq rest (cdr rest))
+ )
+ dest)
"Alist MIME CHARSET vs CODING-SYSTEM.
MIME CHARSET and CODING-SYSTEM must be symbol."
:group 'i18n
:type '(repeat (cons symbol coding-system)))
-(defsubst mime-charset-to-coding-system (charset &optional lbt)
+(defcustom mime-charset-to-coding-system-default-method
+ nil
+ "Function called when suitable coding-system is not found from MIME-charset.
+It must be nil or function.
+If it is a function, interface must be (CHARSET LBT CODING-SYSTEM)."
+ :group 'i18n
+ :type '(choice function (const nil)))
+
+(defun mime-charset-to-coding-system (charset &optional lbt)
"Return coding-system corresponding with CHARSET.
CHARSET is a symbol whose name is MIME charset.
If optional argument LBT (`CRLF', `LF', `CR', `unix', `dos' or `mac')
(if (stringp charset)
(setq charset (intern (downcase charset)))
)
- (let ((ret (assq charset mime-charset-coding-system-alist)))
- (if ret
- (setq charset (cdr ret))
- ))
- (if lbt
- (setq charset (intern (format "%s-%s" charset
- (cond ((eq lbt 'CRLF) 'dos)
- ((eq lbt 'LF) 'unix)
- ((eq lbt 'CR) 'mac)
- (t lbt)))))
- )
- (if (find-coding-system charset)
- charset
- ))
-
-(defsubst mime-charset-list ()
- "Return a list of all existing MIME-charset."
- (nconc (mapcar (function car) mime-charset-coding-system-alist)
- (coding-system-list)))
-
+ (let ((cs (assq charset mime-charset-coding-system-alist)))
+ (setq cs
+ (if cs
+ (cdr cs)
+ charset))
+ (if lbt
+ (setq cs (intern (format "%s-%s" cs
+ (cond ((eq lbt 'CRLF) 'dos)
+ ((eq lbt 'LF) 'unix)
+ ((eq lbt 'CR) 'mac)
+ (t lbt)))))
+ )
+ (if (find-coding-system cs)
+ cs
+ (if mime-charset-to-coding-system-default-method
+ (funcall mime-charset-to-coding-system-default-method
+ charset lbt cs)
+ ))))
+
+(defalias 'mime-charset-p 'mime-charset-to-coding-system)
(defvar widget-mime-charset-prompt-value-history nil
"History of input to `widget-mime-charset-prompt-value'.")
(widget-apply widget :notify widget event)
(widget-setup)))
-(defcustom default-mime-charset 'x-ctext
+(defcustom default-mime-charset 'x-unknown
"Default value of MIME-charset.
It is used when MIME-charset is not specified.
It must be symbol."
:group 'i18n
:type 'mime-charset)
-(defsubst detect-mime-charset-region (start end)
+(cond ((featurep 'utf-2000)
+;; for CHISE Architecture
+(defun mcs-region-repertoire-p (start end charsets &optional buffer)
+ (save-excursion
+ (if buffer
+ (set-buffer buffer))
+ (save-restriction
+ (narrow-to-region start end)
+ (goto-char (point-min))
+ (catch 'tag
+ (let (ch)
+ (while (not (eobp))
+ (setq ch (char-after (point)))
+ (unless (some (lambda (ccs)
+ (encode-char ch ccs))
+ charsets)
+ (throw 'tag nil))
+ (forward-char)))
+ t))))
+
+(defun mcs-string-repertoire-p (string charsets &optional start end)
+ (let ((i (if start
+ (if (< start 0)
+ (error 'args-out-of-range string start end)
+ start)
+ 0))
+ ch)
+ (if end
+ (if (> end (length string))
+ (error 'args-out-of-range string start end))
+ (setq end (length string)))
+ (catch 'tag
+ (while (< i end)
+ (setq ch (aref string i))
+ (unless (some (lambda (ccs)
+ (encode-char ch ccs))
+ charsets)
+ (throw 'tag nil))
+ (setq i (1+ i)))
+ t)))
+
+(defun detect-mime-charset-region (start end)
+ "Return MIME charset for region between START and END."
+ (let ((rest charsets-mime-charset-alist)
+ cell)
+ (catch 'tag
+ (while rest
+ (setq cell (car rest))
+ (if (mcs-region-repertoire-p start end (car cell))
+ (throw 'tag (cdr cell)))
+ (setq rest (cdr rest)))
+ default-mime-charset-for-write)))
+
+(defun detect-mime-charset-string (string)
+ "Return MIME charset for STRING."
+ (let ((rest charsets-mime-charset-alist)
+ cell)
+ (catch 'tag
+ (while rest
+ (setq cell (car rest))
+ (if (mcs-string-repertoire-p string (car cell))
+ (throw 'tag (cdr cell)))
+ (setq rest (cdr rest)))
+ default-mime-charset-for-write)))
+)
+(t
+;; for legacy Mule
+(defun detect-mime-charset-region (start end)
"Return MIME charset for region between START and END."
- (charsets-to-mime-charset (find-charset-region start end)))
+ (find-mime-charset-by-charsets (find-charset-region start end)
+ 'region start end))
+))
(defun write-region-as-mime-charset (charset start end filename
&optional append visit lockname)
;;; @ end
;;;
-(provide 'mcs-20)
+(require 'product)
+(product-provide (provide 'mcs-20) (require 'apel-ver))
;;; mcs-20.el ends here
projects / elisp / apel.git / blobdiff