X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/4c57cca724993ab1334cc5c0b35c22b06daee0c3..a457417ee5ba797ab1c91d35ee957bb7a7f8d4b6:/lisp/gnus/rfc2047.el diff --git a/lisp/gnus/rfc2047.el b/lisp/gnus/rfc2047.el index aa30d9ba78..4f63cae9ee 100644 --- a/lisp/gnus/rfc2047.el +++ b/lisp/gnus/rfc2047.el @@ -1,7 +1,7 @@ ;;; rfc2047.el --- functions for encoding and decoding rfc2047 messages -;; Copyright (C) 1998, 1999, 2000, 2002, 2003, 2004, -;; 2005, 2006 Free Software Foundation, Inc. +;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, +;; 2005, 2006, 2007 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; MORIOKA Tomohiko @@ -9,7 +9,7 @@ ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) +;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, @@ -31,45 +31,16 @@ (eval-when-compile (require 'cl) - (defvar message-posting-charset) - (unless (fboundp 'with-syntax-table) ; not in Emacs 20 - (defmacro with-syntax-table (table &rest body) - "Evaluate BODY with syntax table of current buffer set to TABLE. -The syntax table of the current buffer is saved, BODY is evaluated, and the -saved table is restored, even in case of an abnormal exit. -Value is what BODY returns." - (let ((old-table (make-symbol "table")) - (old-buffer (make-symbol "buffer"))) - `(let ((,old-table (syntax-table)) - (,old-buffer (current-buffer))) - (unwind-protect - (progn - (set-syntax-table ,table) - ,@body) - (save-current-buffer - (set-buffer ,old-buffer) - (set-syntax-table ,old-table)))))))) + (defvar message-posting-charset)) (require 'qp) (require 'mm-util) (require 'ietf-drums) ;; Fixme: Avoid this (used for mail-parse-charset) mm dependence on gnus. (require 'mail-prsvr) -(require 'base64) +(require 'rfc2045) ;; rfc2045-encode-string (autoload 'mm-body-7-or-8 "mm-bodies") -(eval-and-compile - ;; Avoid gnus-util for mm- code. - (defalias 'rfc2047-point-at-bol - (if (fboundp 'point-at-bol) - 'point-at-bol - 'line-beginning-position)) - - (defalias 'rfc2047-point-at-eol - (if (fboundp 'point-at-eol) - 'point-at-eol - 'line-end-position))) - (defvar rfc2047-header-encoding-alist '(("Newsgroups" . nil) ("Followup-To" . nil) @@ -159,7 +130,7 @@ This is either `base64' or `quoted-printable'." (progn (forward-line 1) (if (re-search-forward "^[^ \n\t]" nil t) - (rfc2047-point-at-bol) + (point-at-bol) (point-max)))) (goto-char (point-min))) @@ -171,6 +142,55 @@ This is either `base64' or `quoted-printable'." (re-search-forward ":[ \t\n]*" nil t) (buffer-substring-no-properties (point) (point-max))))) +(defun rfc2047-quote-special-characters-in-quoted-strings (&optional + encodable-regexp) + "Quote special characters with `\\'s in quoted strings. +Quoting will not be done in a quoted string if it contains characters +matching ENCODABLE-REGEXP or it is within parentheses." + (goto-char (point-min)) + (let ((tspecials (concat "[" ietf-drums-tspecials "]")) + (start (point)) + beg end) + (with-syntax-table (standard-syntax-table) + (while (not (eobp)) + (if (ignore-errors + (forward-list 1) + (eq (char-before) ?\))) + (forward-list -1) + (goto-char (point-max))) + (save-restriction + (narrow-to-region start (point)) + (goto-char start) + (while (search-forward "\"" nil t) + (setq beg (match-beginning 0)) + (unless (eq (char-before beg) ?\\) + (goto-char beg) + (setq beg (1+ beg)) + (condition-case nil + (progn + (forward-sexp) + (setq end (1- (point))) + (goto-char beg) + (if (and encodable-regexp + (re-search-forward encodable-regexp end t)) + (goto-char (1+ end)) + (save-restriction + (narrow-to-region beg end) + (while (re-search-forward tspecials nil 'move) + (if (eq (char-before) ?\\) + (if (looking-at tspecials) ;; Already quoted. + (forward-char) + (insert "\\")) + (goto-char (match-beginning 0)) + (insert "\\") + (forward-char)))) + (forward-char))) + (error + (goto-char beg))))) + (goto-char (point-max))) + (forward-list 1) + (setq start (point)))))) + (defvar rfc2047-encoding-type 'address-mime "The type of encoding done by `rfc2047-encode-region'. This should be dynamically bound around calls to @@ -187,8 +207,18 @@ Should be called narrowed to the head of the message." (while (not (eobp)) (save-restriction (rfc2047-narrow-to-field) + (setq method nil + alist rfc2047-header-encoding-alist) + (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)))) (if (not (rfc2047-encodable-p)) - (prog1 + (prog2 + (when (eq method 'address-mime) + (rfc2047-quote-special-characters-in-quoted-strings)) (if (and (eq (mm-body-7-or-8) '8bit) (mm-multibyte-p) (mm-coding-system-p @@ -209,14 +239,6 @@ Should be called narrowed to the head of the message." (point)) (point-max)))) ;; We found something that may perhaps be encoded. - (setq method nil - alist rfc2047-header-encoding-alist) - (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)))) (re-search-forward "^[^:]+: *" nil t) (cond ((eq method 'address-mime) @@ -252,9 +274,10 @@ Should be called narrowed to the head of the message." ;;; (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) - default-enable-multibyte-characters)) + (if (or (and (featurep 'mule) + (if (boundp 'default-enable-multibyte-characters) + default-enable-multibyte-characters)) + (featurep 'file-coding)) (mm-encode-coding-region (point) (point-max) method))) ;; Hm. (t))) @@ -347,6 +370,7 @@ Dynamically bind `rfc2047-encoding-type' to change that." (rfc2047-encode start (point)) (goto-char end)))) ;; `address-mime' case -- take care of quoted words, comments. + (rfc2047-quote-special-characters-in-quoted-strings encodable-regexp) (with-syntax-table rfc2047-syntax-table (goto-char (point-min)) (condition-case err ; in case of unbalanced quotes @@ -617,14 +641,14 @@ Point moves to the end of the region." (goto-char b) (setq b (point-marker) e (set-marker (make-marker) e)) - (rfc2047-fold-region (rfc2047-point-at-bol) b) + (rfc2047-fold-region (point-at-bol) b) (goto-char b) (skip-chars-backward "^ \t\n") (unless (= 0 (skip-chars-backward " \t")) ;; `crest' may contain whitespace and an open parenthesis. (setq crest (buffer-substring-no-properties (point) b))) (setq eword (rfc2047-encode-1 - (- b (rfc2047-point-at-bol)) + (- b (point-at-bol)) (mm-replace-in-string (buffer-substring-no-properties b e) "\n\\([ \t]?\\)" "\\1") @@ -671,7 +695,7 @@ Point moves to the end of the region." (first t) (bol (save-restriction (widen) - (rfc2047-point-at-bol)))) + (point-at-bol)))) (while (not (eobp)) (when (and (or break qword-break) (> (- (point) bol) 76)) @@ -743,18 +767,18 @@ Point moves to the end of the region." (goto-char (point-min)) (let ((bol (save-restriction (widen) - (rfc2047-point-at-bol))) - (eol (rfc2047-point-at-eol))) + (point-at-bol))) + (eol (point-at-eol))) (forward-line 1) (while (not (eobp)) (if (and (looking-at "[ \t]") - (< (- (rfc2047-point-at-eol) bol) 76)) + (< (- (point-at-eol) bol) 76)) (delete-region eol (progn (goto-char eol) (skip-chars-forward "\r\n") (point))) - (setq bol (rfc2047-point-at-bol))) - (setq eol (rfc2047-point-at-eol)) + (setq bol (point-at-bol))) + (setq eol (point-at-eol)) (forward-line 1))))) (defun rfc2047-b-encode-string (string) @@ -793,12 +817,9 @@ 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 (concat "[" ietf-drums-tspecials "]") string) - (format "%s=%S" param string) - (concat param "=" string)))) + (let ((rfc2047-encoding-type 'mime) + (rfc2047-encode-max-chars nil)) + (rfc2045-encode-string param (rfc2047-encode-string value)))) ;;; ;;; Functions for decoding RFC2047 messages @@ -806,7 +827,7 @@ it, put the following line in your ~/.gnus.el file: (eval-and-compile (defconst rfc2047-encoded-word-regexp - "=\\?\\([^][\000-\040()<>@,\;:*\\\"/?.=]+\\)\\(\\*[^?]+\\)?\ + "=\\?\\([^][\000-\040()<>@,\;:*\\\"/?.=]+\\)\\(?:\\*[^?]+\\)?\ \\?\\(B\\|Q\\)\\?\\([!->@-~ ]*\\)\\?=")) (defvar rfc2047-quote-decoded-words-containing-tspecials nil @@ -821,6 +842,29 @@ encoded-word, concatenate them, and decode it by charset. Otherwise, the decoder will fully decode each encoded-word before concatenating them.") +(defun rfc2047-strip-backslashes-in-quoted-strings () + "Strip backslashes in quoted strings. `\\\"' remains." + (goto-char (point-min)) + (let (beg) + (with-syntax-table (standard-syntax-table) + (while (search-forward "\"" nil t) + (unless (eq (char-before) ?\\) + (setq beg (match-end 0)) + (goto-char (match-beginning 0)) + (condition-case nil + (progn + (forward-sexp) + (save-restriction + (narrow-to-region beg (1- (point))) + (goto-char beg) + (while (search-forward "\\" nil 'move) + (unless (memq (char-after) '(?\")) + (delete-backward-char 1)) + (forward-char))) + (forward-char)) + (error + (goto-char beg)))))))) + (defun rfc2047-charset-to-coding-system (charset) "Return coding-system corresponding to MIME CHARSET. If your Emacs implementation can't decode CHARSET, return nil." @@ -898,8 +942,10 @@ ENCODED-WORD)." ;; and worthwhile (is it more correct or not?), e.g. something like ;; `=?iso-8859-1?q?foo?=@'. -(defun rfc2047-decode-region (start end) - "Decode MIME-encoded words in region between START and END." +(defun rfc2047-decode-region (start end &optional address-mime) + "Decode MIME-encoded words in region between START and END. +If ADDRESS-MIME is non-nil, strip backslashes which precede characters +other than `\"' and `\\' in quoted strings." (interactive "r") (let ((case-fold-search t) (eword-regexp (eval-when-compile @@ -910,6 +956,8 @@ ENCODED-WORD)." (save-excursion (save-restriction (narrow-to-region start end) + (when address-mime + (rfc2047-strip-backslashes-in-quoted-strings)) (goto-char (setq b start)) ;; Look for the encoded-words. (while (setq match (re-search-forward eword-regexp nil t)) @@ -918,8 +966,8 @@ ENCODED-WORD)." words nil) (while match (push (list (match-string 2) ;; charset - (char-after (match-beginning 4)) ;; encoding - (match-string 5) ;; encoded-text + (char-after (match-beginning 3)) ;; encoding + (match-string 4) ;; encoded-text (match-string 1)) ;; encoded-word words) ;; Look for the subsequent encoded-words. @@ -995,8 +1043,16 @@ ENCODED-WORD)." (not (eq mail-parse-charset 'gnus-decoded))) (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." +(defun rfc2047-decode-address-region (start end) + "Decode MIME-encoded words in region between START and END. +Backslashes which precede characters other than `\"' and `\\' in quoted +strings are stripped." + (rfc2047-decode-region start end t)) + +(defun rfc2047-decode-string (string &optional address-mime) + "Decode MIME-encoded STRING and return the result. +If ADDRESS-MIME is non-nil, strip backslashes which precede characters +other than `\"' and `\\' in quoted strings." (let ((m (mm-multibyte-p))) (if (string-match "=\\?" string) (with-temp-buffer @@ -1010,8 +1066,16 @@ ENCODED-WORD)." (mm-enable-multibyte)) (insert string) (inline - (rfc2047-decode-region (point-min) (point-max))) + (rfc2047-decode-region (point-min) (point-max) address-mime)) (buffer-string)) + (when address-mime + (setq string + (with-temp-buffer + (when (mm-multibyte-string-p string) + (mm-enable-multibyte)) + (insert string) + (rfc2047-strip-backslashes-in-quoted-strings) + (buffer-string)))) ;; Fixme: As above, `m' here is inappropriate. (if (and m mail-parse-charset @@ -1033,6 +1097,12 @@ ENCODED-WORD)." (mm-decode-coding-string string mail-parse-charset)) (mm-string-as-multibyte string))))) +(defun rfc2047-decode-address-string (string) + "Decode MIME-encoded STRING and return the result. +Backslashes which precede characters other than `\"' and `\\' in quoted +strings are stripped." + (rfc2047-decode-string string t)) + (defun rfc2047-pad-base64 (string) "Pad STRING to quartets." ;; Be more liberal to accept buggy base64 strings. If