X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Frfc2047.el;h=ff07547c6d28e3c709ab8fc582b34f452c0abac1;hb=2ee42624a6069cf91f228bdf578e3e5d1f044d5d;hp=6e7512c50f0b7f30cd7fba8d843d8a9407bee394;hpb=09868cf7efbfa51562d76580eafc9a7b6b0c8d72;p=elisp%2Fgnus.git- diff --git a/lisp/rfc2047.el b/lisp/rfc2047.el index 6e7512c..ff07547 100644 --- a/lisp/rfc2047.el +++ b/lisp/rfc2047.el @@ -1,5 +1,5 @@ ;;; 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 ;; MORIOKA Tomohiko @@ -46,7 +46,7 @@ The values can be: 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.") @@ -80,7 +80,7 @@ Valid encodings are nil, `Q' and `B'.") (defvar rfc2047-q-encoding-alist '(("\\(From\\|Cc\\|To\\|Bcc\||Reply-To\\):" . "-A-Za-z0-9!*+/=_") - ("." . "^\000-\007\013\015-\037\200-\377=_?")) + ("." . "^\000-\007\011\013\015-\037\200-\377=_?")) "Alist of header regexps and valid Q characters.") ;;; @@ -105,41 +105,45 @@ Valid encodings are nil, `Q' and `B'.") "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)) - (rfc2047-fold-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." + (save-excursion + (goto-char (point-min)) + (let ((alist rfc2047-header-encoding-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. + (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)) + (rfc2047-fold-region (point-min) (point-max))) + ;; 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 mail-parse-charset)) + (cs (list 'us-ascii (car message-posting-charset))) found) (while charsets (unless (memq (pop charsets) cs) @@ -148,18 +152,60 @@ Should be called narrowed to the head of the message." (defun rfc2047-dissect-region (b e) "Dissect the region between B and E into words." - (let (words) + (let ((all-specials (concat ietf-drums-tspecials " \t\n\r")) + (special-list (mapcar 'identity ietf-drums-tspecials)) + (blank-list '(? ?\t ?\n ?\r)) + words current cs state mail-parse-mule-charset) (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 all-specials) + (setq b (point)) + (while (not (eobp)) + (cond + ((not state) + (setq state 'word) + (if (not (eq (setq cs (mm-charset-after)) 'ascii)) + (setq current cs)) + (setq b (point))) + ((eq state 'blank) + (cond + ((memq (char-after) special-list) + (setq state nil)) + ((memq (char-after) blank-list)) + (t + (setq state 'word) + (unless b + (setq b (point))) + (if (not (eq (setq cs (mm-charset-after)) 'ascii)) + (setq current cs))))) + ((eq state 'word) + (cond + ((memq (char-after) special-list) + (setq state nil) + (push (list b (point) current) words) + (setq current nil)) + ((memq (char-after) blank-list) + (setq state 'blank) + (if (not current) + (setq b nil) + (push (list b (point) current) words) + (setq b (point)) + (setq current nil))) + ((or (eq (setq cs (mm-charset-after)) 'ascii) + (if current + (eq current cs) + (setq current cs)))) + (t + (push (list b (point) current) words) + (setq current cs) + (setq b (point)))))) + (if state + (forward-char) + (skip-chars-forward all-specials))) + (if (eq state 'word) + (push (list b (point) current) words))) + words)) (defun rfc2047-encode-region (b e) "Encode all encodable words in REGION." @@ -169,7 +215,14 @@ Should be called narrowed to the head of the message." (if (equal (nth 2 word) current) (setq beg (nth 0 word)) (when current - (rfc2047-encode beg end current)) + (if (and (eq beg (nth 1 word)) (nth 2 word)) + (progn + ;; There might be a bug in Emacs Mule. + ;; A space must be inserted before encoding. + (goto-char beg) + (insert " ") + (rfc2047-encode (1+ beg) (1+ end) current)) + (rfc2047-encode beg end current))) (setq current (nth 2 word) beg (nth 0 word) end (nth 1 word)))) @@ -202,7 +255,9 @@ Should be called narrowed to the head of the message." (goto-char (min (point-max) (+ 15 (point)))) (unless (eobp) (insert "\n")))) - (mm-encode-coding-region (point-min) (point-max) mime-charset) + (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)) @@ -228,11 +283,12 @@ Should be called narrowed to the head of the message." ((and (not break) (looking-at "=\\?")) (setq break (point))) - ((and (looking-at "\\?=") + ((and break + (looking-at "\\?=") (> (- (point) (save-excursion (beginning-of-line) (point))) 76)) (goto-char break) - (insert "\n ") - (forward-line 1))) + (setq break nil) + (insert "\n "))) (unless (eobp) (forward-char 1)))))) @@ -297,12 +353,14 @@ Should be called narrowed to the head of the message." (match-string 0) (delete-region (match-beginning 0) (match-end 0))))) (when (and (mm-multibyte-p) - mail-parse-charset) + 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 'us-ascii)) + (not (eq mail-parse-charset 'gnus-decoded))) (mm-decode-coding-region b (point-max) mail-parse-charset)))))) (defun rfc2047-decode-string (string) @@ -335,10 +393,17 @@ Return WORD if not." 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) (memq charset mail-parse-ignored-charsets)) + (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)