[Richard Stallman <rms@gnu.org>] rfc2047.el

[Richard Stallman <rms@gnu.org>] rfc2047.el

[Kai Großjohann]

[-- Attachment #1: Type: text/plain, Size: 148 bytes --]

I think this should be installed in Oort, what do you think?  Then
Richard has his testers.

kai
-- 
~/.signature is: umop ap!sdn    (Frank Nobis)


[-- Attachment #2.1: Type: text/plain, Size: 59 bytes --]

Subject: Topics

Topics:
   [d.love@dl.ac.uk: rfc2047.el]


[-- Attachment #2.2: Type: text/plain, Size: 17957 bytes --]

Date: Sat, 26 Oct 2002 16:14:09 -0400
From: Richard Stallman <rms@gnu.org>
Subject: [d.love@dl.ac.uk: rfc2047.el]
Message-ID: <E185XJx-0002Es-00@fencepost.gnu.org>
MIME-Version: 1.0

I think a larger group of people should see this patch.
Can people please test this?

------- Start of forwarded message -------
Envelope-to: emacs-pretest-bug@gnu.org
Delivery-date: Fri, 25 Oct 2002 13:37:43 -0400
To: emacs-pretest-bug@gnu.org   
Subject: rfc2047.el
From: Dave Love <d.love@dl.ac.uk>
Date: 25 Oct 2002 18:37:03 +0100
X-Spam-Status: No, hits=-1.2 required=5.0
	tests=PATCH_CONTEXT_DIFF,SPAM_PHRASE_00_01,TO_HAS_SPACES,
	      USER_AGENT
	version=2.41
X-Spam-Level: 

- --benelux-Jiang-Zemin-Qaddafi-MD5-subversive

This is the best I can do on minimal changes to rfc2047.el to fix the
problems with it generating invalid encodings for 21.3.  It's not well
tested yet, but survived a few attempts to break it.


- --benelux-Jiang-Zemin-Qaddafi-MD5-subversive
Content-Type: text/x-patch
Content-Disposition: inline

2002-10-25  Dave Love  <fx@gnu.org>

	* rfc2047.el (ietf-drums): Don't require.
	(message-posting-charset): defvar when compiling.
	(rfc2047-header-encoding-alist): Add `address-mime' part.
	(rfc2047-charset-encoding-alist): Use B for iso-8859-7,
	iso-8859-8.  Doc fix.
	(rfc2047-q-encoding-alist): Augment header list.
	(rfc2047-encoding-type, rfc2047-syntax-table): New.
	(rfc2047-encode-message-header): Account for address-mime method.
	(rfc2047-dissect-region): Rewritten for RFC2822 rules.  Now just
	return list of strings.
	(rfc2047-encode-region): Change test for need to encode word.
	Change rfc2047-encode call.
	(rfc2047-encode): Remove CHARSET arg and decide encoding from
	region contents.

Index: rfc2047.el
===================================================================
RCS file: /cvsroot/emacs/emacs/lisp/gnus/rfc2047.el,v
retrieving revision 1.10
diff -u -p -c -r1.10 rfc2047.el
cvs server: conflicting specifications of output style
*** rfc2047.el	15 Jul 2001 17:42:53 -0000	1.10
- --- rfc2047.el	25 Oct 2002 15:01:44 -0000
***************
*** 1,5 ****
  ;;; rfc2047.el --- functions for encoding and decoding rfc2047 messages
! ;; Copyright (C) 1998, 1999, 2000 Free Software Foundation, Inc.
  
  ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
  ;;	MORIOKA Tomohiko <morioka@jaist.ac.jp>
- --- 1,5 ----
  ;;; rfc2047.el --- functions for encoding and decoding rfc2047 messages
! ;; Copyright (C) 1998, 1999, 2000, 2002 Free Software Foundation, Inc.
  
  ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
  ;;	MORIOKA Tomohiko <morioka@jaist.ac.jp>
***************
*** 27,37 ****
  
  ;;; Code:
  
! (eval-when-compile (require 'cl))
  
  (require 'qp)
  (require 'mm-util)
- - (require 'ietf-drums)
  (require 'mail-prsvr)
  (require 'base64)
  ;; Fixme: Avoid this (for gnus-point-at-...) mm dependence on gnus.
- --- 27,38 ----
  
  ;;; Code:
  
! (eval-when-compile
!   (require 'cl)
!   (defvar message-posting-charset))
  
  (require 'qp)
  (require 'mm-util)
  (require 'mail-prsvr)
  (require 'base64)
  ;; Fixme: Avoid this (for gnus-point-at-...) mm dependence on gnus.
***************
*** 41,46 ****
- --- 42,49 ----
  (defvar rfc2047-header-encoding-alist
    '(("Newsgroups" . nil)
      ("Message-ID" . nil)
+     ("\\(Resent-\\)?\\(From\\|Cc\\|To\\|Bcc\\|Reply-To\\|Sender\\)" .
+      address-mime)
      (t . mime))
    "*Header/encoding method alist.
  The list is traversed sequentially.  The keys can either be
*************** The values can be:
*** 50,57 ****
  
  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 charset;
! 4) `default', in which case the field will be encoded as the rest
     of the article.")
  
  (defvar rfc2047-charset-encoding-alist
- --- 53,62 ----
  
  1) nil, in which case no encoding is done;
  2) `mime', in which case the header will be encoded according to RFC2047;
! 3) `address-mime', like `mime', but takes account of the rules for address
!    fields (where quoted strings and comments must be treated separately);
! 4) a charset, in which case it will be encoded as that charset;
! 5) `default', in which case the field will be encoded as the rest
     of the article.")
  
  (defvar rfc2047-charset-encoding-alist
*************** The values can be:
*** 62,69 ****
      (iso-8859-4 . Q)
      (iso-8859-5 . B)
      (koi8-r . B)
!     (iso-8859-7 . Q)
!     (iso-8859-8 . Q)
      (iso-8859-9 . Q)
      (iso-8859-14 . Q)
      (iso-8859-15 . Q)
- --- 67,74 ----
      (iso-8859-4 . Q)
      (iso-8859-5 . B)
      (koi8-r . B)
!     (iso-8859-7 . B)
!     (iso-8859-8 . B)
      (iso-8859-9 . Q)
      (iso-8859-14 . Q)
      (iso-8859-15 . Q)
*************** The values can be:
*** 78,84 ****
      (iso-2022-jp-2 . B)
      (iso-2022-int-1 . B))
    "Alist of MIME charsets to RFC2047 encodings.
! Valid encodings are nil, `Q' and `B'.")
  
  (defvar rfc2047-encoding-function-alist
    '((Q . rfc2047-q-encode-region)
- --- 83,90 ----
      (iso-2022-jp-2 . B)
      (iso-2022-int-1 . B))
    "Alist of MIME charsets to RFC2047 encodings.
