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

   1 ;;; mm-decode.el --- Functions for decoding 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 (require 'base64)
  28 (require 'qp)
  29 (require 'nnheader)
  30
  31 (defvar mm-charset-regexp (concat "[^" "][\000-\040()<>@,\;:\\\"/?.=" "]+"))
  32
  33 (defvar mm-encoded-word-regexp
  34   (concat "=\\?\\(" mm-charset-regexp "\\)\\?\\(B\\|Q\\)\\?"
  35           "\\([!->@-~]+\\)\\?="))
  36
  37 (defun mm-decode-words-region (start end)
  38   "Decode MIME-encoded words in region between START and END."
  39   (interactive "r")
  40   (save-excursion
  41     (save-restriction
  42       (narrow-to-region start end)
  43       (goto-char (point-min))
  44       ;; Remove whitespace between encoded words.
  45       (while (re-search-forward
  46               (concat "\\(" mm-encoded-word-regexp "\\)"
  47                       "\\(\n?[ \t]\\)+"
  48                       "\\(" mm-encoded-word-regexp "\\)")
  49               nil t)
  50         (delete-region (goto-char (match-end 1)) (match-beginning 6)))
  51       ;; Decode the encoded words.
  52       (goto-char (point-min))
  53       (while (re-search-forward mm-encoded-word-regexp nil t)
  54         (insert (mm-decode-word
  55                  (prog1
  56                      (match-string 0)
  57                    (delete-region (match-beginning 0) (match-end 0)))))))))
  58
  59 (defun mm-decode-words-string (string)
  60  "Decode the quoted-printable-encoded STRING and return the results."
  61  (with-temp-buffer
  62    (insert string)
  63    (inline
  64      (mm-decode-words-region (point-min) (point-max)))
  65    (buffer-string)))
  66
  67 (defun mm-decode-word (word)
  68   "Decode WORD and return it if it is an encoded word.
  69 Return WORD if not."
  70   (if (not (string-match mm-encoded-word-regexp word))
  71       word
  72     (or
  73      (condition-case nil
  74          (mm-decode-text
  75           (match-string 1 word)
  76           (upcase (match-string 2 word))
  77           (match-string 3 word))
  78        (error word))
  79      word)))
  80
  81 (eval-and-compile
  82   (if (fboundp 'decode-coding-string)
  83       (fset 'mm-decode-coding-string 'decode-coding-string)
  84     (fset 'mm-decode-coding-string (lambda (s a) s))))
  85
  86 (eval-and-compile
  87   (if (fboundp 'coding-system-list)
  88       (fset 'mm-coding-system-list 'coding-system-list)
  89     (fset 'mm-coding-system-list 'ignore)))
  90
  91 (defun mm-decode-text (charset encoding string)
  92   "Decode STRING as an encoded text.
  93 Valid ENCODINGs are \"B\" and \"Q\".
  94 If your Emacs implementation can't decode CHARSET, it returns nil."
  95   (let ((cs (mm-charset-to-coding-system charset)))
  96     (when cs
  97       (mm-decode-coding-string
  98        (cond
  99         ((equal "B" encoding)
 100          (base64-decode string))
 101         ((equal "Q" encoding)
 102          (quoted-printable-decode-string
 103           (nnheader-replace-chars-in-string string ?_ ? )))
 104         (t (error "Invalid encoding: %s" encoding)))
 105        cs))))
 106
 107 (defvar mm-charset-coding-system-alist
 108   (let ((rest
 109          '((us-ascii . iso-8859-1)
 110            (gb2312 . cn-gb-2312)
 111            (iso-2022-jp-2 . iso-2022-7bit-ss2)
 112            (x-ctext . ctext)))
 113         (systems (mm-coding-system-list))
 114         dest)
 115     (while rest
 116       (let ((pair (car rest)))
 117         (unless (memq (car pair) systems)
 118           (setq dest (cons pair dest))))
 119       (setq rest (cdr rest)))
 120     dest)
 121   "Charset/coding system alist.")
 122
 123 (defun mm-charset-to-coding-system (charset &optional lbt)
 124   "Return coding-system corresponding to CHARSET.
 125 CHARSET is a symbol naming a MIME charset.
 126 If optional argument LBT (`unix', `dos' or `mac') is specified, it is
 127 used as the line break code type of the coding system."
 128   (when (stringp charset)
 129     (setq charset (intern (downcase charset))))
 130   (setq charset
 131         (or (cdr (assq charset mm-charset-coding-system-alist))
 132             charset))
 133   (when lbt
 134     (setq charset (intern (format "%s-%s" charset lbt))))
 135   (cond
 136    ;; Running in a non-MULE environment.
 137    ((and (null (mm-coding-system-list))
 138          (eq charset 'iso-8859-1))
 139     charset)
 140    ;; Check to see whether we can handle this charset.
 141    ((memq charset (mm-coding-system-list))
 142     charset)
 143    ;; Nope.
 144    (t
 145     nil)))
 146
 147 (provide 'mm-decode)
 148
 149 ;; qp.el ends here