;;; rfc2047.el --- functions for encoding and decoding rfc2047 messages
-;; Copyright (C) 1998, 1999, 2000, 2002, 2003, 2004,
-;; 2005, 2006 Free Software Foundation, Inc.
+;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
+;; 2005, 2006, 2007 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; MORIOKA Tomohiko <morioka@jaist.ac.jp>
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
+;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
(eval-when-compile
(require 'cl)
- (defvar message-posting-charset)
- (unless (fboundp 'with-syntax-table) ; not in Emacs 20
- (defmacro with-syntax-table (table &rest body)
- "Evaluate BODY with syntax table of current buffer set to TABLE.
-The syntax table of the current buffer is saved, BODY is evaluated, and the
-saved table is restored, even in case of an abnormal exit.
-Value is what BODY returns."
- (let ((old-table (make-symbol "table"))
- (old-buffer (make-symbol "buffer")))
- `(let ((,old-table (syntax-table))
- (,old-buffer (current-buffer)))
- (unwind-protect
- (progn
- (set-syntax-table ,table)
- ,@body)
- (save-current-buffer
- (set-buffer ,old-buffer)
- (set-syntax-table ,old-table))))))))
+ (defvar message-posting-charset))
(require 'qp)
(require 'mm-util)
(require 'ietf-drums)
;; Fixme: Avoid this (used for mail-parse-charset) mm dependence on gnus.
(require 'mail-prsvr)
-(require 'base64)
+(require 'rfc2045) ;; rfc2045-encode-string
(autoload 'mm-body-7-or-8 "mm-bodies")
-(eval-and-compile
- ;; Avoid gnus-util for mm- code.
- (defalias 'rfc2047-point-at-bol
- (if (fboundp 'point-at-bol)
- 'point-at-bol
- 'line-beginning-position))
-
- (defalias 'rfc2047-point-at-eol
- (if (fboundp 'point-at-eol)
- 'point-at-eol
- 'line-end-position)))
-
(defvar rfc2047-header-encoding-alist
'(("Newsgroups" . nil)
("Followup-To" . nil)
(progn
(forward-line 1)
(if (re-search-forward "^[^ \n\t]" nil t)
- (rfc2047-point-at-bol)
+ (point-at-bol)
(point-max))))
(goto-char (point-min)))
(re-search-forward ":[ \t\n]*" nil t)
(buffer-substring-no-properties (point) (point-max)))))
+(defun rfc2047-quote-special-characters-in-quoted-strings (&optional
+ encodable-regexp)
+ "Quote special characters with `\\'s in quoted strings.
+Quoting will not be done in a quoted string if it contains characters
+matching ENCODABLE-REGEXP or it is within parentheses."
+ (goto-char (point-min))
+ (let ((tspecials (concat "[" ietf-drums-tspecials "]"))
+ (start (point))
+ beg end)
+ (with-syntax-table (standard-syntax-table)
+ (while (not (eobp))
+ (if (ignore-errors
+ (forward-list 1)
+ (eq (char-before) ?\)))
+ (forward-list -1)
+ (goto-char (point-max)))
+ (save-restriction
+ (narrow-to-region start (point))
+ (goto-char start)
+ (while (search-forward "\"" nil t)
+ (setq beg (match-beginning 0))
+ (unless (eq (char-before beg) ?\\)
+ (goto-char beg)
+ (setq beg (1+ beg))
+ (condition-case nil
+ (progn
+ (forward-sexp)
+ (setq end (1- (point)))
+ (goto-char beg)
+ (if (and encodable-regexp
+ (re-search-forward encodable-regexp end t))
+ (goto-char (1+ end))
+ (save-restriction
+ (narrow-to-region beg end)
+ (while (re-search-forward tspecials nil 'move)
+ (if (eq (char-before) ?\\)
+ (if (looking-at tspecials) ;; Already quoted.
+ (forward-char)
+ (insert "\\"))
+ (goto-char (match-beginning 0))
+ (insert "\\")
+ (forward-char))))
+ (forward-char)))
+ (error
+ (goto-char beg)))))
+ (goto-char (point-max)))
+ (forward-list 1)
+ (setq start (point))))))
+
(defvar rfc2047-encoding-type 'address-mime
"The type of encoding done by `rfc2047-encode-region'.
This should be dynamically bound around calls to
(while (not (eobp))
(save-restriction
(rfc2047-narrow-to-field)
+ (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))))
(if (not (rfc2047-encodable-p))
- (prog1
+ (prog2
+ (when (eq method 'address-mime)
+ (rfc2047-quote-special-characters-in-quoted-strings))
(if (and (eq (mm-body-7-or-8) '8bit)
(mm-multibyte-p)
(mm-coding-system-p
(point))
(point-max))))
;; 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))))
(re-search-forward "^[^:]+: *" nil t)
(cond
((eq method 'address-mime)
;;; (rfc2047-encode-region (point-min) (point-max))
;;; (error "Cannot send unencoded text")))
((mm-coding-system-p method)
- (if (and (featurep 'mule)
- (if (boundp 'default-enable-multibyte-characters)
- default-enable-multibyte-characters))
+ (if (or (and (featurep 'mule)
+ (if (boundp 'default-enable-multibyte-characters)
+ default-enable-multibyte-characters))
+ (featurep 'file-coding))
(mm-encode-coding-region (point) (point-max) method)))
;; Hm.
(t)))
(rfc2047-encode start (point))
(goto-char end))))
;; `address-mime' case -- take care of quoted words, comments.
+ (rfc2047-quote-special-characters-in-quoted-strings encodable-regexp)
(with-syntax-table rfc2047-syntax-table
(goto-char (point-min))
(condition-case err ; in case of unbalanced quotes
(goto-char b)
(setq b (point-marker)
e (set-marker (make-marker) e))
- (rfc2047-fold-region (rfc2047-point-at-bol) b)
+ (rfc2047-fold-region (point-at-bol) b)
(goto-char b)
(skip-chars-backward "^ \t\n")
(unless (= 0 (skip-chars-backward " \t"))
;; `crest' may contain whitespace and an open parenthesis.
(setq crest (buffer-substring-no-properties (point) b)))
(setq eword (rfc2047-encode-1
- (- b (rfc2047-point-at-bol))
+ (- b (point-at-bol))
(mm-replace-in-string
(buffer-substring-no-properties b e)
"\n\\([ \t]?\\)" "\\1")
(first t)
(bol (save-restriction
(widen)
- (rfc2047-point-at-bol))))
+ (point-at-bol))))
(while (not (eobp))
(when (and (or break qword-break)
(> (- (point) bol) 76))
(goto-char (point-min))
(let ((bol (save-restriction
(widen)
- (rfc2047-point-at-bol)))
- (eol (rfc2047-point-at-eol)))
+ (point-at-bol)))
+ (eol (point-at-eol)))
(forward-line 1)
(while (not (eobp))
(if (and (looking-at "[ \t]")
- (< (- (rfc2047-point-at-eol) bol) 76))
+ (< (- (point-at-eol) bol) 76))
(delete-region eol (progn
(goto-char eol)
(skip-chars-forward "\r\n")
(point)))
- (setq bol (rfc2047-point-at-bol)))
- (setq eol (rfc2047-point-at-eol))
+ (setq bol (point-at-bol)))
+ (setq eol (point-at-eol))
(forward-line 1)))))
(defun rfc2047-b-encode-string (string)
\(defalias 'mail-header-encode-parameter 'rfc2047-encode-parameter)
"
- (let* ((rfc2047-encoding-type 'mime)
- (rfc2047-encode-max-chars nil)
- (string (rfc2047-encode-string value)))
- (if (string-match (concat "[" ietf-drums-tspecials "]") string)
- (format "%s=%S" param string)
- (concat param "=" string))))
+ (let ((rfc2047-encoding-type 'mime)
+ (rfc2047-encode-max-chars nil))
+ (rfc2045-encode-string param (rfc2047-encode-string value))))
;;;
;;; Functions for decoding RFC2047 messages
(eval-and-compile
(defconst rfc2047-encoded-word-regexp
- "=\\?\\([^][\000-\040()<>@,\;:*\\\"/?.=]+\\)\\(\\*[^?]+\\)?\
+ "=\\?\\([^][\000-\040()<>@,\;:*\\\"/?.=]+\\)\\(?:\\*[^?]+\\)?\
\\?\\(B\\|Q\\)\\?\\([!->@-~ ]*\\)\\?="))
(defvar rfc2047-quote-decoded-words-containing-tspecials nil
the decoder will fully decode each encoded-word before concatenating
them.")
+(defun rfc2047-strip-backslashes-in-quoted-strings ()
+ "Strip backslashes in quoted strings. `\\\"' remains."
+ (goto-char (point-min))
+ (let (beg)
+ (with-syntax-table (standard-syntax-table)
+ (while (search-forward "\"" nil t)
+ (unless (eq (char-before) ?\\)
+ (setq beg (match-end 0))
+ (goto-char (match-beginning 0))
+ (condition-case nil
+ (progn
+ (forward-sexp)
+ (save-restriction
+ (narrow-to-region beg (1- (point)))
+ (goto-char beg)
+ (while (search-forward "\\" nil 'move)
+ (unless (memq (char-after) '(?\"))
+ (delete-backward-char 1))
+ (forward-char)))
+ (forward-char))
+ (error
+ (goto-char beg))))))))
+
(defun rfc2047-charset-to-coding-system (charset)
"Return coding-system corresponding to MIME CHARSET.
If your Emacs implementation can't decode CHARSET, return nil."
;; and worthwhile (is it more correct or not?), e.g. something like
;; `=?iso-8859-1?q?foo?=@'.
-(defun rfc2047-decode-region (start end)
- "Decode MIME-encoded words in region between START and END."
+(defun rfc2047-decode-region (start end &optional address-mime)
+ "Decode MIME-encoded words in region between START and END.
+If ADDRESS-MIME is non-nil, strip backslashes which precede characters
+other than `\"' and `\\' in quoted strings."
(interactive "r")
(let ((case-fold-search t)
(eword-regexp (eval-when-compile
(save-excursion
(save-restriction
(narrow-to-region start end)
+ (when address-mime
+ (rfc2047-strip-backslashes-in-quoted-strings))
(goto-char (setq b start))
;; Look for the encoded-words.
(while (setq match (re-search-forward eword-regexp nil t))
words nil)
(while match
(push (list (match-string 2) ;; charset
- (char-after (match-beginning 4)) ;; encoding
- (match-string 5) ;; encoded-text
+ (char-after (match-beginning 3)) ;; encoding
+ (match-string 4) ;; encoded-text
(match-string 1)) ;; encoded-word
words)
;; Look for the subsequent encoded-words.
(not (eq mail-parse-charset 'gnus-decoded)))
(mm-decode-coding-region b (point-max) mail-parse-charset))))))
-(defun rfc2047-decode-string (string)
- "Decode the quoted-printable-encoded STRING and return the results."
+(defun rfc2047-decode-address-region (start end)
+ "Decode MIME-encoded words in region between START and END.
+Backslashes which precede characters other than `\"' and `\\' in quoted
+strings are stripped."
+ (rfc2047-decode-region start end t))
+
+(defun rfc2047-decode-string (string &optional address-mime)
+ "Decode MIME-encoded STRING and return the result.
+If ADDRESS-MIME is non-nil, strip backslashes which precede characters
+other than `\"' and `\\' in quoted strings."
(let ((m (mm-multibyte-p)))
(if (string-match "=\\?" string)
(with-temp-buffer
(mm-enable-multibyte))
(insert string)
(inline
- (rfc2047-decode-region (point-min) (point-max)))
+ (rfc2047-decode-region (point-min) (point-max) address-mime))
(buffer-string))
+ (when address-mime
+ (setq string
+ (with-temp-buffer
+ (when (mm-multibyte-string-p string)
+ (mm-enable-multibyte))
+ (insert string)
+ (rfc2047-strip-backslashes-in-quoted-strings)
+ (buffer-string))))
;; Fixme: As above, `m' here is inappropriate.
(if (and m
mail-parse-charset
(mm-decode-coding-string string mail-parse-charset))
(mm-string-as-multibyte string)))))
+(defun rfc2047-decode-address-string (string)
+ "Decode MIME-encoded STRING and return the result.
+Backslashes which precede characters other than `\"' and `\\' in quoted
+strings are stripped."
+ (rfc2047-decode-string string t))
+
(defun rfc2047-pad-base64 (string)
"Pad STRING to quartets."
;; Be more liberal to accept buggy base64 strings. If