! 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)
*************** Valid encodings are nil, `Q' and `B'.")
*** 87,93 ****
    "Alist of RFC2047 encodings to encoding functions.")
  
  (defvar rfc2047-q-encoding-alist
!   '(("\\(From\\|Cc\\|To\\|Bcc\||Reply-To\\):" . "-A-Za-z0-9!*+/")
      ;; = (\075), _ (\137), ? (\077) are used in the encoded word.
      ;; Avoid using 8bit characters.
      ;; Equivalent to "^\000-\007\011\013\015-\037\200-\377=_?"
- --- 93,100 ----
    "Alist of RFC2047 encodings to encoding functions.")
  
  (defvar rfc2047-q-encoding-alist
!   '(("\\(Resent-\\)?\\(From\\|Cc\\|To\\|Bcc\\|Reply-To\\|Sender\\):"
!      . "-A-Za-z0-9!*+/" )
      ;; = (\075), _ (\137), ? (\077) are used in the encoded word.
      ;; Avoid using 8bit characters.
      ;; Equivalent to "^\000-\007\011\013\015-\037\200-\377=_?"
*************** Valid encodings are nil, `Q' and `B'.")
*** 112,117 ****
- --- 119,130 ----
         (point-max))))
    (goto-char (point-min)))
  
+ (defvar rfc2047-encoding-type 'address-mime
+   "The type of encoding done by `rfc2047-encode-region'.
+ This should be dynamically bound around calls to
+ `rfc2047-encode-region' to either `mime' or `address-mime'.  See
+ `rfc2047-header-encoding-alist', for definitions.")
+ 
  (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."
*************** Should be called narrowed to the head of
*** 142,149 ****
  		(setq alist nil
  		      method (cdr elem))))
  	    (cond
! 	     ((eq method 'mime)
! 	      (rfc2047-encode-region (point-min) (point-max)))
  	     ((eq method 'default)
  	      (if (and (featurep 'mule)
  		       (if (boundp 'default-enable-multibyte-characters)
- --- 155,165 ----
  		(setq alist nil
  		      method (cdr elem))))
  	    (cond
! 	     ((or (eq method 'address-mime) (eq method 'mime))
! 	      (goto-char (point-min))
! 	      (re-search-forward "^[^:]+: *" nil t)
! 	      (let ((rfc2047-encoding-type method))
! 		(rfc2047-encode-region (point) (point-max))))
  	     ((eq method 'default)
  	      (if (and (featurep 'mule)
  		       (if (boundp 'default-enable-multibyte-characters)
*************** The buffer may be narrowed."
*** 179,258 ****
  	(setq found t)))
      found))
  
  (defun rfc2047-dissect-region (b e)
!   "Dissect the region between B and E into words."
!   (let ((word-chars "-A-Za-z0-9!*+/")
! 	;; Not using ietf-drums-specials-token makes life simple.
! 	mail-parse-mule-charset
! 	words point current
! 	result word)
!     (save-restriction
!       (narrow-to-region b e)
!       (goto-char (point-min))
!       (skip-chars-forward "\000-\177")
!       (while (not (eobp))
! 	(setq point (point))
! 	(skip-chars-backward word-chars b)
! 	(unless (eq b (point))
! 	  (push (cons (buffer-substring b (point)) nil) words))
! 	(setq b (point))
! 	(goto-char point)
! 	(setq current (mm-charset-after))
! 	(forward-char 1)
! 	(skip-chars-forward word-chars)
! 	(while (and (not (eobp))
! 		    (eq (mm-charset-after) current))
! 	  (forward-char 1)
! 	  (skip-chars-forward word-chars))
! 	(unless (eq b (point))
! 	  (push (cons (buffer-substring b (point)) current) words))
! 	(setq b (point))
! 	(skip-chars-forward "\000-\177"))
!       (unless (eq b (point))
! 	(push (cons (buffer-substring b (point)) nil) words)))
!     ;; merge adjacent words
!     (setq word (pop words))
!     (while word
!       (if (and (cdr word)
! 	       (caar words)
! 	       (not (cdar words))
! 	       (not (string-match "[^ \t]" (caar words))))
! 	  (if (eq (cdr (nth 1 words)) (cdr word))
! 	      (progn
! 		(setq word (cons (concat
! 				  (car (nth 1 words)) (caar words)
! 				  (car word))
! 				 (cdr word)))
! 		(pop words)
! 		(pop words))
! 	    (push (cons (concat (caar words) (car word)) (cdr word))
! 		  result)
! 	    (pop words)
! 	    (setq word (pop words)))
! 	(push word result)
! 	(setq word (pop words))))
!     result))
  
  (defun rfc2047-encode-region (b e)
!   "Encode all encodable words in region B to E."
    (let ((words (rfc2047-dissect-region b e)) word)
      (save-restriction
        (narrow-to-region b e)
        (delete-region (point-min) (point-max))
        (while (setq word (pop words))
! 	(if (not (cdr word))
! 	    (insert (car word))
! 	  (rfc2047-fold-region (gnus-point-at-bol) (point))
  	  (goto-char (point-max))
- - 	  (if (> (- (point) (save-restriction
- - 			      (widen)
- - 			      (gnus-point-at-bol))) 76)
- - 	      (insert "\n "))
  	  ;; Insert blank between encoded words
  	  (if (eq (char-before) ?=) (insert " "))
  	  (rfc2047-encode (point)
! 			  (progn (insert (car word)) (point))
! 			  (cdr word))))
        (rfc2047-fold-region (point-min) (point-max)))))
  
  (defun rfc2047-encode-string (string)
- --- 195,314 ----
  	(setq found t)))
      found))
  
+ ;; Use this syntax table when parsing into regions that may need
+ ;; encoding.  Double quotes are string delimiters, backslash is
+ ;; character quoting, and all other RFC 2822 special characters are
+ ;; treated as punctuation so we can use forward-sexp/forward-word to
+ ;; skip to the end of regions appropriately.  Nb. ietf-drums does
+ ;; things differently.
+ (defconst rfc2047-syntax-table
+   (let ((table (make-char-table 'syntax-table '(2))))
+     (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)
+     (modify-syntax-entry ?\; "." table)
+     (modify-syntax-entry ?, "." table)
+     (modify-syntax-entry ?@ "." table)
+     table))
+ 
  (defun rfc2047-dissect-region (b e)
!   "Dissect the region between B and E into tokens.
! The tokens comprise sequences of atoms, quoted strings, special
! characters and whitespace."
!   (save-restriction
!     (narrow-to-region b e)
!     (if (eq 'mime rfc2047-encoding-type)
! 	;; Simple case -- no need to tokenize.
! 	(list (buffer-substring b e))
!       ;; `address-mime' case -- take care of quoted words, comments.
!       (with-syntax-table rfc2047-syntax-table
! 	(let ((start (point))
! 	      words last-encoded end)
! 	  (goto-char (point-min))
! 	  (condition-case nil	      ; in case of unbalanced specials
! 	      ;; Look for rfc2822-style: sequences of atoms, quoted
! 	      ;; strings, specials, whitespace.  (Specials mustn't be
! 	      ;; encoded.)
! 	      (while (not (eobp))
! 		(setq start (point))
! 		(cond
! 		 ((not (char-after)))	; eob
! 		 ((or (eq ?\  (char-after))
! 		      (eq ?\t (char-after)))
! 		  (skip-chars-forward " \t")
! 		  (push (buffer-substring start (point)) words))
! 		 ;; else token start
! 		 ((eq ?\" (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))
! 		      ;; It doesn't need encoding.
! 		      (progn (push (buffer-substring start end) words)
! 			     (setq last-encoded nil))
! 		    ;; It needs encoding.  Strip the quotes first,
! 		    ;; since encoded words can't occur in quotes.
! 		    (goto-char end)
! 		    (setq end (1- end)
! 			  start (1+ start))
! 		    (if (and last-encoded
! 			     (string-match "^[ \t]+\\'" (car-safe words)))
! 			;; There was a preceding quoted word followed by
! 			;; whitespace.  Include the whitespace in this
! 			;; word to avoid it getting lost.
! 			(push (concat (pop words) (buffer-substring start end))
! 			      words)
! 		      (push (buffer-substring start end) words))
! 		    (setq last-encoded t))) ; record that it was encoded
! 		 ((eq ?. (char-syntax (char-after)))
! 		  ;; Skip other delimiters, but record that they've
! 		  ;; potentially separated quoted words.
! 		  (forward-char)
! 		  (push (string (char-before)) words)
! 		  (setq last-encoded nil))
! 		 (t		    ; normal token/whitespace sequence
! 		  ;; Find the end.
! 		  (forward-word 1)
! 		  (skip-chars-backward " \t")
! 		  (setq end (point))
! 		  ;; Deal with encoding and leading space as for
! 		  ;; quoted words.
! 		  (goto-char start)
! 		  (skip-chars-forward "\000-\177" end)
! 		  (setq last-encoded (/= end (point)))
! 		  (goto-char end)
! 		  (push (buffer-substring start end) words))))
! 	    (error (error "Invalid data for rfc2047 encoding: %s"
! 			  (buffer-substring b e))))
! 	  (nreverse words))))))
  
