X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Frfc2047.el;h=c3afdc49cb54f71ac32f4256ba46136a06919c99;hb=f702159a4d7cb8471a17884108880aa8d7961728;hp=3b76718755a7bbce51590571e0ccd40b3dcf4dd3;hpb=aa5b48ff62cfe04cd016fbd5e546c962b457e7c0;p=elisp%2Fgnus.git- diff --git a/lisp/rfc2047.el b/lisp/rfc2047.el index 3b76718..c3afdc4 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. @@ -292,7 +292,7 @@ Dynamically bind `rfc2047-encoding-type' to change that." "[^\000-\177]+\\|=\\?" "[^\000-\177]+")) start ; start of current token - end begin + end begin csyntax ;; Whether there's an encoded word before the current token, ;; either immediately or separated by space. last-encoded @@ -319,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.) @@ -330,7 +330,7 @@ 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)) @@ -357,48 +357,63 @@ Dynamically bind `rfc2047-encoding-type' to change that." (rfc2047-encode start (- end 2)) (setq last-encoded t)) ; record that it was encoded (setq last-encoded nil))) - ((eq ?. (char-syntax (char-after))) + ((eq ?. csyntax) ;; Skip other delimiters, but record that they've ;; potentially separated quoted words. (forward-char) (setq last-encoded nil)) - ((eq ?\) (char-syntax (char-after))) + ((eq ?\) csyntax) (error "Unbalanced parentheses")) - ((eq ?\( (char-syntax (char-after))) + ((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))) - (forward-char))) + (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 end) + (while (not (or end (eobp))) (when (looking-at "[\000-\177]+") (setq begin (point) end (match-end 0)) - (if (re-search-forward "[ \t\n]\\|\\Sw" end 'move) - (progn - (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))) - (setq end nil))) + (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 - (setq end t) (when (looking-at encodable-regexp) - (goto-char (match-end 0)) + (goto-char (setq begin (match-end 0))) (while (and (looking-at "[ \t\n]+\\([^ \t\n]+\\)") (setq end (match-end 0)) - (string-match encodable-regexp - (match-string 1))) + (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)) @@ -407,11 +422,15 @@ Dynamically bind `rfc2047-encoding-type' to change that." ;; to be encoded so that MTAs may parse ;; them safely. (cond ((= end (point))) - ((looking-at encodable-regexp) + ((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") @@ -425,12 +444,27 @@ Dynamically bind `rfc2047-encoding-type' to change that." (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" - (mm-replace-in-string orig-text "[ \t\n]+" " "))))))) + (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)))) @@ -443,22 +477,38 @@ By default, the string is treated as containing addresses (see (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 @@ -468,27 +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. 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))) @@ -509,12 +580,19 @@ Point moves to the end of the region." '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 @@ -526,15 +604,21 @@ Point moves to the end of the region." '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) (set-marker b nil) (set-marker e nil) - (unless (or (eolp) + (unless (or (/= 0 (length tail)) + (eobp) (looking-at "[ \t\n)]")) (insert " ")))) (t @@ -605,9 +689,10 @@ Point moves to the end of the region." (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") @@ -664,6 +749,28 @@ Point moves to the end of the region." (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 ;;;