X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Frfc2047.el;h=fdce08db1d77f19ecd97918b672a67c1577c487a;hb=ebdecdf203f300217a9a7f533dcf43fec5d427b4;hp=7d04a83e4fe3a5db2f5ac055e10bf5aabf90c5c2;hpb=12880262125c73b531b08cd9005fbaf49c2c3395;p=elisp%2Fgnus.git- diff --git a/lisp/rfc2047.el b/lisp/rfc2047.el index 7d04a83..fdce08d 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, 1999, 2000, 2001 Free Software Foundation, Inc. +;; Copyright (C) 1998, 1999, 2000, 2001, 2002 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; MORIOKA Tomohiko @@ -27,7 +27,9 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile + (require 'cl) + (defvar message-posting-charset)) (require 'qp) (require 'mm-util) @@ -65,8 +67,8 @@ The values can be: (iso-8859-4 . Q) (iso-8859-5 . B) (koi8-r . B) - (iso-8859-7 . Q) - (iso-8859-8 . Q) + (iso-8859-7 . B) + (iso-8859-8 . B) (iso-8859-9 . Q) (iso-8859-14 . Q) (iso-8859-15 . Q) @@ -81,7 +83,8 @@ The values can be: (iso-2022-jp-2 . B) (iso-2022-int-1 . B)) "Alist of MIME charsets to RFC2047 encodings. -Valid encodings are nil, `Q' and `B'.") +Valid encodings are nil, `Q' and `B'. These indicate binary (no) encoding, +quoted-printable and base64 respectively.") (defvar rfc2047-encoding-function-alist '((Q . rfc2047-q-encode-region) @@ -116,6 +119,14 @@ Valid encodings are nil, `Q' and `B'.") (point-max)))) (goto-char (point-min))) +(defun rfc2047-field-value () + "Return the value of the field at point." + (save-excursion + (save-restriction + (rfc2047-narrow-to-field) + (re-search-forward ":[ \t\n]*" nil t) + (buffer-substring (point) (point-max))))) + (defun rfc2047-encode-message-header () "Encode the message header according to `rfc2047-header-encoding-alist'. Should be called narrowed to the head of the message." @@ -127,15 +138,26 @@ Should be called narrowed to the head of the message." (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))) + (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. + ;; Is message-posting-charset a coding system? + (mm-encode-coding-region + (point-min) (point-max) + (car message-posting-charset)) + nil) + ;; 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))) ;; We found something that may perhaps be encoded. (setq method nil alist rfc2047-header-encoding-alist) @@ -157,18 +179,29 @@ Should be called narrowed to the head of the message." mail-parse-charset) (mm-encode-coding-region (point-min) (point-max) mail-parse-charset))) + ;; We get this when CC'ing messsages to newsgroups with + ;; 8-bit names. The group name mail copy just get + ;; unconditionally encoded. Previously, it would ask + ;; whether to encode, which was quite confusing for the + ;; user. If the new behaviour is wrong, tell me. I have + ;; left the old code commented out below. + ;; -- Per Abrahamsen Date: 2001-10-07. ((null method) - (and (delq 'ascii - (mm-find-charset-region (point-min) - (point-max))) - (if (or (message-options-get - 'rfc2047-encode-message-header-encode-any) - (message-options-set - 'rfc2047-encode-message-header-encode-any - (y-or-n-p - "Some texts are not encoded. Encode anyway?"))) - (rfc2047-encode-region (point-min) (point-max)) - (error "Cannot send unencoded text.")))) + (when (delq 'ascii + (mm-find-charset-region (point-min) (point-max))) + (rfc2047-encode-region (point-min) (point-max)))) +;;; ((null method) +;;; (and (delq 'ascii +;;; (mm-find-charset-region (point-min) +;;; (point-max))) +;;; (if (or (message-options-get +;;; 'rfc2047-encode-message-header-encode-any) +;;; (message-options-set +;;; 'rfc2047-encode-message-header-encode-any +;;; (y-or-n-p +;;; "Some texts are not encoded. Encode anyway?"))) +;;; (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) @@ -316,6 +349,13 @@ The buffer may be narrowed." (insert "?=") (forward-line 1))))) +(defun rfc2047-fold-field () + "Fold the current line." + (save-excursion + (save-restriction + (rfc2047-narrow-to-field) + (rfc2047-fold-region (point-min) (point-max))))) + (defun rfc2047-fold-region (b e) "Fold long lines in region B to E." (save-restriction @@ -323,21 +363,24 @@ The buffer may be narrowed." (goto-char (point-min)) (let ((break nil) (qword-break nil) + (first t) (bol (save-restriction (widen) (gnus-point-at-bol)))) (while (not (eobp)) - (when (and (or break qword-break) (> (- (point) bol) 76)) + (when (and (or break qword-break) + (> (- (point) bol) 76)) (goto-char (or break qword-break)) (setq break nil qword-break nil) - (if (looking-at " \t") + (if (looking-at "[ \t]") (insert "\n") (insert "\n ")) (setq bol (1- (point))) ;; Don't break before the first non-LWSP characters. (skip-chars-forward " \t") - (unless (eobp) (forward-char 1))) + (unless (eobp) + (forward-char 1))) (cond ((eq (char-after) ?\n) (forward-char 1) @@ -351,7 +394,10 @@ The buffer may be narrowed." (forward-char 1)) ((memq (char-after) '(? ?\t)) (skip-chars-forward " \t") - (setq break (1- (point)))) + (if first + ;; Don't break just after the header name. + (setq first nil) + (setq break (1- (point))))) ((not break) (if (not (looking-at "=\\?[^=]")) (if (eq (char-after) ?=) @@ -361,17 +407,26 @@ The buffer may be narrowed." (skip-chars-forward "^ \t\n\r"))) (t (skip-chars-forward "^ \t\n\r")))) - (when (and (or break qword-break) (> (- (point) bol) 76)) + (when (and (or break qword-break) + (> (- (point) bol) 76)) (goto-char (or break qword-break)) (setq break nil qword-break nil) - (if (looking-at " \t") + (if (looking-at "[ \t]") (insert "\n") (insert "\n ")) (setq bol (1- (point))) ;; Don't break before the first non-LWSP characters. (skip-chars-forward " \t") - (unless (eobp) (forward-char 1)))))) + (unless (eobp) + (forward-char 1)))))) + +(defun rfc2047-unfold-field () + "Fold the current line." + (save-excursion + (save-restriction + (rfc2047-narrow-to-field) + (rfc2047-unfold-region (point-min) (point-max))))) (defun rfc2047-unfold-region (b e) "Unfold lines in region B to E." @@ -381,18 +436,15 @@ The buffer may be narrowed." (let ((bol (save-restriction (widen) (gnus-point-at-bol))) - (eol (gnus-point-at-eol)) - leading) + (eol (gnus-point-at-eol))) (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))))) + (if (and (looking-at "[ \t]") + (< (- (gnus-point-at-eol) bol) 76)) + (delete-region eol (progn + (goto-char eol) + (skip-chars-forward "\r\n") + (point))) (setq bol (gnus-point-at-bol))) (setq eol (gnus-point-at-eol)) (forward-line 1))))) @@ -419,7 +471,7 @@ The buffer may be narrowed." (while alist (when (looking-at (caar alist)) (mm-with-unibyte-current-buffer-mule4 - (quoted-printable-encode-region + (quoted-printable-encode-region (point-min) (point-max) nil (cdar alist))) (subst-char-in-region (point-min) (point-max) ? ?_) (setq alist nil)) @@ -468,8 +520,17 @@ The buffer may be narrowed." (prog1 (match-string 0) (delete-region (match-beginning 0) (match-end 0))))) + ;; Remove newlines between decoded words. Though such things + ;; must not be essentially there. + (save-restriction + (narrow-to-region e (point)) + (goto-char e) + (while (re-search-forward "[\n\r]+" nil t) + (replace-match " ")) + (goto-char (point-max))) (when (and (mm-multibyte-p) mail-parse-charset + (not (eq mail-parse-charset 'us-ascii)) (not (eq mail-parse-charset 'gnus-decoded))) (mm-decode-coding-region b e mail-parse-charset)) (setq b (point))) @@ -477,19 +538,25 @@ The buffer may be narrowed." 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)))))) + (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." (let ((m (mm-multibyte-p))) - (with-temp-buffer - (when m - (mm-enable-multibyte)) - (insert string) - (inline - (rfc2047-decode-region (point-min) (point-max))) - (buffer-string)))) + (if (string-match "=\\?" string) + (with-temp-buffer + (when m + (mm-enable-multibyte)) + (insert string) + (inline + (rfc2047-decode-region (point-min) (point-max))) + (buffer-string)) + (if (and m + mail-parse-charset + (not (eq mail-parse-charset 'us-ascii)) + (not (eq mail-parse-charset 'gnus-decoded))) + (mm-decode-coding-string string mail-parse-charset) + string)))) (defun rfc2047-parse-and-decode (word) "Decode WORD and return it if it is an encoded word.