[7238] | 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 |
---|