X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Frfc2047.el;h=081ba9b24a13421c5ad9aad4ec31eaed96c3d250;hb=29066f563c4fb40540835af4e82210b6367c7cee;hp=34683c3a64b7e4f47ef888f4515bde60dfd5f8b5;hpb=a0c6e9c55f781bf7dacc6c1ae7f405441fcf1071;p=gnus diff --git a/lisp/rfc2047.el b/lisp/rfc2047.el index 34683c3a6..081ba9b24 100644 --- a/lisp/rfc2047.el +++ b/lisp/rfc2047.el @@ -44,7 +44,7 @@ '(("Newsgroups" . nil) ("Followup-To" . nil) ("Message-ID" . nil) - ("\\(Resent-\\)?\\(From\\|Cc\\|To\\|Bcc\\|Reply-To\\|Sender\ + ("\\(Resent-\\)?\\(From\\|Cc\\|To\\|Bcc\\|\\(In-\\)?Reply-To\\|Sender\ \\|Mail-Followup-To\\|Mail-Copies-To\\|Approved\\)" . address-mime) (t . mime)) "*Header/encoding method alist. @@ -159,24 +159,25 @@ Should be called narrowed to the head of the message." (rfc2047-narrow-to-field) (if (not (rfc2047-encodable-p)) (prog1 - (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. - (mm-encode-coding-region - (point-min) (point-max) - (mm-charset-to-coding-system - (car message-posting-charset)))) + (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. + (mm-encode-coding-region + (point-min) (point-max) + (mm-charset-to-coding-system + (car message-posting-charset)))) ;; No encoding necessary, but folding is nice - (rfc2047-fold-region - (save-excursion - (goto-char (point-min)) - (skip-chars-forward "^:") - (when (looking-at ": ") - (forward-char 2)) - (point)) - (point-max))) + (when nil + (rfc2047-fold-region + (save-excursion + (goto-char (point-min)) + (skip-chars-forward "^:") + (when (looking-at ": ") + (forward-char 2)) + (point)) + (point-max)))) ;; We found something that may perhaps be encoded. (setq method nil alist rfc2047-header-encoding-alist) @@ -186,7 +187,6 @@ Should be called narrowed to the head of the message." (eq (car elem) t)) (setq alist nil method (cdr elem)))) - (goto-char (point-min)) (re-search-forward "^[^:]+: *" nil t) (cond ((eq method 'address-mime) @@ -270,8 +270,8 @@ The buffer may be narrowed." table)))) (modify-syntax-entry ?\\ "\\" table) (modify-syntax-entry ?\" "\"" table) - (modify-syntax-entry ?\( "." table) - (modify-syntax-entry ?\) "." table) + (modify-syntax-entry ?\( "(" table) + (modify-syntax-entry ?\) ")" table) (modify-syntax-entry ?\< "." table) (modify-syntax-entry ?\> "." table) (modify-syntax-entry ?\[ "." table) @@ -289,13 +289,14 @@ Dynamically bind `rfc2047-encoding-type' to change that." (save-restriction (narrow-to-region b e) (let ((encodable-regexp (if rfc2047-encode-encoded-words - "[^\000-\177]\\|=\\?" - "[^\000-\177]")) + "[^\000-\177]+\\|=\\?" + "[^\000-\177]+")) start ; start of current token - end ; end of current token + end begin csyntax ;; Whether there's an encoded word before the current token, ;; either immediately or separated by space. - last-encoded) + last-encoded + (orig-text (buffer-substring-no-properties b e))) (if (eq 'mime rfc2047-encoding-type) ;; Simple case. Continuous words in which all those contain ;; non-ASCII characters are encoded collectively. Encoding @@ -318,7 +319,7 @@ Dynamically bind `rfc2047-encoding-type' to change that." ;; `address-mime' case -- take care of quoted words, comments. (with-syntax-table rfc2047-syntax-table (goto-char (point-min)) - (condition-case nil ; in case of unbalanced quotes + (condition-case err ; in case of unbalanced quotes ;; Look for rfc2822-style: sequences of atoms, quoted ;; strings, specials, whitespace. (Specials mustn't be ;; encoded.) @@ -329,137 +330,185 @@ Dynamically bind `rfc2047-encoding-type' to change that." (cond ((not (char-after))) ; eob ;; else token start - ((eq ?\" (char-syntax (char-after))) + ((eq ?\" (setq csyntax (char-syntax (char-after)))) ;; Quoted word. (forward-sexp) (setq end (point)) ;; Does it need encoding? (goto-char start) - (skip-chars-forward "\000-\177" end) - (if (= end (point)) - (setq last-encoded nil) - ;; It needs encoding. Strip the quotes first, - ;; since encoded words can't occur in quotes. - (goto-char end) - (delete-backward-char 1) - (goto-char start) - (delete-char 1) - (when last-encoded - ;; There was a preceding quoted word. We need - ;; to include any separating whitespace in this - ;; word to avoid it getting lost. - (skip-chars-backward " \t") - ;; A space is needed between the encoded words. - (insert ? ) - (setq start (point) - end (1+ end))) - ;; Adjust the end position for the deleted quotes. - (rfc2047-encode start (- end 2)) - (setq last-encoded t))) ; record that it was encoded - ((eq ?. (char-syntax (char-after))) + (if (re-search-forward encodable-regexp end 'move) + ;; It needs encoding. Strip the quotes first, + ;; since encoded words can't occur in quotes. + (progn + (goto-char end) + (delete-backward-char 1) + (goto-char start) + (delete-char 1) + (when last-encoded + ;; There was a preceding quoted word. We need + ;; to include any separating whitespace in this + ;; word to avoid it getting lost. + (skip-chars-backward " \t") + ;; A space is needed between the encoded words. + (insert ? ) + (setq start (point) + end (1+ end))) + ;; Adjust the end position for the deleted quotes. + (rfc2047-encode start (- end 2)) + (setq last-encoded t)) ; record that it was encoded + (setq last-encoded nil))) + ((eq ?. csyntax) ;; Skip other delimiters, but record that they've ;; potentially separated quoted words. (forward-char) (setq last-encoded nil)) + ((eq ?\) csyntax) + (error "Unbalanced parentheses")) + ((eq ?\( csyntax) + ;; Look for the end of parentheses. + (forward-list) + ;; Encode text as an unstructured field. + (let ((rfc2047-encoding-type 'mime)) + (rfc2047-encode-region (1+ start) (1- (point)))) + (skip-chars-forward ")")) (t ; normal token/whitespace sequence ;; Find the end. + ;; Skip one ASCII word, or encode continuous words + ;; in which all those contain non-ASCII characters. + (setq end nil) + (while (not (or end (eobp))) + (when (looking-at "[\000-\177]+") + (setq begin (point) + end (match-end 0)) + (when (progn + (while (and (or (re-search-forward + "[ \t\n]\\|\\Sw" end 'move) + (setq end nil)) + (eq ?\\ (char-syntax (char-before)))) + ;; Skip backslash-quoted characters. + (forward-char)) + end) + (setq end (match-beginning 0)) + (if rfc2047-encode-encoded-words + (progn + (goto-char begin) + (when (search-forward "=?" end 'move) + (goto-char (match-beginning 0)) + (setq end nil))) + (goto-char end)))) + ;; Where the value nil of `end' means there may be + ;; text to have to be encoded following the point. + ;; Otherwise, the point reached to the end of ASCII + ;; words separated by whitespace or a special char. + (unless end + (when (looking-at encodable-regexp) + (goto-char (setq begin (match-end 0))) + (while (and (looking-at "[ \t\n]+\\([^ \t\n]+\\)") + (setq end (match-end 0)) + (progn + (while (re-search-forward + encodable-regexp end t)) + (< begin (point))) + (goto-char begin) + (or (not (re-search-forward "\\Sw" end t)) + (progn + (goto-char (match-beginning 0)) + nil))) + (goto-char end)) + (when (looking-at "[^ \t\n]+") + (setq end (match-end 0)) + (if (re-search-forward "\\Sw+" end t) + ;; There are special characters better + ;; to be encoded so that MTAs may parse + ;; them safely. + (cond ((= end (point))) + ((looking-at (concat "\\sw*\\(" + encodable-regexp + "\\)")) + (setq end nil)) + (t + (goto-char (1- (match-end 0))) + (unless (= (point) (match-beginning 0)) + ;; Separate encodable text and + ;; delimiter. + (insert " ")))) + (goto-char end) + (skip-chars-forward " \t\n") + (if (and (looking-at "[^ \t\n]+") + (string-match encodable-regexp + (match-string 0))) + (setq end nil) + (goto-char end))))))) (skip-chars-backward " \t\n") - (if (and (eq (char-before) ?\() - ;; Look for the end of parentheses. - (let ((string (buffer-substring (point) - (point-max))) - (default-major-mode 'fundamental-mode)) - ;; Use `standard-syntax-table'. - (with-temp-buffer - (insert "(" string) - (goto-char (point-min)) - (condition-case nil - (progn - (forward-list 1) - (setq end (- (point) 3))) - (error nil))))) - ;; Encode text as an unstructured field. - (let ((rfc2047-encoding-type 'mime)) - (rfc2047-encode-region start (+ (point) end)) - (forward-char)) - ;; Skip one ASCII word, or encode continuous words - ;; in which all those contain non-ASCII characters. - (skip-chars-forward " \t\n") - (setq end nil) - (while (not end) - (when (looking-at "[\000-\177]+") - (setq end (match-end 0)) - (if (re-search-forward "[ \t\n]\\|\\Sw" end t) - (goto-char (match-beginning 0)) - (goto-char end) - (setq end nil))) - (unless end - (setq end t) - (when (looking-at "[^\000-\177]+") - (goto-char (match-end 0)) - (while (and (looking-at "[ \t\n]+\\([^ \t\n]+\\)") - (setq end (match-end 0)) - (string-match "[^\000-\177]" - (match-string 1))) - (goto-char end)) - (when (looking-at "[^ \t\n]+") - (setq end (match-end 0)) - (if (re-search-forward "\\Sw+" end t) - ;; There are special characters better - ;; to be encoded so that MTAs may parse - ;; them safely. - (cond ((= end (point))) - ((looking-at "[^\000-\177]") - (setq end nil)) - (t - (goto-char (1- (match-end 0))) - (unless (= (point) (match-beginning 0)) - (insert " ")))) - (goto-char end) - (skip-chars-forward " \t\n") - (if (and (looking-at "[^ \t\n]+") - (string-match "[^\000-\177]" - (match-string 0))) - (setq end nil) - (goto-char end))))))) - (skip-chars-backward " \t\n") - (setq end (point)) - (goto-char start) - (skip-chars-forward "\000-\177" end) - (if (= end (point)) - (setq last-encoded nil) - (rfc2047-encode start end) - (setq last-encoded t)))))) + (setq end (point)) + (goto-char start) + (if (re-search-forward encodable-regexp end 'move) + (progn + (unless (memq (char-before start) '(nil ?\t ? )) + (if (progn + (goto-char start) + (skip-chars-backward "^ \t\n") + (and (looking-at "\\Sw+") + (= (match-end 0) start))) + ;; Also encode bogus delimiters. + (setq start (point)) + ;; Separate encodable text and delimiter. + (goto-char start) + (insert " ") + (setq start (1+ start) + end (1+ end)))) + (rfc2047-encode start end) + (setq last-encoded t)) + (setq last-encoded nil))))) (error - (error "Invalid data for rfc2047 encoding: %s" - (buffer-substring b e))))))) - (rfc2047-fold-region b (point)))) + (if (or debug-on-quit debug-on-error) + (signal (car err) (cdr err)) + (error "Invalid data for rfc2047 encoding: %s" + (mm-replace-in-string orig-text "[ \t\n]+" " ")))))))) + (rfc2047-fold-region b (point)) + (goto-char (point-max)))) (defun rfc2047-encode-string (string) "Encode words in STRING. By default, the string is treated as containing addresses (see `rfc2047-encoding-type')." - (with-temp-buffer + (mm-with-multibyte-buffer (insert string) (rfc2047-encode-region (point-min) (point-max)) (buffer-string))) -(defun rfc2047-encode-1 (column string cs encoder start space &optional eword) +(defvar rfc2047-encode-max-chars 76 + "Maximum characters of each header line that contain encoded-words. +If it is nil, encoded-words will not be folded. Too small value may +cause an error. Don't change this for no particular reason.") + +(defun rfc2047-encode-1 (column string cs encoder start crest tail + &optional eword) "Subroutine used by `rfc2047-encode'." (cond ((string-equal string "") (or eword "")) - ((>= column 76) - (when (and eword - (string-match "\n[ \t]+\\'" eword)) - ;; Reomove a superfluous empty line. - (setq eword (substring eword 0 (match-beginning 0)))) - (rfc2047-encode-1 (length space) string cs encoder start " " - (concat eword "\n" space))) + ((not rfc2047-encode-max-chars) + (concat start + (funcall encoder (if cs + (mm-encode-coding-string string cs) + string)) + "?=")) + ((>= column rfc2047-encode-max-chars) + (when eword + (cond ((string-match "\n[ \t]+\\'" eword) + ;; Reomove a superfluous empty line. + (setq eword (substring eword 0 (match-beginning 0)))) + ((string-match "(+\\'" eword) + ;; Break the line before the open parenthesis. + (setq crest (concat crest (match-string 0 eword)) + eword (substring eword 0 (match-beginning 0)))))) + (rfc2047-encode-1 (length crest) string cs encoder start " " tail + (concat eword "\n" crest))) (t (let ((index 0) (limit (1- (length string))) (prev "") - next) + next len) (while (and prev (<= index limit)) (setq next (concat start @@ -469,28 +518,48 @@ By default, the string is treated as containing addresses (see (substring string 0 (1+ index)) cs) (substring string 0 (1+ index)))) - "?=")) - (if (<= (+ column (length next)) 76) - (setq prev next - index (1+ index)) - (setq next prev - prev nil))) - (setq eword (concat eword next)) + "?=") + len (+ column (length next))) + (if (> len rfc2047-encode-max-chars) + (setq next prev + prev nil) + (if (or (< index limit) + (<= (+ len (or (string-match "\n" tail) + (length tail))) + rfc2047-encode-max-chars)) + (setq prev next + index (1+ index)) + (if (string-match "\\`)+" tail) + ;; Break the line after the close parenthesis. + (setq tail (concat (substring tail 0 (match-end 0)) + "\n " + (substring tail (match-end 0))) + prev next + index (1+ index)) + (setq next prev + prev nil))))) (if (> index limit) - eword + (concat eword next tail) + (if (= 0 index) + (if (and eword + (string-match "(+\\'" eword)) + (setq crest (concat crest (match-string 0 eword)) + eword (substring eword 0 (match-beginning 0))) + (setq eword (concat eword next))) + (setq crest " " + eword (concat eword next))) (when (string-match "\n[ \t]+\\'" eword) ;; Reomove a superfluous empty line. (setq eword (substring eword 0 (match-beginning 0)))) - (rfc2047-encode-1 (length space) (substring string index) - cs encoder start " " - (concat eword "\n" space))))))) + (rfc2047-encode-1 (length crest) (substring string index) + cs encoder start " " tail + (concat eword "\n" crest))))))) (defun rfc2047-encode (b e) "Encode the word(s) in the region B to E. -By default, the region is treated as containing addresses (see -`rfc2047-encoding-type')." +Point moves to the end of the region." (let ((mime-charset (or (mm-find-mime-charset-region b e) (list 'us-ascii))) - cs encoding space eword) + cs encoding tail crest eword) (cond ((> (length mime-charset) 1) (error "Can't rfc2047-encode `%s'" (buffer-substring-no-properties b e))) @@ -511,9 +580,19 @@ By default, the region is treated as containing addresses (see 'B 'Q))) (widen) + (goto-char e) + (skip-chars-forward "^ \t\n") + ;; `tail' may contain a close parenthesis. + (setq tail (buffer-substring-no-properties e (point))) (goto-char b) + (setq b (point-marker) + e (set-marker (make-marker) e)) + (rfc2047-fold-region (point-at-bol) b) + (goto-char b) + (skip-chars-backward "^ \t\n") (unless (= 0 (skip-chars-backward " \t")) - (setq space (buffer-substring-no-properties (point) b))) + ;; `crest' may contain whitespace and an open parenthesis. + (setq crest (buffer-substring-no-properties (point) b))) (setq eword (rfc2047-encode-1 (- b (point-at-bol)) (mm-replace-in-string @@ -525,13 +604,21 @@ By default, the region is treated as containing addresses (see 'identity) (concat "=?" (downcase (symbol-name mime-charset)) "?" (upcase (symbol-name encoding)) "?") - (or space " "))) + (or crest " ") + tail)) (delete-region (if (eq (aref eword 0) ?\n) - (point) + (if (bolp) + ;; The line was folded before encoding. + (1- (point)) + (point)) (goto-char b)) - e) + (+ e (length tail))) + ;; `eword' contains `crest' and `tail'. (insert eword) - (unless (or (eolp) + (set-marker b nil) + (set-marker e nil) + (unless (or (/= 0 (length tail)) + (eobp) (looking-at "[ \t\n)]")) (insert " ")))) (t @@ -602,9 +689,10 @@ By default, the region is treated as containing addresses (see (goto-char (or break qword-break)) (setq break nil qword-break nil) - (if (looking-at "[ \t]") - (insert ?\n) - (insert "\n ")) + (if (or (> 0 (skip-chars-backward " \t")) + (looking-at "[ \t]")) + (insert ?\n) + (insert "\n ")) (setq bol (1- (point))) ;; Don't break before the first non-LWSP characters. (skip-chars-forward " \t") @@ -661,6 +749,28 @@ By default, the region is treated as containing addresses (see (subst-char-in-region (point-min) (point-max) ? ?_) (buffer-string))) +(defun rfc2047-encode-parameter (param value) + "Return and PARAM=VALUE string encoded in the RFC2047-like style. +This is a replacement for the `rfc2231-encode-string' function. + +When attaching files as MIME parts, we should use the RFC2231 encoding +to specify the file names containing non-ASCII characters. However, +many mail softwares don't support it in practice and recipients won't +be able to extract files with correct names. Instead, the RFC2047-like +encoding is acceptable generally. This function provides the very +RFC2047-like encoding, resigning to such a regrettable trend. To use +it, put the following line in your ~/.gnus.el file: + +\(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 "[][()<>@,;:\\\"/?=]" ;; tspecials + string) + (format "%s=%S" param string) + (concat param "=" string)))) + ;;; ;;; Functions for decoding RFC2047 messages ;;; @@ -810,9 +920,8 @@ If your Emacs implementation can't decode CHARSET, return nil." (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)) + (when (eq cs 'ascii) + (setq cs (or mail-parse-charset 'raw-text))) (mm-decode-coding-string (cond ((char-equal ?B encoding)