cgit.sxemacs.org Git - gnus/blob - lisp/mm-encode.el

   1 ;;; mm-encode.el --- Functions for encoding MIME things
   2 ;; Copyright (C) 1998 Free Software Foundation, Inc.
   3
   4 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   5 ;;      MORIOKA Tomohiko <morioka@jaist.ac.jp>
   6 ;; This file is not yet part of GNU Emacs.
   7
   8 ;; GNU Emacs is free software; you can redistribute it and/or modify
   9 ;; it under the terms of the GNU General Public License as published by
  10 ;; the Free Software Foundation; either version 2, or (at your option)
  11 ;; any later version.
  12
  13 ;; GNU Emacs is distributed in the hope that it will be useful,
  14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;; GNU General Public License for more details.
  17
  18 ;; You should have received a copy of the GNU General Public License
  19 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  20 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  21 ;; Boston, MA 02111-1307, USA.
  22
  23 ;;; Commentary:
  24
  25 ;;; Code:
  26
  27 (defvar mm-header-encoding-alist
  28   '(("X-Nsubject" . iso-2022-jp-2)
  29     ("Newsgroups" . nil)
  30     ("Message-ID" . nil)
  31     (t . mime))
  32   "*Header/encoding method alist.
  33 The list is traversed sequentially.  The keys can either be a
  34 header regexp or `t'.
  35
  36 The values can be:
  37
  38 1) nil, in which case no encoding is done;
  39 2) `mime', in which case the header will be encoded according to RFC1522;
  40 3) a charset, in which case it will be encoded as that charse;
  41 4) `default', in which case the field will be encoded as the rest
  42    of the article.")
  43
  44 (defvar mm-mime-mule-charset-alist
  45   '((us-ascii ascii)
  46     (iso-8859-1 latin-iso8859-1)
  47     (iso-8859-2 latin-iso8859-2)
  48     (iso-8859-3 latin-iso8859-3)
  49     (iso-8859-4 latin-iso8859-4)
  50     (iso-8859-5 cyrillic-iso8859-5)
  51     (koi8-r cyrillic-iso8859-5)
  52     (iso-8859-6 arabic-iso8859-6)
  53     (iso-8859-7 greek-iso8859-7)
  54     (iso-8859-8 hebrew-iso8859-8)
  55     (iso-8859-9 latin-iso8859-9)
  56     (iso-2022-jp latin-jisx0201
  57                  japanese-jisx0208-1978 japanese-jisx0208)
  58     (euc-kr korean-ksc5601)
  59     (cn-gb-2312 chinese-gb2312)
  60     (cn-big5 chinese-big5-1 chinese-big5-2)
  61     (iso-2022-jp-2 latin-iso8859-1 greek-iso8859-7
  62                    latin-jisx0201 japanese-jisx0208-1978
  63                    chinese-gb2312 japanese-jisx0208
  64                    korean-ksc5601 japanese-jisx0212)
  65     (iso-2022-int-1 latin-iso8859-1 greek-iso8859-7
  66                     latin-jisx0201 japanese-jisx0208-1978
  67                     chinese-gb2312 japanese-jisx0208
  68                     korean-ksc5601 japanese-jisx0212
  69                     chinese-cns11643-1 chinese-cns11643-2)
  70     (iso-2022-int-1 latin-iso8859-1 latin-iso8859-2
  71                     cyrillic-iso8859-5 greek-iso8859-7
  72                     latin-jisx0201 japanese-jisx0208-1978
  73                     chinese-gb2312 japanese-jisx0208
  74                     korean-ksc5601 japanese-jisx0212
  75                     chinese-cns11643-1 chinese-cns11643-2
  76                     chinese-cns11643-3 chinese-cns11643-4
  77                     chinese-cns11643-5 chinese-cns11643-6
  78                     chinese-cns11643-7))
  79   "Alist of MIME-charset/MULE-charsets.")
  80
  81 (defvar mm-mime-charset-encoding-alist
  82   '((us-ascii . nil)
  83     (iso-8859-1 . Q)
  84     (iso-8859-2 . Q)
  85     (iso-8859-3 . Q)
  86     (iso-8859-4 . Q)
  87     (iso-8859-5 . Q)
  88     (koi8-r . Q)
  89     (iso-8859-7 . Q)
  90     (iso-8859-8 . Q)
  91     (iso-8859-9 . Q)
  92     (iso-2022-jp . B)
  93     (iso-2022-kr . B)
  94     (gb2312 . B)
  95     (cn-gb . B)
  96     (cn-gb-2312 . B)
  97     (euc-kr . B)
  98     (iso-2022-jp-2 . B)
  99     (iso-2022-int-1 . B))
 100   "Alist of MIME charsets to MIME encodings.
 101 Valid encodings are nil, `Q' and `B'.")
 102
 103 (defvar mm-mime-encoding-function-alist
 104   '((Q . quoted-printable-encode-region)
 105     (B . base64-encode-region)
 106     (nil . ignore))
 107   "Alist of MIME encodings to encoding functions.")
 108
 109 (defun mm-encode-message-header ()
 110   "Encode the message header according to `mm-header-encoding-alist'."
 111   (when (featurep 'mule)
 112     (save-excursion
 113       (save-restriction
 114         (message-narrow-to-headers)
 115         (let ((alist mm-header-encoding-alist)
 116               elem method)
 117           (while (not (eobp))
 118             (save-restriction
 119               (message-narrow-to-field)
 120               (when (find-non-ascii-charset-region (point-min) (point-max))
 121                 ;; We found something that may perhaps be encoded.
 122                 (while (setq elem (pop alist))
 123                   (when (or (and (stringp (car elem))
 124                                  (looking-at (car elem)))
 125                             (eq (car elem) t))
 126                     (setq alist nil
 127                           method (cdr elem))))
 128                 (when method
 129                   (cond
 130                    ((eq method 'mime)
 131                     (mm-encode-words-region (point-min) (point-max)))
 132                    ;; Hm.
 133                    (t))))
 134               (goto-char (point-max)))))))))
 135
 136 (defun mm-encode-words-region (b e)
 137   "Encode all encodable words in REGION."
 138   (let (prev c start qstart qprev qend)
 139     (save-excursion
 140       (goto-char b)
 141       (while (re-search-forward "[^ \t\n]+" nil t)
 142         (save-restriction
 143           (narrow-to-region (match-beginning 0) (match-end 0))
 144           (goto-char (setq start (point-min)))
 145           (setq prev nil)
 146           (while (not (eobp))
 147             (unless (eq (setq c (char-charset (following-char))) 'ascii)
 148               (cond
 149                ((eq c prev)
 150                 )
 151                ((null prev)
 152                 (setq qstart (or qstart start)
 153                       qend (point-max)
 154                       qprev c)
 155                 (setq prev c))
 156                (t
 157                 ;(mm-encode-word-region start (setq start (point)) prev)
 158                 (setq prev c)
 159                 )))
 160             (forward-char 1)))
 161         (when (and (not prev) qstart)
 162           (mm-encode-word-region qstart qend qprev)
 163           (setq qstart nil)))
 164       (when qstart
 165         (mm-encode-word-region qstart qend qprev)
 166         (setq qstart nil)))))
 167
 168 (defun mm-encode-words-string (string)
 169   "Encode words in STRING."
 170   (with-temp-buffer
 171     (insert string)
 172     (mm-encode-words-region (point-min) (point-max))
 173     (buffer-string)))
 174
 175 (defun mm-mule-charset-to-mime-charset (charset)
 176   "Return the MIME charset corresponding to MULE CHARSET."
 177   (let ((alist mm-mime-mule-charset-alist)
 178         out)
 179     (while alist
 180       (when (memq charset (cdar alist))
 181         (setq out (caar alist)
 182               alist nil))
 183       (pop alist))
 184     out))
 185
 186 (defun mm-encode-word-region (b e charset)
 187   "Encode the word in the region with CHARSET."
 188   (let* ((mime-charset (mm-mule-charset-to-mime-charset charset))
 189          (encoding (cdr (assq mime-charset mm-mime-charset-encoding-alist))))
 190     (save-restriction
 191       (narrow-to-region b e)
 192       (funcall (cdr (assq encoding mm-mime-encoding-function-alist))
 193                b e)
 194       (goto-char (point-min))
 195       (insert "=?" (upcase (symbol-name mime-charset)) "?"
 196               (symbol-name encoding) "?")
 197       (goto-char (point-max))
 198       (insert "?="))))
 199
 200 (provide 'mm-encode)
 201
 202 ;;; mm-encode.el ends here