;;; rfc2047.el --- Functions for encoding and decoding rfc2047 messages
-;; Copyright (C) 1998 Free Software Foundation, Inc.
+;; Copyright (C) 1998,99 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; MORIOKA Tomohiko <morioka@jaist.ac.jp>
;;; Code:
-(require 'base64)
+(eval-and-compile
+ (eval
+ '(unless (fboundp 'base64-decode-string)
+ (require 'base64))))
+
(require 'qp)
(require 'mm-util)
-
-(defvar rfc2047-unencoded-charsets '(ascii latin-iso8859-1)
- "List of MULE charsets not to encode.")
+(require 'ietf-drums)
+(require 'mail-prsvr)
(defvar rfc2047-header-encoding-alist
'(("Newsgroups" . nil)
(iso-8859-2 . Q)
(iso-8859-3 . Q)
(iso-8859-4 . Q)
- (iso-8859-5 . Q)
- (koi8-r . Q)
+ (iso-8859-5 . B)
+ (koi8-r . B)
(iso-8859-7 . Q)
(iso-8859-8 . Q)
(iso-8859-9 . Q)
(defvar rfc2047-encoding-function-alist
'((Q . rfc2047-q-encode-region)
- (B . base64-encode-region)
+ (B . rfc2047-b-encode-region)
(nil . ignore))
"Alist of RFC2047 encodings to encoding functions.")
(defvar rfc2047-q-encoding-alist
- '(("\\(From\\|Cc\\|To\\|Bcc\||Reply-To\\):" . "[^-A-Za-z0-9!*+/=_]")
- ("." . "[\000-\007\013\015-\037\200-\377=_?]"))
+ '(("\\(From\\|Cc\\|To\\|Bcc\||Reply-To\\):" . "-A-Za-z0-9!*+/=_")
+ ("." . "^\000-\007\013\015-\037\200-\377=_?"))
"Alist of header regexps and valid Q characters.")
;;;
(point-max))))
(goto-char (point-min)))
-;;;###autoload
(defun rfc2047-encode-message-header ()
"Encode the message header according to `rfc2047-header-encoding-alist'.
Should be called narrowed to the head of the message."
(interactive "*")
(when (featurep 'mule)
(save-excursion
+ (goto-char (point-min))
(let ((alist rfc2047-header-encoding-alist)
elem method)
(while (not (eobp))
(when method
(cond
((eq method 'mime)
- (rfc2047-encode-region (point-min) (point-max)))
+ (rfc2047-encode-region (point-min) (point-max))
+ (rfc2047-fold-region (point-min) (point-max)))
;; Hm.
(t))))
- (goto-char (point-max))))))))
+ (goto-char (point-max)))))
+ (when mail-parse-charset
+ (encode-coding-region (point-min) (point-max)
+ mail-parse-charset)))))
(defun rfc2047-encodable-p ()
"Say whether the current (narrowed) buffer contains characters that need encoding."
- (let ((charsets (find-charset-region (point-min) (point-max)))
- (cs rfc2047-unencoded-charsets)
+ (let ((charsets
+ (mapcar
+ 'mm-mime-charset
+ (mm-find-charset-region (point-min) (point-max))))
+ (cs (list 'us-ascii mail-parse-charset))
found)
(while charsets
(unless (memq (pop charsets) cs)
(setq found t)))
found))
+(defun rfc2047-dissect-region (b e)
+ "Dissect the region between B and E into words."
+ (let (words)
+ (save-restriction
+ (narrow-to-region b e)
+ (goto-char (point-min))
+ (while (re-search-forward
+ (concat "[^" ietf-drums-tspecials " \t\n]+") nil t)
+ (push
+ (list (match-beginning 0) (match-end 0)
+ (car (delq 'ascii (mm-find-charset-region
+ (match-beginning 0) (match-end 0)))))
+ words))
+ words)))
+
(defun rfc2047-encode-region (b e)
"Encode all encodable words in REGION."
- (let (prev c start qstart qprev qend)
- (save-excursion
- (goto-char b)
- (while (re-search-forward "[^ \t\n]+" nil t)
- (save-restriction
- (narrow-to-region (match-beginning 0) (match-end 0))
- (goto-char (setq start (point-min)))
- (setq prev nil)
- (while (not (eobp))
- (unless (eq (setq c (char-charset (following-char))) 'ascii)
- (cond
- ((eq c prev)
- )
- ((null prev)
- (setq qstart (or qstart start)
- qend (point-max)
- qprev c)
- (setq prev c))
- (t
- ;(rfc2047-encode start (setq start (point)) prev)
- (setq prev c))))
- (forward-char 1)))
- (when (and (not prev) qstart)
- (rfc2047-encode qstart qend qprev)
- (setq qstart nil)))
- (when qstart
- (rfc2047-encode qstart qend qprev)
- (setq qstart nil)))))
+ (let ((words (rfc2047-dissect-region b e))
+ beg end current word)
+ (while (setq word (pop words))
+ (if (equal (nth 2 word) current)
+ (setq beg (nth 0 word))
+ (when current
+ (rfc2047-encode beg end current))
+ (setq current (nth 2 word)
+ beg (nth 0 word)
+ end (nth 1 word))))
+ (when current
+ (rfc2047-encode beg end current))))
(defun rfc2047-encode-string (string)
"Encode words in STRING."
(defun rfc2047-encode (b e charset)
"Encode the word in the region with CHARSET."
- (let* ((mime-charset (mm-mule-charset-to-mime-charset charset))
- (encoding (cdr (assq mime-charset
- rfc2047-charset-encoding-alist)))
+ (let* ((mime-charset (mm-mime-charset charset))
+ (encoding (or (cdr (assq mime-charset
+ rfc2047-charset-encoding-alist))
+ 'B))
(start (concat
"=?" (downcase (symbol-name mime-charset)) "?"
- (downcase (symbol-name encoding)) "?")))
+ (downcase (symbol-name encoding)) "?"))
+ (first t))
(save-restriction
(narrow-to-region b e)
- (insert
- (prog1
- (mm-encode-coding-string (buffer-string) mime-charset)
- (delete-region (point-min) (point-max))))
+ (when (eq encoding 'B)
+ ;; break into lines before encoding
+ (goto-char (point-min))
+ (while (not (eobp))
+ (goto-char (min (point-max) (+ 15 (point))))
+ (unless (eobp)
+ (insert "\n"))))
+ (mm-encode-coding-region (point-min) (point-max) mime-charset)
(funcall (cdr (assq encoding rfc2047-encoding-function-alist))
(point-min) (point-max))
(goto-char (point-min))
- (insert start)
- (goto-char (point-max))
- (insert "?=")
- ;; Encoded words can't be more than 75 chars long, so we have to
- ;; split the long ones up.
- (end-of-line)
- (while (> (current-column) 74)
- (beginning-of-line)
- (forward-char 73)
- (insert "?=\n " start)
- (end-of-line)))))
+ (while (not (eobp))
+ (unless first
+ (insert " "))
+ (setq first nil)
+ (insert start)
+ (end-of-line)
+ (insert "?=")
+ (forward-line 1)))))
+
+(defun rfc2047-fold-region (b e)
+ "Fold the long lines in the region."
+ (save-restriction
+ (narrow-to-region b e)
+ (goto-char (point-min))
+ (let ((break nil))
+ (while (not (eobp))
+ (cond
+ ((memq (char-after) '(? ?\t))
+ (setq break (point)))
+ ((and (not break)
+ (looking-at "=\\?"))
+ (setq break (point)))
+ ((and (looking-at "\\?=")
+ (> (- (point) (save-excursion (beginning-of-line) (point))) 76))
+ (goto-char break)
+ (insert "\n ")
+ (forward-line 1)))
+ (unless (eobp)
+ (forward-char 1))))))
+
+(defun rfc2047-b-encode-region (b e)
+ "Encode the header contained in REGION with the B encoding."
+ (save-restriction
+ (narrow-to-region (goto-char b) e)
+ (while (not (eobp))
+ (base64-encode-region (point) (progn (end-of-line) (point)) t)
+ (if (and (bolp) (eolp))
+ (delete-backward-char 1))
+ (forward-line))))
(defun rfc2047-q-encode-region (b e)
"Encode the header contained in REGION with the Q encoding."
(while alist
(when (looking-at (caar alist))
(quoted-printable-encode-region b e nil (cdar alist))
- (subst-char-in-region (point-min) (point-max) ? ?_))
- (pop alist))))))
+ (subst-char-in-region (point-min) (point-max) ? ?_)
+ (setq alist nil))
+ (pop alist))
+ (goto-char (point-min))
+ (while (not (eobp))
+ (goto-char (min (point-max) (+ 64 (point))))
+ (search-backward "=" (- (point) 2) t)
+ (unless (eobp)
+ (insert "\n")))))))
;;;
;;; Functions for decoding RFC2047 messages
;;;
(defvar rfc2047-encoded-word-regexp
- "=\\?\\([^][\000-\040()<>@,\;:\\\"/?.=]+\\)\\?\\(B\\|Q\\)\\?\\([!->@-~]+\\)\\?=")
+ "=\\?\\([^][\000-\040()<>@,\;:\\\"/?.=]+\\)\\?\\(B\\|Q\\)\\?\\([!->@-~ +]+\\)\\?=")
-;;;###autoload
(defun rfc2047-decode-region (start end)
"Decode MIME-encoded words in region between START and END."
(interactive "r")
- (save-excursion
- (save-restriction
- (narrow-to-region start end)
- (goto-char (point-min))
- ;; Remove whitespace between encoded words.
- (while (re-search-forward
- (concat "\\(" rfc2047-encoded-word-regexp "\\)"
- "\\(\n?[ \t]\\)+"
- "\\(" rfc2047-encoded-word-regexp "\\)")
- nil t)
- (delete-region (goto-char (match-end 1)) (match-beginning 6)))
- ;; Decode the encoded words.
- (goto-char (point-min))
- (while (re-search-forward rfc2047-encoded-word-regexp nil t)
- (insert (rfc2047-parse-and-decode
- (prog1
- (match-string 0)
- (delete-region (match-beginning 0) (match-end 0)))))))))
+ (let ((case-fold-search t)
+ b e)
+ (save-excursion
+ (save-restriction
+ (narrow-to-region start end)
+ (goto-char (point-min))
+ ;; Remove whitespace between encoded words.
+ (while (re-search-forward
+ (concat "\\(" rfc2047-encoded-word-regexp "\\)"
+ "\\(\n?[ \t]\\)+"
+ "\\(" rfc2047-encoded-word-regexp "\\)")
+ nil t)
+ (delete-region (goto-char (match-end 1)) (match-beginning 6)))
+ ;; Decode the encoded words.
+ (setq b (goto-char (point-min)))
+ (while (re-search-forward rfc2047-encoded-word-regexp nil t)
+ (setq e (match-beginning 0))
+ (insert (rfc2047-parse-and-decode
+ (prog1
+ (match-string 0)
+ (delete-region (match-beginning 0) (match-end 0)))))
+ (when (and (mm-multibyte-p)
+ mail-parse-charset
+ (not (eq mail-parse-charset 'gnus-decoded)))
+ (mm-decode-coding-region b e mail-parse-charset))
+ (setq b (point)))
+ (when (and (mm-multibyte-p)
+ mail-parse-charset
+ (not (eq mail-parse-charset 'us-ascii))
+ (not (eq mail-parse-charset 'gnus-decoded)))
+ (mm-decode-coding-region b (point-max) mail-parse-charset))))))
-;;;###autoload
(defun rfc2047-decode-string (string)
- "Decode the quoted-printable-encoded STRING and return the results."
- (with-temp-buffer
- (insert string)
- (inline
- (rfc2047-decode-region (point-min) (point-max)))
- (buffer-string)))
+ "Decode the quoted-printable-encoded STRING and return the results."
+ (let ((m (mm-multibyte-p)))
+ (with-temp-buffer
+ (when m
+ (mm-enable-multibyte))
+ (insert string)
+ (inline
+ (rfc2047-decode-region (point-min) (point-max)))
+ (buffer-string))))
(defun rfc2047-parse-and-decode (word)
"Decode WORD and return it if it is an encoded word.
word)))
(defun rfc2047-decode (charset encoding string)
- "Decode STRING as an encoded text.
+ "Decode STRING that uses CHARSET with ENCODING.
Valid ENCODINGs are \"B\" and \"Q\".
If your Emacs implementation can't decode CHARSET, it returns nil."
+ (if (stringp charset)
+ (setq charset (intern (downcase charset))))
+ (if (or (not charset)
+ (eq 'gnus-all mail-parse-ignored-charsets)
+ (memq 'gnus-all mail-parse-ignored-charsets)
+ (memq charset mail-parse-ignored-charsets))
+ (setq charset mail-parse-charset))
(let ((cs (mm-charset-to-coding-system charset)))
+ (if (and (not cs) charset
+ (listp mail-parse-ignored-charsets)
+ (memq 'gnus-unknown mail-parse-ignored-charsets))
+ (setq cs (mm-charset-to-coding-system mail-parse-charset)))
(when cs
+ (when (and (eq cs 'ascii)
+ mail-parse-charset)
+ (setq cs mail-parse-charset))
(mm-decode-coding-string
(cond
((equal "B" encoding)
- (base64-decode string))
+ (base64-decode-string string))
((equal "Q" encoding)
(quoted-printable-decode-string
(mm-replace-chars-in-string string ?_ ? )))
projects / elisp / gnus.git- / blobdiff