;;; rfc2047.el --- Functions for encoding and decoding rfc2047 messages
-;; Copyright (C) 1998,99 Free Software Foundation, Inc.
+;; Copyright (C) 1998, 1999, 2000 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; MORIOKA Tomohiko <morioka@jaist.ac.jp>
1) nil, in which case no encoding is done;
2) `mime', in which case the header will be encoded according to RFC2047;
-3) a charset, in which case it will be encoded as that charse;
+3) a charset, in which case it will be encoded as that charset;
4) `default', in which case the field will be encoded as the rest
of the article.")
(iso-8859-7 . Q)
(iso-8859-8 . Q)
(iso-8859-9 . Q)
+ (iso-8859-14 . Q)
+ (iso-8859-15 . Q)
(iso-2022-jp . B)
(iso-2022-kr . B)
(gb2312 . B)
"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!*+/")
+ ;; = (\075), _ (\137), ? (\077) are used in the encoded word.
+ ;; Avoid using 8bit characters. Some versions of Emacs has bug!
+ ;; Equivalent to "^\000-\007\011\013\015-\037\200-\377=_?"
+ ("." . "\010\012\014\040-\074\076\100-\136\140-\177"))
"Alist of header regexps and valid Q characters.")
;;;
"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))
- (save-restriction
- (rfc2047-narrow-to-field)
- (when (rfc2047-encodable-p)
- ;; We found something that may perhaps be encoded.
- (while (setq elem (pop alist))
- (when (or (and (stringp (car elem))
- (looking-at (car elem)))
- (eq (car elem) t))
- (setq alist nil
- method (cdr elem))))
- (when method
- (cond
- ((eq method 'mime)
- (rfc2047-encode-region (point-min) (point-max)))
- ;; Hm.
- (t))))
- (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 (mapcar
- 'mm-mule-charset-to-mime-charset
- (mm-find-charset-region (point-min) (point-max))))
- (cs (list 'us-ascii mail-parse-charset))
+ (save-excursion
+ (goto-char (point-min))
+ (let (alist elem method)
+ (while (not (eobp))
+ (save-restriction
+ (rfc2047-narrow-to-field)
+ (if (not (rfc2047-encodable-p))
+ (if (and (eq (mm-body-7-or-8) '8bit)
+ (mm-multibyte-p)
+ (mm-coding-system-p
+ (car message-posting-charset)))
+ ;; 8 bit must be decoded.
+ ;; Is message-posting-charset a coding system?
+ (mm-encode-coding-region
+ (point-min) (point-max)
+ (car message-posting-charset)))
+ ;; We found something that may perhaps be encoded.
+ (setq method nil
+ alist rfc2047-header-encoding-alist)
+ (while (setq elem (pop alist))
+ (when (or (and (stringp (car elem))
+ (looking-at (car elem)))
+ (eq (car elem) t))
+ (setq alist nil
+ method (cdr elem))))
+ (cond
+ ((eq method 'mime)
+ (rfc2047-encode-region (point-min) (point-max)))
+ ((eq method 'default)
+ (if (and (featurep 'mule)
+ mail-parse-charset)
+ (mm-encode-coding-region (point-min) (point-max)
+ mail-parse-charset)))
+ ((mm-coding-system-p method)
+ (if (featurep 'mule)
+ (mm-encode-coding-region (point-min) (point-max) method)))
+ ;; Hm.
+ (t)))
+ (goto-char (point-max)))))))
+
+(defun rfc2047-encodable-p (&optional header)
+ "Say whether the current (narrowed) buffer contains characters that need encoding in headers."
+ (let ((charsets
+ (mapcar
+ 'mm-mime-charset
+ (mm-find-charset-region (point-min) (point-max))))
+ (cs (list 'us-ascii (car message-posting-charset)))
found)
(while charsets
(unless (memq (pop charsets) cs)
(defun rfc2047-dissect-region (b e)
"Dissect the region between B and E into words."
- (let (words)
+ (let ((word-chars "-A-Za-z0-9!*+/")
+ ;; Not using ietf-drums-specials-token makes life simple.
+ mail-parse-mule-charset
+ words point current
+ result word)
(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)))
+ (skip-chars-forward "\000-\177")
+ (while (not (eobp))
+ (setq point (point))
+ (skip-chars-backward word-chars b)
+ (unless (eq b (point))
+ (push (cons (buffer-substring b (point)) nil) words))
+ (setq b (point))
+ (goto-char point)
+ (setq current (mm-charset-after))
+ (forward-char 1)
+ (skip-chars-forward word-chars)
+ (while (and (not (eobp))
+ (eq (mm-charset-after) current))
+ (forward-char 1)
+ (skip-chars-forward word-chars))
+ (unless (eq b (point))
+ (push (cons (buffer-substring b (point)) current) words))
+ (setq b (point))
+ (skip-chars-forward "\000-\177"))
+ (unless (eq b (point))
+ (push (cons (buffer-substring b (point)) nil) words)))
+ ;; merge adjacent words
+ (setq word (pop words))
+ (while word
+ (if (and (cdr word)
+ (caar words)
+ (not (cdar words))
+ (string-match "^[ \t]+$" (caar words)))
+ (if (eq (cdr (nth 1 words)) (cdr word))
+ (progn
+ (setq word (cons (concat
+ (car (nth 1 words)) (caar words)
+ (car word))
+ (cdr word)))
+ (pop words)
+ (pop words))
+ (push (cons (concat (caar words) (car word)) (cdr word))
+ result)
+ (pop words)
+ (setq word (pop words)))
+ (push word result)
+ (setq word (pop words))))
+ result))
(defun rfc2047-encode-region (b e)
"Encode all encodable words in REGION."
- (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))))
+ (let ((words (rfc2047-dissect-region b e)) word)
+ (save-restriction
+ (narrow-to-region b e)
+ (delete-region (point-min) (point-max))
+ (while (setq word (pop words))
+ (if (not (cdr word))
+ (insert (car word))
+ (rfc2047-fold-region (gnus-point-at-bol) (point))
+ (goto-char (point-max))
+ (if (> (- (point) (save-restriction
+ (widen)
+ (gnus-point-at-bol))) 76)
+ (insert "\n "))
+ ;; Insert blank between encoded words
+ (if (eq (char-before) ?=) (insert " "))
+ (rfc2047-encode (point)
+ (progn (insert (car word)) (point))
+ (cdr word))))
+ (rfc2047-fold-region (point-min) (point-max)))))
(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-mime-charset charset b e))
+ (let* ((mime-charset (mm-mime-charset charset))
(encoding (or (cdr (assq mime-charset
- rfc2047-charset-encoding-alist))
+ rfc2047-charset-encoding-alist))
'B))
(start (concat
"=?" (downcase (symbol-name mime-charset)) "?"
(first t))
(save-restriction
(narrow-to-region b e)
- (mm-encode-coding-region b e mime-charset)
+ (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"))))
+ (if (and (mm-multibyte-p)
+ (mm-coding-system-p mime-charset))
+ (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 "?=")
(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)
+ (bol (save-restriction
+ (widen)
+ (gnus-point-at-bol))))
+ (while (not (eobp))
+ (when (and break (> (- (point) bol) 76))
+ (goto-char break)
+ (setq break nil)
+ (insert "\n ")
+ (setq bol (1- (point)))
+ ;; Don't break before the first non-LWSP characters.
+ (skip-chars-forward " \t")
+ (forward-char 1))
+ (cond
+ ((eq (char-after) ?\n)
+ (forward-char 1)
+ (setq bol (point))
+ (skip-chars-forward " \t")
+ (unless (or (eobp) (eq (char-after) ?\n))
+ (forward-char 1)))
+ ((eq (char-after) ?\r)
+ (forward-char 1))
+ ((memq (char-after) '(? ?\t))
+ (skip-chars-forward " \t")
+ (setq break (1- (point))))
+ ((not break)
+ (if (not (looking-at "=\\?"))
+ (if (eq (char-after) ?=)
+ (forward-char 1)
+ (skip-chars-forward "^ \t="))
+ (setq break (point))
+ (skip-chars-forward "^ \t")))
+ (t
+ (skip-chars-forward "^ \t")))))))
+
+(defun rfc2047-unfold-region (b e)
+ "Fold the long lines in the region."
+ (save-restriction
+ (narrow-to-region b e)
+ (goto-char (point-min))
+ (let ((bol (save-restriction
+ (widen)
+ (gnus-point-at-bol)))
+ (eol (gnus-point-at-eol))
+ leading)
+ (forward-line 1)
+ (while (not (eobp))
+ (looking-at "[ \t]*")
+ (setq leading (- (match-end 0) (match-beginning 0)))
+ (if (< (- (gnus-point-at-eol) bol leading) 76)
+ (progn
+ (goto-char eol)
+ (delete-region eol (progn
+ (skip-chars-forward "[ \t\n\r]+")
+ (1- (point)))))
+ (setq bol (gnus-point-at-bol)))
+ (setq eol (gnus-point-at-eol))
+ (forward-line 1)))))
+
(defun rfc2047-b-encode-region (b e)
"Encode the header contained in REGION with the B encoding."
- (base64-encode-region b e t)
- (goto-char (point-min))
- (while (not (eobp))
- (goto-char (min (point-max) (+ 64 (point))))
- (unless (eobp)
- (insert "\n"))))
+ (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."
(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))))
+ (goto-char (1+ (point-min)))
+ (while (and (not (bobp)) (not (eobp)))
+ (goto-char (min (point-max) (save-restriction
+ (widen)
+ ;; THe QP encapsulation is about 20.
+ (+ 56 (gnus-point-at-bol)))))
(search-backward "=" (- (point) 2) t)
- (unless (eobp)
+ (unless (or (bobp) (eobp))
(insert "\n")))))))
;;;
(prog1
(match-string 0)
(delete-region (match-beginning 0) (match-end 0)))))
- (when (and (mm-multibyte-p) mail-parse-charset)
+ (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)))
- (mm-decode-coding-region b (point-max) 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))
+ (rfc2047-unfold-region (point-min) (point-max))))))
(defun rfc2047-decode-string (string)
"Decode the quoted-printable-encoded STRING and return the results."
"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 string))
- ((equal "Q" encoding)
- (quoted-printable-decode-string
- (mm-replace-chars-in-string string ?_ ? )))
- (t (error "Invalid encoding: %s" encoding)))
- cs))))
+ (mm-with-unibyte-current-buffer
+ ;; In Emacs Mule 4, decoding UTF-8 should be in unibyte mode.
+ (mm-decode-coding-string
+ (cond
+ ((equal "B" encoding)
+ (base64-decode-string string))
+ ((equal "Q" encoding)
+ (quoted-printable-decode-string
+ (mm-replace-chars-in-string string ?_ ? )))
+ (t (error "Invalid encoding: %s" encoding)))
+ cs)))))
(provide 'rfc2047)
projects / gnus / blobdiff