git.chise.org Git - elisp/gnus.git-/blob - lisp/rfc1522.el

   1 ;;; rfc1522.el --- Functions for encoding and decoding rfc1522 messages
   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 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 (require 'base64)
  28 (require 'qp)
  29 (require 'mm-util)
  30
  31 (defvar rfc1522-header-encoding-alist
  32   '(("Newsgroups" . nil)
  33     ("Message-ID" . nil)
  34     (t . mime))
  35   "*Header/encoding method alist.
  36 The list is traversed sequentially.  The keys can either be
  37 header regexps or `t'.
  38
  39 The values can be:
  40
  41 1) nil, in which case no encoding is done;
  42 2) `mime', in which case the header will be encoded according to RFC1522;
  43 3) a charset, in which case it will be encoded as that charse;
  44 4) `default', in which case the field will be encoded as the rest
  45    of the article.")
  46
  47 (defvar rfc1522-charset-encoding-alist
  48   '((us-ascii . nil)
  49     (iso-8859-1 . Q)
  50     (iso-8859-2 . Q)
  51     (iso-8859-3 . Q)
  52     (iso-8859-4 . Q)
  53     (iso-8859-5 . Q)
  54     (koi8-r . Q)
  55     (iso-8859-7 . Q)
  56     (iso-8859-8 . Q)
  57     (iso-8859-9 . Q)
  58     (iso-2022-jp . B)
  59     (iso-2022-kr . B)
  60     (gb2312 . B)
  61     (cn-gb . B)
  62     (cn-gb-2312 . B)
  63     (euc-kr . B)
  64     (iso-2022-jp-2 . B)
  65     (iso-2022-int-1 . B))
  66   "Alist of MIME charsets to RFC1522 encodings.
  67 Valid encodings are nil, `Q' and `B'.")
  68
  69 (defvar rfc1522-encoding-function-alist
  70   '((Q . rfc1522-q-encode-region)
  71     (B . base64-encode-region)
  72     (nil . ignore))
  73   "Alist of RFC1522 encodings to encoding functions.")
  74
  75 (defvar rfc1522-q-encoding-alist
  76   '(("\\(From\\|Cc\\|To\\|Bcc\||Reply-To\\):" . "[^-A-Za-z0-9!*+/=_]")
  77     ("." . "[\000-\007\013\015-\037\200-\377=_?]"))
  78   "Alist of header regexps and valid Q characters.")
  79
  80 ;;;
  81 ;;; Functions for encoding RFC1522 messages
  82 ;;;
  83
  84 (defun rfc1522-narrow-to-field ()
  85   "Narrow the buffer to the header on the current line."
  86   (beginning-of-line)
  87   (narrow-to-region
  88    (point)
  89    (progn
  90      (forward-line 1)
  91      (if (re-search-forward "^[^ \n\t]" nil t)
  92          (progn
  93            (beginning-of-line)
  94            (point))
  95        (point-max))))
  96   (goto-char (point-min)))
  97
  98 ;;;###autoload
  99 (defun rfc1522-encode-message-header ()
 100   "Encode the message header according to `rfc1522-header-encoding-alist'.
 101 Should be called narrowed to the head of the message."
 102   (interactive "*")
 103   (when (featurep 'mule)
 104     (save-excursion
 105       (let ((alist rfc1522-header-encoding-alist)
 106             elem method)
 107         (while (not (eobp))
 108           (save-restriction
 109             (rfc1522-narrow-to-field)
 110             (when (find-non-ascii-charset-region (point-min) (point-max))
 111               ;; We found something that may perhaps be encoded.
 112               (while (setq elem (pop alist))
 113                 (when (or (and (stringp (car elem))
 114                                (looking-at (car elem)))
 115                           (eq (car elem) t))
 116                   (setq alist nil
 117                         method (cdr elem))))
 118               (when method
 119                 (cond
 120                  ((eq method 'mime)
 121                   (rfc1522-encode-region (point-min) (point-max)))
 122                  ;; Hm.
 123                  (t))))
 124             (goto-char (point-max))))))))
 125
 126 (defun rfc1522-encode-region (b e)
 127   "Encode all encodable words in REGION."
 128   (let (prev c start qstart qprev qend)
 129     (save-excursion
 130       (goto-char b)
 131       (while (re-search-forward "[^ \t\n]+" nil t)
 132         (save-restriction
 133           (narrow-to-region (match-beginning 0) (match-end 0))
 134           (goto-char (setq start (point-min)))
 135           (setq prev nil)
 136           (while (not (eobp))
 137             (unless (eq (setq c (char-charset (following-char))) 'ascii)
 138               (cond
 139                ((eq c prev)
 140                 )
 141                ((null prev)
 142                 (setq qstart (or qstart start)
 143                       qend (point-max)
 144                       qprev c)
 145                 (setq prev c))
 146                (t
 147                 ;(rfc1522-encode start (setq start (point)) prev)
 148                 (setq prev c))))
 149             (forward-char 1)))
 150         (when (and (not prev) qstart)
 151           (rfc1522-encode qstart qend qprev)
 152           (setq qstart nil)))
 153       (when qstart
 154         (rfc1522-encode qstart qend qprev)
 155         (setq qstart nil)))))
 156
 157 (defun rfc1522-encode-string (string)
 158   "Encode words in STRING."
 159   (with-temp-buffer
 160     (insert string)
 161     (rfc1522-encode-region (point-min) (point-max))
 162     (buffer-string)))
 163
 164 (defun rfc1522-encode (b e charset)
 165   "Encode the word in the region with CHARSET."
 166   (let* ((mime-charset (mm-mule-charset-to-mime-charset charset))
 167          (encoding (cdr (assq mime-charset
 168                               rfc1522-charset-encoding-alist)))
 169          (start (concat
 170                  "=?" (downcase (symbol-name mime-charset)) "?"
 171                  (downcase (symbol-name encoding)) "?")))
 172     (save-restriction
 173       (narrow-to-region b e)
 174       (insert
 175        (prog1
 176            (mm-encode-coding-string (buffer-string) mime-charset)
 177          (delete-region (point-min) (point-max))))
 178       (funcall (cdr (assq encoding rfc1522-encoding-function-alist))
 179                (point-min) (point-max))
 180       (goto-char (point-min))
 181       (insert start)
 182       (goto-char (point-max))
 183       (insert "?=")
 184       ;; Encoded words can't be more than 75 chars long, so we have to
 185       ;; split the long ones up.
 186       (end-of-line)
 187       (while (> (current-column) 74)
 188         (beginning-of-line)
 189         (forward-char 73)
 190         (insert "?=\n " start)
 191         (end-of-line)))))
 192
 193 (defun rfc1522-q-encode-region (b e)
 194   "Encode the header contained in REGION with the Q encoding."
 195   (save-excursion
 196     (save-restriction
 197       (narrow-to-region (goto-char b) e)
 198       (let ((alist rfc1522-q-encoding-alist))
 199         (while alist
 200           (when (looking-at (caar alist))
 201             (quoted-printable-encode-region b e nil (cdar alist))
 202             (subst-char-in-region (point-min) (point-max) ?  ?_))
 203           (pop alist))))))
 204
 205 ;;;
 206 ;;; Functions for decoding RFC1522 messages
 207 ;;;
 208
 209 (defvar rfc1522-encoded-word-regexp
 210   "=\\?\\([^][\000-\040()<>@,\;:\\\"/?.=]+\\)\\?\\(B\\|Q\\)\\?\\([!->@-~]+\\)\\?=")
 211
 212 ;;;###autoload
 213 (defun rfc1522-decode-region (start end)
 214   "Decode MIME-encoded words in region between START and END."
 215   (interactive "r")
 216   (save-excursion
 217     (save-restriction
 218       (narrow-to-region start end)
 219       (goto-char (point-min))
 220       ;; Remove whitespace between encoded words.
 221       (while (re-search-forward
 222               (concat "\\(" rfc1522-encoded-word-regexp "\\)"
 223                       "\\(\n?[ \t]\\)+"
 224                       "\\(" rfc1522-encoded-word-regexp "\\)")
 225               nil t)
 226         (delete-region (goto-char (match-end 1)) (match-beginning 6)))
 227       ;; Decode the encoded words.
 228       (goto-char (point-min))
 229       (while (re-search-forward rfc1522-encoded-word-regexp nil t)
 230         (insert (rfc1522-parse-and-decode
 231                  (prog1
 232                      (match-string 0)
 233                    (delete-region (match-beginning 0) (match-end 0)))))))))
 234
 235 ;;;###autoload
 236 (defun rfc1522-decode-string (string)
 237  "Decode the quoted-printable-encoded STRING and return the results."
 238  (with-temp-buffer
 239    (insert string)
 240    (inline
 241      (rfc1522-decode-region (point-min) (point-max)))
 242    (buffer-string)))
 243
 244 (defun rfc1522-parse-and-decode (word)
 245   "Decode WORD and return it if it is an encoded word.
 246 Return WORD if not."
 247   (if (not (string-match rfc1522-encoded-word-regexp word))
 248       word
 249     (or
 250      (condition-case nil
 251          (rfc1522-decode
 252           (match-string 1 word)
 253           (upcase (match-string 2 word))
 254           (match-string 3 word))
 255        (error word))
 256      word)))
 257
 258 (defun rfc1522-decode (charset encoding string)
 259   "Decode STRING as an encoded text.
 260 Valid ENCODINGs are \"B\" and \"Q\".
 261 If your Emacs implementation can't decode CHARSET, it returns nil."
 262   (let ((cs (mm-charset-to-coding-system charset)))
 263     (when cs
 264       (mm-decode-coding-string
 265        (cond
 266         ((equal "B" encoding)
 267          (base64-decode string))
 268         ((equal "Q" encoding)
 269          (quoted-printable-decode-string
 270           (mm-replace-chars-in-string string ?_ ? )))
 271         (t (error "Invalid encoding: %s" encoding)))
 272        cs))))
 273
 274 (provide 'rfc1522)
 275
 276 ;;; rfc1522.el ends here