+ ;; Fixme: why does this cons a list of words and insert them, rather
+ ;; than encoding in place?
  (defun rfc2047-encode-region (b e)
!   "Encode all encodable words in region B to E.
! By default, the region is treated as containing addresses (see
! `rfc2047-special-chars')."
    (let ((words (rfc2047-dissect-region b e)) word)
      (save-restriction
        (narrow-to-region b e)
        (delete-region (point-min) (point-max))
        (while (setq word (pop words))
! 	(if (string-match "\\`[\0-\177]*\\'" word) ; including whitespace
! 	    (insert word)
  	  (goto-char (point-max))
  	  ;; Insert blank between encoded words
  	  (if (eq (char-before) ?=) (insert " "))
  	  (rfc2047-encode (point)
! 			  (progn (insert word) (point)))))
        (rfc2047-fold-region (point-min) (point-max)))))
  
  (defun rfc2047-encode-string (string)
*************** The buffer may be narrowed."
*** 262,301 ****
      (rfc2047-encode-region (point-min) (point-max))
      (buffer-string)))
  
! (defun rfc2047-encode (b e charset)
!   "Encode the word in the region B to E with CHARSET."
!   (let* ((mime-charset (mm-mime-charset charset))
! 	 (cs (mm-charset-to-coding-system mime-charset))
! 	 (encoding (or (cdr (assq mime-charset
  				  rfc2047-charset-encoding-alist))
! 		       'B))
  	 (start (concat
  		 "=?" (downcase (symbol-name mime-charset)) "?"
  		 (downcase (symbol-name encoding)) "?"))
  	 (first t))
!     (save-restriction
!       (narrow-to-region b e)
!       (when (eq encoding 'B)
! 	;; break into lines before encoding
! 	(goto-char (point-min))
! 	(while (not (eobp))
! 	  (goto-char (min (point-max) (+ 15 (point))))
! 	  (unless (eobp)
! 	    (insert "\n"))))
!       (if (and (mm-multibyte-p)
! 	       (mm-coding-system-p cs))
! 	  (mm-encode-coding-region (point-min) (point-max) cs))
!       (funcall (cdr (assq encoding rfc2047-encoding-function-alist))
! 	       (point-min) (point-max))
!       (goto-char (point-min))
!       (while (not (eobp))
! 	(unless first
! 	  (insert " "))
! 	(setq first nil)
! 	(insert start)
! 	(end-of-line)
! 	(insert "?=")
! 	(forward-line 1)))))
  
  (defun rfc2047-fold-region (b e)
    "Fold long lines in region B to E."
- --- 318,366 ----
      (rfc2047-encode-region (point-min) (point-max))
      (buffer-string)))
  
! (defun rfc2047-encode (b e)
!   "Encode the word(s) in the region B to E."
!   (let* ((mime-charset (mm-find-mime-charset-region b e))
! 	 (cs (if (> (length mime-charset) 1)
! 		 ;; Fixme: instead of this, try to break region into
! 		 ;; parts that can be encoded separately.
! 		 (error "Can't rfc2047-encode `%s'"
! 			(buffer-substring b e))
! 	       (setq mime-charset (car mime-charset))
! 	       (mm-charset-to-coding-system mime-charset)))
! 	 (encoding (if (assq mime-charset
! 			     rfc2047-charset-encoding-alist)
! 		       (cdr (assq mime-charset
  				  rfc2047-charset-encoding-alist))
! 		     'B))
  	 (start (concat
  		 "=?" (downcase (symbol-name mime-charset)) "?"
  		 (downcase (symbol-name encoding)) "?"))
  	 (first t))
!     (if mime-charset
! 	(save-restriction
! 	  (narrow-to-region b e)
! 	  (when (eq encoding 'B)
! 	    ;; break into lines before encoding
! 	    (goto-char (point-min))
! 	    (while (not (eobp))
! 	      (goto-char (min (point-max) (+ 15 (point))))
! 	      (unless (eobp)
! 		(insert "\n"))))
! 	  (if (and (mm-multibyte-p)
! 		   (mm-coding-system-p cs))
! 	      (mm-encode-coding-region (point-min) (point-max) cs))
! 	  (funcall (cdr (assq encoding rfc2047-encoding-function-alist))
! 		   (point-min) (point-max))
! 	  (goto-char (point-min))
! 	  (while (not (eobp))
! 	    (unless first
! 	      (insert " "))
! 	    (setq first nil)
! 	    (insert start)
! 	    (end-of-line)
! 	    (insert "?=")
! 	    (forward-line 1))))))
  
  (defun rfc2047-fold-region (b e)
    "Fold long lines in region B to E."

- --benelux-Jiang-Zemin-Qaddafi-MD5-subversive--
------- End of forwarded message -------

Re: [Richard Stallman <rms@gnu.org>] rfc2047.el

[Simon Josefsson]

kai.grossjohann@uni-duisburg.de (Kai Großjohann) writes:

> I think this should be installed in Oort, what do you think?  Then
> Richard has his testers.

Does the patch apply to Oort?  I think the patch was made for Emacs
21.3, and a thread in gnus.gnus-bug said this was already fixed in
Oort but differently, but I may be mistaken.  (None of the solutions
does the right thing; implement a RFC 2822 parser to tokenize and then
QP only the correct tokens....)

Re: [Richard Stallman <rms@gnu.org>] rfc2047.el

[Kai Großjohann]

Simon Josefsson <jas@extundo.com> writes:

> Does the patch apply to Oort?  I think the patch was made for Emacs
> 21.3, and a thread in gnus.gnus-bug said this was already fixed in
> Oort but differently, but I may be mistaken.  (None of the solutions
> does the right thing; implement a RFC 2822 parser to tokenize and then
> QP only the correct tokens....)

Hm.  I don't know all this stuff.  If anyone knows, please holler.

kai
-- 
~/.signature is: umop ap!sdn    (Frank Nobis)

Re: [Richard Stallman <rms@gnu.org>] rfc2047.el

[ShengHuo ZHU]

kai.grossjohann@uni-duisburg.de (Kai Großjohann) writes:

> Simon Josefsson <jas@extundo.com> writes:
>
>> Does the patch apply to Oort?  I think the patch was made for Emacs
>> 21.3, and a thread in gnus.gnus-bug said this was already fixed in
>> Oort but differently, but I may be mistaken.  (None of the solutions
>> does the right thing; implement a RFC 2822 parser to tokenize and then
>> QP only the correct tokens....)
>
> Hm.  I don't know all this stuff.  If anyone knows, please holler.

I checked Dave's previous patch in Sep 13. Because some problems had
been fixed before, I only merged some changes of Dave's previous patch
into Oort Gnus.  The message id of the previous patch is
<rzqn0qxc2yb.fsf@albion.dl.ac.uk> .  I didn't check the new one.

I agree with Simon.  But I don't have much time to fix bugs in the
next three or four months.  Anyone volunteers to fix the bug?  I think
we need a bunch of test cases to make sure that a new fixing doesn't
bring new bugs.

ShengHuo

Re: [Richard Stallman <rms@gnu.org>] rfc2047.el

[Lars Magne Ingebrigtsen]

Simon Josefsson <jas@extundo.com> writes:

> (None of the solutions does the right thing; implement a RFC 2822
> parser to tokenize and then QP only the correct tokens....)

The thing was based on RFC2047 (etc.) and DRUMS.  Has things changed
much between DRUMS and RFC2822?  Any pointers to what needs fixing?

-- 
(domestic pets only, the antidote for overdose, milk.)
   larsi@gnus.org * Lars Magne Ingebrigtsen