diff options
Diffstat (limited to 'lisp/mail')
| -rw-r--r-- | lisp/mail/emacsbug.el | 28 | ||||
| -rw-r--r-- | lisp/mail/flow-fill.el | 240 | ||||
| -rw-r--r-- | lisp/mail/ietf-drums.el | 291 | ||||
| -rw-r--r-- | lisp/mail/mail-extr.el | 39 | ||||
| -rw-r--r-- | lisp/mail/mail-parse.el | 75 | ||||
| -rw-r--r-- | lisp/mail/mail-prsvr.el | 43 | ||||
| -rw-r--r-- | lisp/mail/qp.el | 177 | ||||
| -rw-r--r-- | lisp/mail/rfc2045.el | 41 | ||||
| -rw-r--r-- | lisp/mail/rfc2047.el | 1166 | ||||
| -rw-r--r-- | lisp/mail/rfc2231.el | 308 | ||||
| -rw-r--r-- | lisp/mail/rmail.el | 229 | ||||
| -rw-r--r-- | lisp/mail/rmailedit.el | 2 | ||||
| -rw-r--r-- | lisp/mail/rmailkwd.el | 2 | ||||
| -rw-r--r-- | lisp/mail/rmailmm.el | 2 | ||||
| -rw-r--r-- | lisp/mail/rmailmsc.el | 2 | ||||
| -rw-r--r-- | lisp/mail/rmailsort.el | 2 | ||||
| -rw-r--r-- | lisp/mail/rmailsum.el | 2 | ||||
| -rw-r--r-- | lisp/mail/smtpmail.el | 9 | ||||
| -rw-r--r-- | lisp/mail/undigest.el | 2 | ||||
| -rw-r--r-- | lisp/mail/yenc.el | 139 |
20 files changed, 2531 insertions, 268 deletions
diff --git a/lisp/mail/emacsbug.el b/lisp/mail/emacsbug.el index ce3c50bce2b..18eaa22b34c 100644 --- a/lisp/mail/emacsbug.el +++ b/lisp/mail/emacsbug.el @@ -242,7 +242,7 @@ usually do not have translators for other languages.\n\n"))) (let ((txt (delete-and-extract-region (1+ user-point) (point)))) (insert (propertize "\n" 'display txt))) - (insert "\n\nIn " (emacs-version)) + (insert "\nIn " (emacs-version)) (if emacs-build-system (insert " built on " emacs-build-system)) (insert "\n") @@ -263,6 +263,18 @@ usually do not have translators for other languages.\n\n"))) (buffer-string))))) (if (stringp lsb) (insert "System " lsb "\n"))) + (let ((message-buf (get-buffer "*Messages*"))) + (if message-buf + (let (beg-pos + (end-pos message-end-point)) + (with-current-buffer message-buf + (goto-char end-pos) + (forward-line -10) + (setq beg-pos (point))) + (terpri (current-buffer) t) + (insert "Recent messages:\n") + (insert-buffer-substring message-buf beg-pos end-pos)))) + (insert "\n") (when (and system-configuration-options (not (equal system-configuration-options ""))) (insert "Configured using:\n 'configure " @@ -295,20 +307,6 @@ usually do not have translators for other languages.\n\n"))) (and (boundp mode) (buffer-local-value mode from-buffer) (insert (format " %s: %s\n" mode (buffer-local-value mode from-buffer))))) - (let ((message-buf (get-buffer "*Messages*"))) - (if message-buf - (let (beg-pos - (end-pos message-end-point)) - (with-current-buffer message-buf - (goto-char end-pos) - (forward-line -10) - (setq beg-pos (point))) - (insert "\nRecent messages:\n") - (insert-buffer-substring message-buf beg-pos end-pos)))) - ;; After Recent messages, to avoid the messages produced by - ;; list-load-path-shadows. - (unless (looking-back "\n" (1- (point))) - (insert "\n")) (insert "\n") (insert "Load-path shadows:\n") (let* ((msg "Checking for load-path shadows...") diff --git a/lisp/mail/flow-fill.el b/lisp/mail/flow-fill.el new file mode 100644 index 00000000000..d2881422475 --- /dev/null +++ b/lisp/mail/flow-fill.el @@ -0,0 +1,240 @@ +;;; flow-fill.el --- interpret RFC2646 "flowed" text + +;; Copyright (C) 2000-2016 Free Software Foundation, Inc. + +;; Author: Simon Josefsson <jas@pdc.kth.se> +;; Keywords: mail + +;; This file is part of GNU Emacs. + +;; 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 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This implement decoding of RFC2646 formatted text, including the +;; quoted-depth wins rules. + +;; Theory of operation: search for lines ending with SPC, save quote +;; length of line, remove SPC and concatenate line with the following +;; line if quote length of following line matches current line. + +;; When no further concatenations are possible, we've found a +;; paragraph and we let `fill-region' fill the long line into several +;; lines with the quote prefix as `fill-prefix'. + +;; Todo: implement basic `fill-region' (Emacs and XEmacs +;; implementations differ..) + +;;; History: + +;; 2000-02-17 posted on ding mailing list +;; 2000-02-19 use `point-at-{b,e}ol' in XEmacs +;; 2000-03-11 no compile warnings for point-at-bol stuff +;; 2000-03-26 committed to gnus cvs +;; 2000-10-23 don't flow "-- " lines, make "quote-depth wins" rule +;; work when first line is at level 0. +;; 2002-01-12 probably incomplete encoding support +;; 2003-12-08 started working on test harness. + +;;; Code: + +(eval-when-compile (require 'cl)) + +(defcustom fill-flowed-display-column 'fill-column + "Column beyond which format=flowed lines are wrapped, when displayed. +This can be a Lisp expression or an integer." + :version "22.1" + :group 'mime-display + :type '(choice (const :tag "Standard `fill-column'" fill-column) + (const :tag "Fit Window" (- (window-width) 5)) + (sexp) + (integer))) + +(defcustom fill-flowed-encode-column 66 + "Column beyond which format=flowed lines are wrapped, in outgoing messages. +This can be a Lisp expression or an integer. +RFC 2646 suggests 66 characters for readability." + :version "22.1" + :group 'mime-display + :type '(choice (const :tag "Standard fill-column" fill-column) + (const :tag "RFC 2646 default (66)" 66) + (sexp) + (integer))) + +;;;###autoload +(defun fill-flowed-encode (&optional buffer) + (with-current-buffer (or buffer (current-buffer)) + ;; No point in doing this unless hard newlines is used. + (when use-hard-newlines + (let ((start (point-min)) end) + ;; Go through each paragraph, filling it and adding SPC + ;; as the last character on each line. + (while (setq end (text-property-any start (point-max) 'hard 't)) + (save-restriction + (narrow-to-region start end) + (let ((fill-column (eval fill-flowed-encode-column))) + (fill-flowed-fill-buffer)) + (goto-char (point-min)) + (while (re-search-forward "\n" nil t) + (replace-match " \n" t t)) + (goto-char (setq start (1+ (point-max))))))) + t))) + +(defun fill-flowed-fill-buffer () + (let ((prefix nil) + (prev-prefix nil) + (start (point-min))) + (goto-char (point-min)) + (while (not (eobp)) + (setq prefix (and (looking-at "[> ]+") + (match-string 0))) + (if (equal prefix prev-prefix) + (forward-line 1) + (save-restriction + (narrow-to-region start (point)) + (let ((fill-prefix prev-prefix)) + (fill-region (point-min) (point-max) t 'nosqueeze 'to-eop)) + (goto-char (point-max))) + (setq prev-prefix prefix + start (point)))) + (save-restriction + (narrow-to-region start (point)) + (let ((fill-prefix prev-prefix)) + (fill-region (point-min) (point-max) t 'nosqueeze 'to-eop))))) + +;;;###autoload +(defun fill-flowed (&optional buffer delete-space) + (with-current-buffer (or (current-buffer) buffer) + (goto-char (point-min)) + ;; Remove space stuffing. + (while (re-search-forward "^\\( \\|>+ $\\)" nil t) + (delete-char -1) + (forward-line 1)) + (goto-char (point-min)) + (while (re-search-forward " $" nil t) + (when (save-excursion + (beginning-of-line) + (looking-at "^\\(>*\\)\\( ?\\)")) + (let ((quote (match-string 1)) + sig) + (if (string= quote "") + (setq quote nil)) + (when (and quote (string= (match-string 2) "")) + (save-excursion + ;; insert SP after quote for pleasant reading of quoted lines + (beginning-of-line) + (when (> (skip-chars-forward ">") 0) + (insert " ")))) + ;; XXX slightly buggy handling of "-- " + (while (and (save-excursion + (ignore-errors (backward-char 3)) + (setq sig (looking-at "-- ")) + (looking-at "[^-][^-] ")) + (save-excursion + (unless (eobp) + (forward-char 1) + (looking-at (format "^\\(%s\\)\\([^>\n\r]\\)" + (or quote " ?")))))) + (save-excursion + (replace-match (if (string= (match-string 2) " ") + "" "\\2"))) + (backward-delete-char -1) + (when delete-space + (delete-char -1)) + (end-of-line)) + (unless sig + (condition-case nil + (let ((fill-prefix (when quote (concat quote " "))) + (fill-column (eval fill-flowed-display-column)) + adaptive-fill-mode) + (fill-region (point-at-bol) + (min (1+ (point-at-eol)) + (point-max)) + 'left 'nosqueeze)) + (error + (forward-line 1) + nil)))))))) + +;; Test vectors. + +(defvar show-trailing-whitespace) + +(defvar fill-flowed-encode-tests + `( + ;; The syntax of each list element is: + ;; (INPUT . EXPECTED-OUTPUT) + (,(concat + "> Thou villainous ill-breeding spongy dizzy-eyed \n" + "> reeky elf-skinned pigeon-egg! \n" + ">> Thou artless swag-bellied milk-livered \n" + ">> dismal-dreaming idle-headed scut!\n" + ">>> Thou errant folly-fallen spleeny reeling-ripe \n" + ">>> unmuzzled ratsbane!\n" + ">>>> Henceforth, the coding style is to be strictly \n" + ">>>> enforced, including the use of only upper case.\n" + ">>>>> I've noticed a lack of adherence to the coding \n" + ">>>>> styles, of late.\n" + ">>>>>> Any complaints?") + . + ,(concat + "> Thou villainous ill-breeding spongy dizzy-eyed reeky elf-skinned\n" + "> pigeon-egg! \n" + ">> Thou artless swag-bellied milk-livered dismal-dreaming idle-headed\n" + ">> scut!\n" + ">>> Thou errant folly-fallen spleeny reeling-ripe unmuzzled ratsbane!\n" + ">>>> Henceforth, the coding style is to be strictly enforced,\n" + ">>>> including the use of only upper case.\n" + ">>>>> I've noticed a lack of adherence to the coding styles, of late.\n" + ">>>>>> Any complaints?\n" + )) + ;; (,(concat + ;; "\n" + ;; "> foo\n" + ;; "> \n" + ;; "> \n" + ;; "> bar\n") + ;; . + ;; ,(concat + ;; "\n" + ;; "> foo bar\n")) + )) + +(defun fill-flowed-test () + (interactive "") + (switch-to-buffer (get-buffer-create "*Format=Flowed test output*")) + (erase-buffer) + (setq show-trailing-whitespace t) + (dolist (test fill-flowed-encode-tests) + (let (start output) + (insert "***** BEGIN TEST INPUT *****\n") + (insert (car test)) + (insert "***** END TEST INPUT *****\n\n") + (insert "***** BEGIN TEST OUTPUT *****\n") + (setq start (point)) + (insert (car test)) + (save-restriction + (narrow-to-region start (point)) + (fill-flowed)) + (setq output (buffer-substring start (point-max))) + (insert "***** END TEST OUTPUT *****\n") + (unless (string= output (cdr test)) + (insert "\n***** BEGIN TEST EXPECTED OUTPUT *****\n") + (insert (cdr test)) + (insert "***** END TEST EXPECTED OUTPUT *****\n")) + (insert "\n\n"))) + (goto-char (point-max))) + +(provide 'flow-fill) + +;;; flow-fill.el ends here diff --git a/lisp/mail/ietf-drums.el b/lisp/mail/ietf-drums.el new file mode 100644 index 00000000000..03349d12055 --- /dev/null +++ b/lisp/mail/ietf-drums.el @@ -0,0 +1,291 @@ +;;; ietf-drums.el --- Functions for parsing RFC822bis headers + +;; Copyright (C) 1998-2016 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> +;; This file is part of GNU Emacs. + +;; 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 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; DRUMS is an IETF Working Group that works (or worked) on the +;; successor to RFC822, "Standard For The Format Of Arpa Internet Text +;; Messages". This library is based on +;; draft-ietf-drums-msg-fmt-05.txt, released on 1998-08-05. + +;; Pending a real regression self test suite, Simon Josefsson added +;; various self test expressions snipped from bug reports, and their +;; expected value, below. I you believe it could be useful, please +;; add your own test cases, or write a real self test suite, or just +;; remove this. + +;; <m3oekvfd50.fsf@whitebox.m5r.de> +;; (ietf-drums-parse-address "'foo' <foo@example.com>") +;; => ("foo@example.com" . "'foo'") + +;;; Code: + +(eval-when-compile (require 'cl)) + +(defvar ietf-drums-no-ws-ctl-token "\001-\010\013\014\016-\037\177" + "US-ASCII control characters excluding CR, LF and white space.") +(defvar ietf-drums-text-token "\001-\011\013\014\016-\177" + "US-ASCII characters excluding CR and LF.") +(defvar ietf-drums-specials-token "()<>[]:;@\\,.\"" + "Special characters.") +(defvar ietf-drums-quote-token "\\" + "Quote character.") +(defvar ietf-drums-wsp-token " \t" + "White space.") +(defvar ietf-drums-fws-regexp + (concat "[" ietf-drums-wsp-token "]*\n[" ietf-drums-wsp-token "]+") + "Folding white space.") +(defvar ietf-drums-atext-token "-^a-zA-Z0-9!#$%&'*+/=?_`{|}~" + "Textual token.") +(defvar ietf-drums-dot-atext-token "-^a-zA-Z0-9!#$%&'*+/=?_`{|}~." + "Textual token including full stop.") +(defvar ietf-drums-qtext-token + (concat ietf-drums-no-ws-ctl-token "\041\043-\133\135-\177") + "Non-white-space control characters, plus the rest of ASCII excluding +backslash and doublequote.") +(defvar ietf-drums-tspecials "][()<>@,;:\\\"/?=" + "Tspecials.") + +(defvar ietf-drums-syntax-table + (let ((table (copy-syntax-table emacs-lisp-mode-syntax-table))) + (modify-syntax-entry ?\\ "/" table) + (modify-syntax-entry ?< "(" table) + (modify-syntax-entry ?> ")" table) + (modify-syntax-entry ?@ "w" table) + (modify-syntax-entry ?/ "w" table) + (modify-syntax-entry ?* "_" table) + (modify-syntax-entry ?\; "_" table) + (modify-syntax-entry ?\' "_" table) + table)) + +(defun ietf-drums-token-to-list (token) + "Translate TOKEN into a list of characters." + (let ((i 0) + b e c out range) + (while (< i (length token)) + (setq c (aref token i)) + (incf i) + (cond + ((eq c ?-) + (if b + (setq range t) + (push c out))) + (range + (while (<= b c) + (push (make-char 'ascii b) out) + (incf b)) + (setq range nil)) + ((= i (length token)) + (push (make-char 'ascii c) out)) + (t + (when b + (push (make-char 'ascii b) out)) + (setq b c)))) + (nreverse out))) + +(defsubst ietf-drums-init (string) + (set-syntax-table ietf-drums-syntax-table) + (insert string) + (ietf-drums-unfold-fws) + (goto-char (point-min))) + +(defun ietf-drums-remove-comments (string) + "Remove comments from STRING." + (with-temp-buffer + (let (c) + (ietf-drums-init string) + (while (not (eobp)) + (setq c (char-after)) + (cond + ((eq c ?\") + (condition-case err + (forward-sexp 1) + (error (goto-char (point-max))))) + ((eq c ?\() + (delete-region + (point) + (condition-case nil + (with-syntax-table (copy-syntax-table ietf-drums-syntax-table) + (modify-syntax-entry ?\" "w") + (forward-sexp 1) + (point)) + (error (point-max))))) + (t + (forward-char 1)))) + (buffer-string)))) + +(defun ietf-drums-remove-whitespace (string) + "Remove whitespace from STRING." + (with-temp-buffer + (ietf-drums-init string) + (let (c) + (while (not (eobp)) + (setq c (char-after)) + (cond + ((eq c ?\") + (forward-sexp 1)) + ((eq c ?\() + (forward-sexp 1)) + ((memq c '(?\ ?\t ?\n)) + (delete-char 1)) + (t + (forward-char 1)))) + (buffer-string)))) + +(defun ietf-drums-get-comment (string) + "Return the first comment in STRING." + (with-temp-buffer + (ietf-drums-init string) + (let (result c) + (while (not (eobp)) + (setq c (char-after)) + (cond + ((eq c ?\") + (forward-sexp 1)) + ((eq c ?\() + (setq result + (buffer-substring + (1+ (point)) + (progn (forward-sexp 1) (1- (point)))))) + (t + (forward-char 1)))) + result))) + +(defun ietf-drums-strip (string) + "Remove comments and whitespace from STRING." + (ietf-drums-remove-whitespace (ietf-drums-remove-comments string))) + +(defun ietf-drums-parse-address (string) + "Parse STRING and return a MAILBOX / DISPLAY-NAME pair." + (with-temp-buffer + (let (display-name mailbox c display-string) + (ietf-drums-init string) + (while (not (eobp)) + (setq c (char-after)) + (cond + ((or (eq c ? ) + (eq c ?\t)) + (forward-char 1)) + ((eq c ?\() + (forward-sexp 1)) + ((eq c ?\") + (push (buffer-substring + (1+ (point)) (progn (forward-sexp 1) (1- (point)))) + display-name)) + ((looking-at (concat "[" ietf-drums-atext-token "@" "]")) + (push (buffer-substring (point) (progn (forward-sexp 1) (point))) + display-name)) + ((eq c ?<) + (setq mailbox + (ietf-drums-remove-whitespace + (ietf-drums-remove-comments + (buffer-substring + (1+ (point)) + (progn (forward-sexp 1) (1- (point)))))))) + (t + (forward-char 1)))) + ;; If we found no display-name, then we look for comments. + (if display-name + (setq display-string + (mapconcat 'identity (reverse display-name) " ")) + (setq display-string (ietf-drums-get-comment string))) + (if (not mailbox) + (when (and display-string + (string-match "@" display-string)) + (cons + (mapconcat 'identity (nreverse display-name) "") + (ietf-drums-get-comment string))) + (cons mailbox display-string))))) + +(defun ietf-drums-parse-addresses (string &optional rawp) + "Parse STRING and return a list of MAILBOX / DISPLAY-NAME pairs. +If RAWP, don't actually parse the addresses, but instead return +a list of address strings." + (if (null string) + nil + (with-temp-buffer + (ietf-drums-init string) + (let ((beg (point)) + pairs c address) + (while (not (eobp)) + (setq c (char-after)) + (cond + ((memq c '(?\" ?< ?\()) + (condition-case nil + (forward-sexp 1) + (error + (skip-chars-forward "^,")))) + ((eq c ?,) + (setq address + (if rawp + (buffer-substring beg (point)) + (condition-case nil + (ietf-drums-parse-address + (buffer-substring beg (point))) + (error nil)))) + (if address (push address pairs)) + (forward-char 1) + (setq beg (point))) + (t + (forward-char 1)))) + (setq address + (if rawp + (buffer-substring beg (point)) + (condition-case nil + (ietf-drums-parse-address + (buffer-substring beg (point))) + (error nil)))) + (if address (push address pairs)) + (nreverse pairs))))) + +(defun ietf-drums-unfold-fws () + "Unfold folding white space in the current buffer." + (goto-char (point-min)) + (while (re-search-forward ietf-drums-fws-regexp nil t) + (replace-match " " t t)) + (goto-char (point-min))) + +(defun ietf-drums-parse-date (string) + "Return an Emacs time spec from STRING." + (apply 'encode-time (parse-time-string string))) + +(defun ietf-drums-narrow-to-header () + "Narrow to the header section in the current buffer." + (narrow-to-region + (goto-char (point-min)) + (if (re-search-forward "^\r?$" nil 1) + (match-beginning 0) + (point-max))) + (goto-char (point-min))) + +(defun ietf-drums-quote-string (string) + "Quote string if it needs quoting to be displayed in a header." + (if (string-match (concat "[^" ietf-drums-atext-token "]") string) + (concat "\"" string "\"") + string)) + +(defun ietf-drums-make-address (name address) + (if name + (concat (ietf-drums-quote-string name) " <" address ">") + address)) + +(provide 'ietf-drums) + +;;; ietf-drums.el ends here diff --git a/lisp/mail/mail-extr.el b/lisp/mail/mail-extr.el index 44a082c330d..4f3e71d34b8 100644 --- a/lisp/mail/mail-extr.el +++ b/lisp/mail/mail-extr.el @@ -1406,25 +1406,26 @@ consing a string.)" (insert (upcase mi) ". "))) ;; Nuke name if it is the same as mailbox name. - (let ((buffer-length (- (point-max) (point-min))) - (i 0) - (names-match-flag t)) - (when (and (> buffer-length 0) - (eq buffer-length (- mbox-end mbox-beg))) - (goto-char (point-max)) - (insert-buffer-substring canonicalization-buffer - mbox-beg mbox-end) - (while (and names-match-flag - (< i buffer-length)) - (or (eq (downcase (char-after (+ i (point-min)))) - (downcase - (char-after (+ i buffer-length (point-min))))) - (setq names-match-flag nil)) - (setq i (1+ i))) - (delete-region (+ (point-min) buffer-length) (point-max)) - (and names-match-flag - mail-extr-ignore-realname-equals-mailbox-name - (narrow-to-region (point) (point))))) + (when mail-extr-ignore-single-names + (let ((buffer-length (- (point-max) (point-min))) + (i 0) + (names-match-flag t)) + (when (and (> buffer-length 0) + (eq buffer-length (- mbox-end mbox-beg))) + (goto-char (point-max)) + (insert-buffer-substring canonicalization-buffer + mbox-beg mbox-end) + (while (and names-match-flag + (< i buffer-length)) + (or (eq (downcase (char-after (+ i (point-min)))) + (downcase + (char-after (+ i buffer-length (point-min))))) + (setq names-match-flag nil)) + (setq i (1+ i))) + (delete-region (+ (point-min) buffer-length) (point-max)) + (and names-match-flag + mail-extr-ignore-realname-equals-mailbox-name + (narrow-to-region (point) (point)))))) ;; Nuke name if it's just one word. (goto-char (point-min)) diff --git a/lisp/mail/mail-parse.el b/lisp/mail/mail-parse.el new file mode 100644 index 00000000000..4fc7e463595 --- /dev/null +++ b/lisp/mail/mail-parse.el @@ -0,0 +1,75 @@ +;;; mail-parse.el --- Interface functions for parsing mail + +;; Copyright (C) 1998-2016 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> +;; This file is part of GNU Emacs. + +;; 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 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This file contains wrapper functions for a wide range of mail +;; parsing functions. The idea is that there are low-level libraries +;; that implement according to various specs (RFC2231, DRUMS, USEFOR), +;; but that programmers that want to parse some header (say, +;; Content-Type) will want to use the latest spec. +;; +;; So while each low-level library (rfc2231.el, for instance) decodes +;; faithfully according to that (proposed) standard, this library is +;; the interface library. If some later RFC supersedes RFC2231, one +;; would just have to write a new low-level library, adjust the +;; aliases in this library, and the users and programmers won't notice +;; any changes. + +;;; Code: + +(require 'mail-prsvr) +(require 'ietf-drums) +(require 'rfc2231) +(require 'rfc2047) +(require 'rfc2045) + +(defalias 'mail-header-parse-content-type 'rfc2231-parse-qp-string) +(defalias 'mail-header-parse-content-disposition 'rfc2231-parse-qp-string) +(defalias 'mail-content-type-get 'rfc2231-get-value) +(defalias 'mail-header-encode-parameter 'rfc2047-encode-parameter) + +(defalias 'mail-header-remove-comments 'ietf-drums-remove-comments) +(defalias 'mail-header-remove-whitespace 'ietf-drums-remove-whitespace) +(defalias 'mail-header-strip 'ietf-drums-strip) +(defalias 'mail-header-get-comment 'ietf-drums-get-comment) +(defalias 'mail-header-parse-address 'ietf-drums-parse-address) +(defalias 'mail-header-parse-addresses 'ietf-drums-parse-addresses) +(defalias 'mail-header-parse-date 'ietf-drums-parse-date) +(defalias 'mail-narrow-to-head 'ietf-drums-narrow-to-header) +(defalias 'mail-quote-string 'ietf-drums-quote-string) +(defalias 'mail-header-make-address 'ietf-drums-make-address) + +(defalias 'mail-header-fold-field 'rfc2047-fold-field) +(defalias 'mail-header-unfold-field 'rfc2047-unfold-field) +(defalias 'mail-header-narrow-to-field 'rfc2047-narrow-to-field) +(defalias 'mail-header-field-value 'rfc2047-field-value) + +(defalias 'mail-encode-encoded-word-region 'rfc2047-encode-region) +(defalias 'mail-encode-encoded-word-buffer 'rfc2047-encode-message-header) +(defalias 'mail-encode-encoded-word-string 'rfc2047-encode-string) +(defalias 'mail-decode-encoded-word-region 'rfc2047-decode-region) +(defalias 'mail-decode-encoded-word-string 'rfc2047-decode-string) +(defalias 'mail-decode-encoded-address-region 'rfc2047-decode-address-region) +(defalias 'mail-decode-encoded-address-string 'rfc2047-decode-address-string) + +(provide 'mail-parse) + +;;; mail-parse.el ends here diff --git a/lisp/mail/mail-prsvr.el b/lisp/mail/mail-prsvr.el new file mode 100644 index 00000000000..789c0028f64 --- /dev/null +++ b/lisp/mail/mail-prsvr.el @@ -0,0 +1,43 @@ +;;; mail-prsvr.el --- Interface variables for parsing mail + +;; Copyright (C) 1999-2016 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> +;; This file is part of GNU Emacs. + +;; 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 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;;; Code: + +(defvar mail-parse-charset nil + "Default charset used by low-level libraries. +This variable should never be set. Instead, it should be bound by +functions that wish to call mail-parse functions and let them know +what the desired charset is to be.") + +(defvar mail-parse-mule-charset nil + "Default MULE charset used by low-level libraries. +This variable should never be set.") + +(defvar mail-parse-ignored-charsets nil + "Ignored charsets used by low-level libraries. +This variable should never be set. Instead, it should be bound by +functions that wish to call mail-parse functions and let them know +what the desired charsets is to be ignored.") + +(provide 'mail-prsvr) + +;;; mail-prsvr.el ends here diff --git a/lisp/mail/qp.el b/lisp/mail/qp.el new file mode 100644 index 00000000000..a295e0c2d8e --- /dev/null +++ b/lisp/mail/qp.el @@ -0,0 +1,177 @@ +;;; qp.el --- Quoted-Printable functions + +;; Copyright (C) 1998-2016 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> +;; Keywords: mail, extensions + +;; This file is part of GNU Emacs. + +;; 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 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Functions for encoding and decoding quoted-printable text as +;; defined in RFC 2045. + +;;; Code: + +;;;###autoload +(defun quoted-printable-decode-region (from to &optional coding-system) + "Decode quoted-printable in the region between FROM and TO, per RFC 2045. +If CODING-SYSTEM is non-nil, decode bytes into characters with that +coding-system. + +Interactively, you can supply the CODING-SYSTEM argument +with \\[universal-coding-system-argument]. + +The CODING-SYSTEM argument is a historical hangover and is deprecated. +QP encodes raw bytes and should be decoded into raw bytes. Decoding +them into characters should be done separately." + (interactive + ;; Let the user determine the coding system with "C-x RET c". + (list (region-beginning) (region-end) coding-system-for-read)) + (when (and coding-system + (not (coding-system-p coding-system))) ; e.g. `ascii' from Gnus + (setq coding-system nil)) + (save-excursion + (save-restriction + ;; RFC 2045: ``An "=" followed by two hexadecimal digits, one + ;; or both of which are lowercase letters in "abcdef", is + ;; formally illegal. A robust implementation might choose to + ;; recognize them as the corresponding uppercase letters.'' + (let ((case-fold-search t)) + (narrow-to-region from to) + ;; Do this in case we're called from Gnus, say, in a buffer + ;; which already contains non-ASCII characters which would + ;; then get doubly-decoded below. + (if coding-system + (encode-coding-region (point-min) (point-max) coding-system)) + (goto-char (point-min)) + (while (and (skip-chars-forward "^=") + (not (eobp))) + (cond ((eq (char-after (1+ (point))) ?\n) + (delete-char 2)) + ((looking-at "\\(=[0-9A-F][0-9A-F]\\)+") + ;; Decode this sequence at once; i.e. by a single + ;; deletion and insertion. + (let* ((n (/ (- (match-end 0) (point)) 3)) + (str (make-string n 0))) + (dotimes (i n) + (let ((n1 (char-after (1+ (point)))) + (n2 (char-after (+ 2 (point))))) + (aset str i + (+ (* 16 (- n1 (if (<= n1 ?9) ?0 + (if (<= n1 ?F) (- ?A 10) + (- ?a 10))))) + (- n2 (if (<= n2 ?9) ?0 + (if (<= n2 ?F) (- ?A 10) + (- ?a 10))))))) + (forward-char 3)) + (delete-region (match-beginning 0) (match-end 0)) + (insert str))) + (t + (message "Malformed quoted-printable text") + (forward-char))))) + (if coding-system + (decode-coding-region (point-min) (point-max) coding-system))))) + +(defun quoted-printable-decode-string (string &optional coding-system) + "Decode the quoted-printable encoded STRING and return the result. +If CODING-SYSTEM is non-nil, decode the string with coding-system. +Use of CODING-SYSTEM is deprecated; this function should deal with +raw bytes, and coding conversion should be done separately." + (with-temp-buffer + (set-buffer-multibyte nil) + (insert string) + (quoted-printable-decode-region (point-min) (point-max) coding-system) + (buffer-string))) + +(defun quoted-printable-encode-region (from to &optional fold class) + "Quoted-printable encode the region between FROM and TO per RFC 2045. + +If FOLD, fold long lines at 76 characters (as required by the RFC). +If CLASS is non-nil, translate the characters not matched by that +regexp class, which is in the form expected by `skip-chars-forward'. +You should probably avoid non-ASCII characters in this arg. + +If `mm-use-ultra-safe-encoding' is set, fold lines unconditionally and +encode lines starting with \"From\"." + (interactive "r") + (unless class + ;; Avoid using 8bit characters. = is \075. + ;; Equivalent to "^\000-\007\013\015-\037\200-\377=" + (setq class "\010-\012\014\040-\074\076-\177")) + (save-excursion + (goto-char from) + (if (re-search-forward (string-to-multibyte "[^\x0-\x7f\x80-\xff]") + to t) + (error "Multibyte character in QP encoding region")) + (save-restriction + (narrow-to-region from to) + ;; Encode all the non-ascii and control characters. + (goto-char (point-min)) + (while (and (skip-chars-forward class) + (not (eobp))) + (insert + (prog1 + (format "=%02X" (char-after)) + (delete-char 1)))) + ;; Encode white space at the end of lines. + (goto-char (point-min)) + (while (re-search-forward "[ \t]+$" nil t) + (goto-char (match-beginning 0)) + (while (not (eolp)) + (insert + (prog1 + (format "=%02X" (char-after)) + (delete-char 1))))) + (let ((ultra + (and (boundp 'mm-use-ultra-safe-encoding) + mm-use-ultra-safe-encoding))) + (when (or fold ultra) + (let ((tab-width 1) ; HTAB is one character. + (case-fold-search nil)) + (goto-char (point-min)) + (while (not (eobp)) + ;; In ultra-safe mode, encode "From " at the beginning + ;; of a line. + (when ultra + (if (looking-at "From ") + (replace-match "From=20" nil t) + (if (looking-at "-") + (replace-match "=2D" nil t)))) + (end-of-line) + ;; Fold long lines. + (while (> (current-column) 76) ; tab-width must be 1. + (beginning-of-line) + (forward-char 75) ; 75 chars plus an "=" + (search-backward "=" (- (point) 2) t) + (insert "=\n") + (end-of-line)) + (forward-line)))))))) + +(defun quoted-printable-encode-string (string) + "Encode the STRING as quoted-printable and return the result." + (with-temp-buffer + (if (multibyte-string-p string) + (set-buffer-multibyte 'to) + (set-buffer-multibyte nil)) + (insert string) + (quoted-printable-encode-region (point-min) (point-max)) + (buffer-string))) + +(provide 'qp) + +;;; qp.el ends here diff --git a/lisp/mail/rfc2045.el b/lisp/mail/rfc2045.el new file mode 100644 index 00000000000..c2ddf906d06 --- /dev/null +++ b/lisp/mail/rfc2045.el @@ -0,0 +1,41 @@ +;;; rfc2045.el --- Functions for decoding rfc2045 headers + +;; Copyright (C) 1998-2016 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> +;; This file is part of GNU Emacs. + +;; 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 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;; RFC 2045 is: "Multipurpose Internet Mail Extensions (MIME) Part +;; One: Format of Internet Message Bodies". + +;;; Commentary: + +;;; Code: + +(require 'ietf-drums) + +(defun rfc2045-encode-string (param value) + "Return and PARAM=VALUE string encoded according to RFC2045." + (if (or (string-match (concat "[" ietf-drums-no-ws-ctl-token "]") value) + (string-match (concat "[" ietf-drums-tspecials "]") value) + (string-match "[ \n\t]" value) + (not (string-match (concat "[" ietf-drums-text-token "]") value))) + (concat param "=" (format "%S" value)) + (concat param "=" value))) + +(provide 'rfc2045) + +;;; rfc2045.el ends here diff --git a/lisp/mail/rfc2047.el b/lisp/mail/rfc2047.el new file mode 100644 index 00000000000..4cb10e54393 --- /dev/null +++ b/lisp/mail/rfc2047.el @@ -0,0 +1,1166 @@ +;;; rfc2047.el --- functions for encoding and decoding rfc2047 messages + +;; Copyright (C) 1998-2016 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> +;; MORIOKA Tomohiko <morioka@jaist.ac.jp> +;; This file is part of GNU Emacs. + +;; 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 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; RFC 2047 is "MIME (Multipurpose Internet Mail Extensions) Part +;; Three: Message Header Extensions for Non-ASCII Text". + +;;; Code: + +(eval-when-compile + (require 'cl)) +(defvar message-posting-charset) + +(require 'mm-util) +(require 'ietf-drums) +;; Fixme: Avoid this (used for mail-parse-charset) mm dependence on gnus. +(require 'mail-prsvr) +(require 'rfc2045) ;; rfc2045-encode-string +(autoload 'mm-body-7-or-8 "mm-bodies") + +(defvar rfc2047-header-encoding-alist + '(("Newsgroups" . nil) + ("Followup-To" . nil) + ("Message-ID" . nil) + ("\\(Resent-\\)?\\(From\\|Cc\\|To\\|Bcc\\|\\(In-\\)?Reply-To\\|Sender\ +\\|Mail-Followup-To\\|Mail-Copies-To\\|Approved\\)" . address-mime) + (t . mime)) + "*Header/encoding method alist. +The list is traversed sequentially. The keys can either be +header regexps or t. + +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) `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 + '((us-ascii . nil) + (iso-8859-1 . Q) + (iso-8859-2 . Q) + (iso-8859-3 . Q) + (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) + (iso-2022-jp . B) + (iso-2022-kr . B) + (gb2312 . B) + (gbk . B) + (gb18030 . B) + (big5 . B) + (cn-big5 . B) + (cn-gb . B) + (cn-gb-2312 . B) + (euc-kr . B) + (iso-2022-jp-2 . B) + (iso-2022-int-1 . B) + (viscii . Q)) + "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-encode-function-alist + '((Q . rfc2047-q-encode-string) + (B . rfc2047-b-encode-string) + (nil . identity)) + "Alist of RFC2047 encodings to encoding functions.") + +(defvar rfc2047-encode-encoded-words t + "Whether encoded words should be encoded again.") + +(defvar rfc2047-allow-irregular-q-encoded-words t + "*Whether to decode irregular Q-encoded words.") + +(eval-and-compile ;; Necessary to hard code them in `rfc2047-decode-region'. + (defconst rfc2047-encoded-word-regexp + "=\\?\\([^][\000-\040()<>@,;:*\\\"/?.=]+\\)\\(?:\\*[^?]+\\)?\\?\ +\\(B\\?[+/0-9A-Za-z]*=*\ +\\|Q\\?[ ->@-~]*\ +\\)\\?=" + "Regexp that matches encoded word." + ;; The patterns for the B encoding and the Q encoding, i.e. the ones + ;; beginning with "B" and "Q" respectively, are restricted into only + ;; the characters that those encodings may generally use. + ) + (defconst rfc2047-encoded-word-regexp-loose + "=\\?\\([^][\000-\040()<>@,;:*\\\"/?.=]+\\)\\(?:\\*[^?]+\\)?\\?\ +\\(B\\?[+/0-9A-Za-z]*=*\ +\\|Q\\?\\(?:\\?+[ -<>@-~]\\)?\\(?:[ ->@-~]+\\?+[ -<>@-~]\\)*[ ->@-~]*\\?*\ +\\)\\?=" + "Regexp that matches encoded word allowing loose Q encoding." + ;; The pattern for the Q encoding, i.e. the one beginning with "Q", + ;; is similar to: + ;; "Q\\?\\(\\?+[^\n=?]\\)?\\([^\n?]+\\?+[^\n=?]\\)*[^\n?]*\\?*" + ;; <--------1-------><----------2,3----------><--4--><-5-> + ;; They mean: + ;; 1. After "Q?", allow "?"s that follow a character other than "=". + ;; 2. Allow "=" after "Q?"; it isn't regarded as the terminator. + ;; 3. In the middle of an encoded word, allow "?"s that follow a + ;; character other than "=". + ;; 4. Allow any characters other than "?" in the middle of an + ;; encoded word. + ;; 5. At the end, allow "?"s. + )) + +;;; +;;; Functions for encoding RFC2047 messages +;;; + +(defun rfc2047-qp-or-base64 () + "Return the type with which to encode the buffer. +This is either `base64' or `quoted-printable'." + (save-excursion + (let ((limit (min (point-max) (+ 2000 (point-min)))) + (n8bit 0)) + (goto-char (point-min)) + (skip-chars-forward "\x20-\x7f\r\n\t" limit) + (while (< (point) limit) + (incf n8bit) + (forward-char 1) + (skip-chars-forward "\x20-\x7f\r\n\t" limit)) + (if (or (< (* 6 n8bit) (- limit (point-min))) + ;; Don't base64, say, a short line with a single + ;; non-ASCII char when splitting parts by charset. + (= n8bit 1)) + 'quoted-printable + 'base64)))) + +(defun rfc2047-narrow-to-field () + "Narrow the buffer to the header on the current line." + (beginning-of-line) + (narrow-to-region + (point) + (progn + (forward-line 1) + (if (re-search-forward "^[^ \n\t]" nil t) + (point-at-bol) + (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-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 +`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." + (interactive "*") + (save-excursion + (goto-char (point-min)) + (let (alist elem method charsets) + (while (not (eobp)) + (save-restriction + (rfc2047-narrow-to-field) + (setq method nil + alist rfc2047-header-encoding-alist + charsets (mm-find-mime-charset-region (point-min) (point-max))) + ;; M$ Outlook boycotts decoding of a header if it consists + ;; of two or more encoded words and those charsets differ; + ;; it seems to decode all words in a header from a charset + ;; found first in the header. So, we unify the charsets into + ;; a single one used for encoding the whole text in a header. + (let ((mm-coding-system-priorities + (if (= (length charsets) 1) + (cons (mm-charset-to-coding-system (car charsets)) + mm-coding-system-priorities) + mm-coding-system-priorities))) + (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)) + (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 + (car message-posting-charset))) + ;; 8 bit must be decoded. + (encode-coding-region + (point-min) (point-max) + (mm-charset-to-coding-system + (car message-posting-charset)))) + ;; No encoding necessary, but folding is nice + (when nil + (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. + (re-search-forward "^[^:]+: *" nil t) + (cond + ((eq method 'address-mime) + (rfc2047-encode-region (point) (point-max))) + ((eq method 'mime) + (let ((rfc2047-encoding-type 'mime)) + (rfc2047-encode-region (point) (point-max)))) + ((eq method 'default) + (if (and (default-value 'enable-multibyte-characters) + mail-parse-charset) + (encode-coding-region (point) (point-max) + mail-parse-charset))) + ;; We get this when CC'ing messages to newsgroups with + ;; 8-bit names. The group name mail copy just got + ;; unconditionally encoded. Previously, it would ask + ;; whether to encode, which was quite confusing for the + ;; user. If the new behavior is wrong, tell me. I have + ;; left the old code commented out below. + ;; -- Per Abrahamsen <abraham@dina.kvl.dk> Date: 2001-10-07. + ;; Modified by Dave Love, with the commented-out code changed + ;; in accordance with changes elsewhere. + ((null method) + (rfc2047-encode-region (point) (point-max))) +;;; ((null method) +;;; (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) + (when (default-value 'enable-multibyte-characters) + (encode-coding-region (point) (point-max) method))) + ;; Hm. + (t))) + (goto-char (point-max)))))))) + +;; Fixme: This, and the require below may not be the Right Thing, but +;; should be safe just before release. -- fx 2001-02-08 + +(defun rfc2047-encodable-p () + "Return non-nil if any characters in current buffer need encoding in headers. +The buffer may be narrowed." + (require 'message) ; for message-posting-charset + (let ((charsets + (mm-find-mime-charset-region (point-min) (point-max)))) + (goto-char (point-min)) + (or (and rfc2047-encode-encoded-words + (prog1 + (re-search-forward rfc2047-encoded-word-regexp nil t) + (goto-char (point-min)))) + (and charsets + (not (equal charsets (list (car message-posting-charset)))))))) + +;; 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 + ;; (make-char-table 'syntax-table '(2)) only works in Emacs. + (let ((table (make-syntax-table))) + ;; The following is done to work for setting all elements of the table; + ;; it appears to be the cleanest way. + ;; Play safe and don't assume the form of the word syntax entry -- + ;; copy it from ?a. + (set-char-table-range table t (aref (standard-syntax-table) ?a)) + (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-encode-region (b e &optional dont-fold) + "Encode words in region B to E that need encoding. +By default, the region is treated as containing RFC2822 addresses. +Dynamically bind `rfc2047-encoding-type' to change that." + (save-restriction + (narrow-to-region b e) + (let ((encodable-regexp (if rfc2047-encode-encoded-words + "[^\000-\177]+\\|=\\?" + "[^\000-\177]+")) + start ; start of current token + end begin csyntax + ;; Whether there's an encoded word before the current token, + ;; either immediately or separated by space. + last-encoded + (orig-text (buffer-substring-no-properties b e))) + (if (eq 'mime rfc2047-encoding-type) + ;; Simple case. Continuous words in which all those contain + ;; non-ASCII characters are encoded collectively. Encoding + ;; ASCII words, including `Re:' used in Subject headers, is + ;; avoided for interoperability with non-MIME clients and + ;; for making it easy to find keywords. + (progn + (goto-char (point-min)) + (while (progn (skip-chars-forward " \t\n") + (not (eobp))) + (setq start (point)) + (while (and (looking-at "[ \t\n]*\\([^ \t\n]+\\)") + (progn + (setq end (match-end 0)) + (re-search-forward encodable-regexp end t))) + (goto-char end)) + (if (> (point) start) + (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 + ;; Look for rfc2822-style: sequences of atoms, quoted + ;; strings, specials, whitespace. (Specials mustn't be + ;; encoded.) + (while (not (eobp)) + ;; Skip whitespace. + (skip-chars-forward " \t\n") + (setq start (point)) + (cond + ((not (char-after))) ; eob + ;; else token start + ((eq ?\" (setq csyntax (char-syntax (char-after)))) + ;; Quoted word. + (forward-sexp) + (setq end (point)) + ;; Does it need encoding? + (goto-char start) + (if (re-search-forward encodable-regexp end 'move) + ;; It needs encoding. Strip the quotes first, + ;; since encoded words can't occur in quotes. + (progn + (goto-char end) + (delete-char -1) + (goto-char start) + (delete-char 1) + (when last-encoded + ;; There was a preceding quoted word. We need + ;; to include any separating whitespace in this + ;; word to avoid it getting lost. + (skip-chars-backward " \t") + ;; A space is needed between the encoded words. + (insert ? ) + (setq start (point) + end (1+ end))) + ;; Adjust the end position for the deleted quotes. + (rfc2047-encode start (- end 2)) + (setq last-encoded t)) ; record that it was encoded + (setq last-encoded nil))) + ((eq ?. csyntax) + ;; Skip other delimiters, but record that they've + ;; potentially separated quoted words. + (forward-char) + (setq last-encoded nil)) + ((eq ?\) csyntax) + (error "Unbalanced parentheses")) + ((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)))) + (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 (or end (eobp))) + (when (looking-at "[\000-\177]+") + (setq begin (point) + end (match-end 0)) + (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 + (when (looking-at encodable-regexp) + (goto-char (setq begin (match-end 0))) + (while (and (looking-at "[ \t\n]+\\([^ \t\n]+\\)") + (setq end (match-end 0)) + (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)) + (if (re-search-forward "\\Sw+" end t) + ;; There are special characters better + ;; to be encoded so that MTAs may parse + ;; them safely. + (cond ((= end (point))) + ((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") + (if (and (looking-at "[^ \t\n]+") + (string-match encodable-regexp + (match-string 0))) + (setq end nil) + (goto-char end))))))) + (skip-chars-backward " \t\n") + (setq end (point)) + (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 + (if (or debug-on-quit debug-on-error) + (signal (car err) (cdr err)) + (error "Invalid data for rfc2047 encoding: %s" + (replace-regexp-in-string "[ \t\n]+" " " orig-text)))))))) + (unless dont-fold + (rfc2047-fold-region b (point))) + (goto-char (point-max)))) + +(defun rfc2047-encode-string (string &optional dont-fold) + "Encode words in STRING. +By default, the string is treated as containing addresses (see +`rfc2047-encoding-type')." + (mm-with-multibyte-buffer + (insert string) + (rfc2047-encode-region (point-min) (point-max) dont-fold) + (buffer-string))) + +;; From RFC 2047: +;; 2. Syntax of encoded-words +;; [...] +;; While there is no limit to the length of a multiple-line header +;; field, each line of a header field that contains one or more +;; 'encoded-word's is limited to 76 characters. +;; +;; In `rfc2047-encode-parameter' it is bound to nil, so don't defconst it. +(defvar rfc2047-encode-max-chars 76 + "Maximum characters of each header line that contain encoded-words. +According to RFC 2047, it is 76. If it is nil, encoded-words +will not be folded. Too small value may cause an error. You +should not change this value.") + +(defun rfc2047-encode-1 (column string cs encoder start crest tail + &optional eword) + "Subroutine used by `rfc2047-encode'." + (cond ((string-equal string "") + (or eword "")) + ((not rfc2047-encode-max-chars) + (concat start + (funcall encoder (if cs + (encode-coding-string string cs) + string)) + "?=")) + ((>= column rfc2047-encode-max-chars) + (when eword + (cond ((string-match "\n[ \t]+\\'" eword) + ;; Remove 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 len) + (while (and prev + (<= index limit)) + (setq next (concat start + (funcall encoder + (if cs + (encode-coding-string + (substring string 0 (1+ index)) + cs) + (substring string 0 (1+ index)))) + "?=") + 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) + (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) + ;; Remove a superfluous empty line. + (setq eword (substring eword 0 (match-beginning 0)))) + (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 tail crest eword) + ;; Use utf-8 as a last resort if determining charset of text fails. + (if (memq nil mime-charset) + (setq mime-charset (list 'utf-8))) + (cond ((> (length mime-charset) 1) + (error "Can't rfc2047-encode `%s'" + (buffer-substring-no-properties b e))) + ((= (length mime-charset) 1) + (setq mime-charset (car mime-charset) + cs (mm-charset-to-coding-system mime-charset)) + (unless (and (mm-multibyte-p) + (mm-coding-system-p cs)) + (setq cs nil)) + (save-restriction + (narrow-to-region b e) + (setq encoding + (or (cdr (assq mime-charset + rfc2047-charset-encoding-alist)) + ;; For the charsets that don't have a preferred + ;; encoding, choose the one that's shorter. + (if (eq (rfc2047-qp-or-base64) 'base64) + '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")) + ;; `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)) + (replace-regexp-in-string + "\n\\([ \t]?\\)" "\\1" + (buffer-substring-no-properties b e)) + cs + (or (cdr (assq encoding + rfc2047-encode-function-alist)) + 'identity) + (concat "=?" (downcase (symbol-name mime-charset)) + "?" (upcase (symbol-name encoding)) "?") + (or crest " ") + tail)) + (delete-region (if (eq (aref eword 0) ?\n) + (if (bolp) + ;; The line was folded before encoding. + (1- (point)) + (point)) + (goto-char b)) + (+ e (length tail))) + ;; `eword' contains `crest' and `tail'. + (insert eword) + (set-marker b nil) + (set-marker e nil) + (unless (or (/= 0 (length tail)) + (eobp) + (looking-at "[ \t\n)]")) + (insert " ")))) + (t + (goto-char e))))) + +(defun rfc2047-fold-field () + "Fold the current header field." + (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 + (narrow-to-region b e) + (goto-char (point-min)) + (let ((break nil) + (qword-break nil) + (first t) + (bol (save-restriction + (widen) + (point-at-bol)))) + (while (not (eobp)) + (when (and (or break qword-break) + (> (- (point) bol) 76)) + (goto-char (or break qword-break)) + (setq break nil + qword-break nil) + (skip-chars-backward " \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))) + (cond + ((eq (char-after) ?\n) + (forward-char 1) + (setq bol (point) + break nil + qword-break nil) + (skip-chars-forward " \t") + (unless (or (eobp) (eq (char-after) ?\n)) + (forward-char 1))) + ((eq (char-after) ?\r) + (forward-char 1)) + ((memq (char-after) '(? ?\t)) + (skip-chars-forward " \t") + (unless first ;; Don't break just after the header name. + (setq break (point)))) + ((not break) + (if (not (looking-at "=\\?[^=]")) + (if (eq (char-after) ?=) + (forward-char 1) + (skip-chars-forward "^ \t\n\r=")) + ;; Don't break at the start of the field. + (unless (= (point) b) + (setq qword-break (point))) + (skip-chars-forward "^ \t\n\r"))) + (t + (skip-chars-forward "^ \t\n\r"))) + (setq first nil)) + (when (and (or break qword-break) + (> (- (point) bol) 76)) + (goto-char (or break qword-break)) + (setq break nil + qword-break nil) + (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") + (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." + (save-restriction + (narrow-to-region b e) + (goto-char (point-min)) + (let ((bol (save-restriction + (widen) + (point-at-bol))) + (eol (point-at-eol))) + (forward-line 1) + (while (not (eobp)) + (if (and (looking-at "[ \t]") + (< (- (point-at-eol) bol) 76)) + (delete-region eol (progn + (goto-char eol) + (skip-chars-forward "\r\n") + (point))) + (setq bol (point-at-bol))) + (setq eol (point-at-eol)) + (forward-line 1))))) + +(defun rfc2047-b-encode-string (string) + "Base64-encode the header contained in STRING." + (base64-encode-string string t)) + +(autoload 'quoted-printable-encode-region "qp") + +(defun rfc2047-q-encode-string (string) + "Quoted-printable-encode the header in STRING." + (mm-with-unibyte-buffer + (insert string) + (quoted-printable-encode-region + (point-min) (point-max) nil + ;; = (\075), _ (\137), ? (\077) are used in the encoded word. + ;; Avoid using 8bit characters. + ;; This list excludes `especials' (see the RFC2047 syntax), + ;; meaning that some characters in non-structured fields will + ;; get encoded when they con't need to be. The following is + ;; what it used to be. + ;;; ;; Equivalent to "^\000-\007\011\013\015-\037\200-\377=_?" + ;;; "\010\012\014\040-\074\076\100-\136\140-\177") + "-\b\n\f !#-'*+0-9A-Z\\^`-~\d") + (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 substitution for the `rfc2231-encode-string' function, that +is the standard but many mailers don't support it." + (let ((rfc2047-encoding-type 'mime) + (rfc2047-encode-max-chars nil)) + (rfc2045-encode-string param (rfc2047-encode-string value t)))) + +;;; +;;; Functions for decoding RFC2047 messages +;;; + +(defvar rfc2047-quote-decoded-words-containing-tspecials nil + "If non-nil, quote decoded words containing special characters.") + +(defvar rfc2047-allow-incomplete-encoded-text t + "*Non-nil means allow incomplete encoded-text in successive encoded-words. +Dividing of encoded-text in the place other than character boundaries +violates RFC2047 section 5, while we have a capability to decode it. +If it is non-nil, the decoder will decode B- or Q-encoding in each +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-char -1)) + (forward-char))) + (forward-char)) + (error + (goto-char beg)))))))) + +(defun rfc2047-charset-to-coding-system (charset &optional allow-override) + "Return coding-system corresponding to MIME CHARSET. +If your Emacs implementation can't decode CHARSET, return nil. + +If allow-override is given, use `mm-charset-override-alist' to +map undesired charset names to their replacement. This should +only be used for decoding, not for encoding." + (when (stringp charset) + (setq charset (intern (downcase charset)))) + (when (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 nil allow-override))) + (cond ((eq cs 'ascii) + (setq cs (or (mm-charset-to-coding-system mail-parse-charset) + 'raw-text))) + ((mm-coding-system-p cs)) + ((and charset + (listp mail-parse-ignored-charsets) + (memq 'gnus-unknown mail-parse-ignored-charsets)) + (setq cs (mm-charset-to-coding-system mail-parse-charset)))) + (if (eq cs 'ascii) + 'raw-text + cs))) + +(autoload 'quoted-printable-decode-string "qp") + +(defun rfc2047-decode-encoded-words (words) + "Decode successive encoded-words in WORDS and return a decoded string. +Each element of WORDS looks like (CHARSET ENCODING ENCODED-TEXT +ENCODED-WORD)." + (let (word charset cs encoding text rest) + (while words + (setq word (pop words)) + (if (and (setq cs (rfc2047-charset-to-coding-system + (setq charset (car word)) t)) + (condition-case code + (cond ((char-equal ?B (nth 1 word)) + (setq text (base64-decode-string + (rfc2047-pad-base64 (nth 2 word))))) + ((char-equal ?Q (nth 1 word)) + (setq text (quoted-printable-decode-string + (subst-char-in-string + ?_ ? (nth 2 word) t))))) + (error + (message "%s" (error-message-string code)) + nil))) + (if (and rfc2047-allow-incomplete-encoded-text + (eq cs (caar rest))) + ;; Concatenate text of which the charset is the same. + (setcdr (car rest) (concat (cdar rest) text)) + (push (cons cs text) rest)) + ;; Don't decode encoded-word. + (push (cons nil (nth 3 word)) rest))) + (while rest + (setq words (concat + (or (and (setq cs (caar rest)) + (condition-case code + (decode-coding-string (cdar rest) cs) + (error + (message "%s" (error-message-string code)) + nil))) + (concat (when (cdr rest) " ") + (cdar rest) + (when (and words + (not (eq (string-to-char words) ? ))) + " "))) + words) + rest (cdr rest))) + words)) + +;; Fixme: This should decode in place, not cons intermediate strings. +;; Also check whether it needs to worry about delimiting fields like +;; encoding. + +;; In fact it's reported that (invalid) encoding of mailboxes in +;; addr-specs is in use, so delimiting fields might help. Probably +;; not decoding a word which isn't properly delimited is good enough +;; and worthwhile (is it more correct or not?), e.g. something like +;; `=?iso-8859-1?q?foo?=@'. + +(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 + (if rfc2047-allow-irregular-q-encoded-words + (eval-when-compile + (concat "[\n\t ]*\\(" rfc2047-encoded-word-regexp-loose "\\)")) + (eval-when-compile + (concat "[\n\t ]*\\(" rfc2047-encoded-word-regexp "\\)")))) + b e match words) + (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)) + (setq e (match-beginning 1) + end (match-end 0) + words nil) + (while match + (push (list (match-string 2) ;; charset + (char-after (match-beginning 3)) ;; encoding + (substring (match-string 3) 2) ;; encoded-text + (match-string 1)) ;; encoded-word + words) + ;; Look for the subsequent encoded-words. + (when (setq match (looking-at eword-regexp)) + (goto-char (setq end (match-end 0))))) + ;; Replace the encoded-words with the decoded one. + (delete-region e end) + (insert (rfc2047-decode-encoded-words (nreverse words))) + (save-restriction + (narrow-to-region e (point)) + (goto-char e) + ;; Remove newlines between decoded words, though such + ;; things essentially must not be there. + (while (re-search-forward "[\n\r]+" nil t) + (replace-match " ")) + (setq end (point-max)) + ;; Quote decoded words if there are special characters + ;; which might violate RFC2822. + (when (and rfc2047-quote-decoded-words-containing-tspecials + (let ((regexp (car (rassq + 'address-mime + rfc2047-header-encoding-alist)))) + (when regexp + (save-restriction + (widen) + (and + ;; Don't quote words if already quoted. + (not (and (eq (char-before e) ?\") + (eq (char-after end) ?\"))) + (progn + (beginning-of-line) + (while (and (memq (char-after) '(? ?\t)) + (zerop (forward-line -1)))) + (looking-at regexp))))))) + (let (quoted) + (goto-char e) + (skip-chars-forward " \t") + (setq start (point)) + (setq quoted (eq (char-after) ?\")) + (goto-char (point-max)) + (skip-chars-backward " \t" start) + (if (setq quoted (and quoted + (> (point) (1+ start)) + (eq (char-before) ?\"))) + (progn + (backward-char) + (setq start (1+ start) + end (point-marker))) + (setq end (point-marker))) + (goto-char start) + (while (search-forward "\"" end t) + (when (prog2 + (backward-char) + (zerop (% (skip-chars-backward "\\\\") 2)) + (goto-char (match-beginning 0))) + (insert "\\")) + (forward-char)) + (when (and (not quoted) + (progn + (goto-char start) + (re-search-forward + (concat "[" ietf-drums-tspecials "]") + end t))) + (goto-char start) + (insert "\"") + (goto-char end) + (insert "\"")) + (set-marker end nil))) + (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))) + (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 'gnus-decoded))) + (decode-coding-region b (point-max) mail-parse-charset)))))) + +(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." + (if (string-match "=\\?" string) + (with-temp-buffer + ;; We used to only call mm-enable-multibyte if `m' is non-nil, + ;; but this can't be the right criterion. Don't just revert this + ;; change if it encounters a bug. Please help me fix it + ;; right instead. --Stef + ;; The string returned should always be multibyte in a multibyte + ;; session, i.e. the buffer should be multibyte before + ;; `buffer-string' is called. + (mm-enable-multibyte) + (insert string) + (inline + (rfc2047-decode-region (point-min) (point-max) address-mime)) + (buffer-string)) + (when address-mime + (setq string + (with-temp-buffer + (when (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 + (not (eq mail-parse-charset 'us-ascii)) + (not (eq mail-parse-charset 'gnus-decoded))) + ;; `decode-coding-string' in Emacs offers a third optional + ;; arg NOCOPY to avoid consing a new string if the decoding + ;; is "trivial". Unfortunately it currently doesn't + ;; consider anything else than a nil coding system + ;; trivial. + ;; `rfc2047-decode-string' is called multiple times for each + ;; article during summary buffer generation, and we really + ;; want to avoid unnecessary consing. So we bypass + ;; `decode-coding-string' if the string is purely ASCII. + (if (eq (detect-coding-string string t) 'undecided) + ;; string is purely ASCII + string + (decode-coding-string string mail-parse-charset)) + (string-to-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 + ;; base64-decode-string accepts buggy strings, this function could + ;; be aliased to identity. + (if (= 0 (mod (length string) 4)) + string + (when (string-match "=+$" string) + (setq string (substring string 0 (match-beginning 0)))) + (case (mod (length string) 4) + (0 string) + (1 string) ;; Error, don't pad it. + (2 (concat string "==")) + (3 (concat string "="))))) + +(provide 'rfc2047) + +;;; rfc2047.el ends here diff --git a/lisp/mail/rfc2231.el b/lisp/mail/rfc2231.el new file mode 100644 index 00000000000..128779ab4c6 --- /dev/null +++ b/lisp/mail/rfc2231.el @@ -0,0 +1,308 @@ +;;; rfc2231.el --- Functions for decoding rfc2231 headers + +;; Copyright (C) 1998-2016 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> +;; This file is part of GNU Emacs. + +;; 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 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;;; Code: + +(eval-when-compile (require 'cl)) +(require 'ietf-drums) +(require 'rfc2047) +(autoload 'mm-encode-body "mm-bodies") +(autoload 'mail-header-remove-whitespace "mail-parse") +(autoload 'mail-header-remove-comments "mail-parse") + +(defun rfc2231-get-value (ct attribute) + "Return the value of ATTRIBUTE from CT." + (cdr (assq attribute (cdr ct)))) + +(defun rfc2231-parse-qp-string (string) + "Parse QP-encoded string using `rfc2231-parse-string'. +N.B. This is in violation with RFC2047, but it seem to be in common use." + (rfc2231-parse-string (rfc2047-decode-string string))) + +(defun rfc2231-parse-string (string &optional signal-error) + "Parse STRING and return a list. +The list will be on the form + `(name (attribute . value) (attribute . value)...)'. + +If the optional SIGNAL-ERROR is non-nil, signal an error when this +function fails in parsing of parameters. Otherwise, this function +must never cause a Lisp error." + (with-temp-buffer + (let ((ttoken (ietf-drums-token-to-list ietf-drums-text-token)) + (stoken (ietf-drums-token-to-list ietf-drums-tspecials)) + (ntoken (ietf-drums-token-to-list "0-9")) + c type attribute encoded number parameters value) + (ietf-drums-init + (condition-case nil + (mail-header-remove-whitespace + (mail-header-remove-comments string)) + ;; The most likely cause of an error is unbalanced parentheses + ;; or double-quotes. If all parentheses and double-quotes are + ;; quoted meaninglessly with backslashes, removing them might + ;; make it parsable. Let's try... + (error + (let (mod) + (when (and (string-match "\\\\\"" string) + (not (string-match "\\`\"\\|[^\\]\"" string))) + (setq string (replace-regexp-in-string "\\\\\"" "\"" string) + mod t)) + (when (and (string-match "\\\\(" string) + (string-match "\\\\)" string) + (not (string-match "\\`(\\|[^\\][()]" string))) + (setq string (replace-regexp-in-string + "\\\\\\([()]\\)" "\\1" string) + mod t)) + (or (and mod + (ignore-errors + (mail-header-remove-whitespace + (mail-header-remove-comments string)))) + ;; Finally, attempt to extract only type. + (if (string-match + (concat "\\`[\t\n ]*\\([^" ietf-drums-tspecials "\t\n ]+" + "\\(?:/[^" ietf-drums-tspecials + "\t\n ]+\\)?\\)\\(?:[\t\n ;]\\|\\'\\)") + string) + (match-string 1 string) + "")))))) + (let ((table (copy-syntax-table ietf-drums-syntax-table))) + (modify-syntax-entry ?\' "w" table) + (modify-syntax-entry ?* " " table) + (modify-syntax-entry ?\; " " table) + (modify-syntax-entry ?= " " table) + ;; The following isn't valid, but one should be liberal + ;; in what one receives. + (modify-syntax-entry ?\: "w" table) + (set-syntax-table table)) + (setq c (char-after)) + (when (and (memq c ttoken) + (not (memq c stoken)) + (setq type (ignore-errors + (downcase + (buffer-substring (point) (progn + (forward-sexp 1) + (point))))))) + ;; Do the params + (condition-case err + (progn + (while (not (eobp)) + (setq c (char-after)) + (unless (eq c ?\;) + (error "Invalid header: %s" string)) + (forward-char 1) + ;; If c in nil, then this is an invalid header, but + ;; since elm generates invalid headers on this form, + ;; we allow it. + (when (setq c (char-after)) + (if (and (memq c ttoken) + (not (memq c stoken))) + (setq attribute + (intern + (downcase + (buffer-substring + (point) (progn (forward-sexp 1) (point)))))) + (error "Invalid header: %s" string)) + (setq c (char-after)) + (if (eq c ?*) + (progn + (forward-char 1) + (setq c (char-after)) + (if (not (memq c ntoken)) + (setq encoded t + number nil) + (setq number + (string-to-number + (buffer-substring + (point) (progn (forward-sexp 1) (point))))) + (setq c (char-after)) + (when (eq c ?*) + (setq encoded t) + (forward-char 1) + (setq c (char-after))))) + (setq number nil + encoded nil)) + (unless (eq c ?=) + (error "Invalid header: %s" string)) + (forward-char 1) + (setq c (char-after)) + (cond + ((eq c ?\") + (setq value (buffer-substring (1+ (point)) + (progn + (forward-sexp 1) + (1- (point))))) + (when encoded + (setq value (mapconcat (lambda (c) (format "%%%02x" c)) + value "")))) + ((and (or (memq c ttoken) + ;; EXTENSION: Support non-ascii chars. + (> c ?\177)) + (not (memq c stoken))) + (setq value + (buffer-substring + (point) + (progn + ;; Jump over asterisk, non-ASCII + ;; and non-boundary characters. + (while (and c + (or (eq c ?*) + (> c ?\177) + (not (eq (char-syntax c) ? )))) + (forward-char 1) + (setq c (char-after))) + (point))))) + (t + (error "Invalid header: %s" string))) + (push (list attribute value number encoded) + parameters)))) + (error + (setq parameters nil) + (when signal-error + (signal (car err) (cdr err))))) + + ;; Now collect and concatenate continuation parameters. + (let ((cparams nil) + elem) + (loop for (attribute value part encoded) + in (sort parameters (lambda (e1 e2) + (< (or (caddr e1) 0) + (or (caddr e2) 0)))) + do (cond + ;; First part. + ((or (not (setq elem (assq attribute cparams))) + (and (numberp part) + (zerop part))) + (push (list attribute value encoded) cparams)) + ;; Repetition of a part; do nothing. + ((and elem + (null number)) + ) + ;; Concatenate continuation parts. + (t + (setcar (cdr elem) (concat (cadr elem) value))))) + ;; Finally decode encoded values. + (cons type (mapcar + (lambda (elem) + (cons (car elem) + (if (nth 2 elem) + (rfc2231-decode-encoded-string (nth 1 elem)) + (nth 1 elem)))) + (nreverse cparams)))))))) + +(defun rfc2231-decode-encoded-string (string) + "Decode an RFC2231-encoded string. +These look like: + \"us-ascii\\='en-us\\='This%20is%20%2A%2A%2Afun%2A%2A%2A\", + \"us-ascii\\='\\='This%20is%20%2A%2A%2Afun%2A%2A%2A\", + \"\\='en-us\\='This%20is%20%2A%2A%2Afun%2A%2A%2A\", + \"\\='\\='This%20is%20%2A%2A%2Afun%2A%2A%2A\", or + \"This is ***fun***\"." + (string-match "\\`\\(?:\\([^']+\\)?'\\([^']+\\)?'\\)?\\(.+\\)" string) + (let ((coding-system (mm-charset-to-coding-system + (match-string 1 string) nil t)) + ;;(language (match-string 2 string)) + (value (match-string 3 string))) + (mm-with-unibyte-buffer + (insert value) + (goto-char (point-min)) + (while (re-search-forward "%\\([0-9A-Fa-f][0-9A-Fa-f]\\)" nil t) + (insert + (prog1 + (string-to-number (match-string 1) 16) + (delete-region (match-beginning 0) (match-end 0))))) + ;; Decode using the charset, if any. + (if (memq coding-system '(nil ascii)) + (buffer-string) + (decode-coding-string (buffer-string) coding-system))))) + +(defun rfc2231-encode-string (param value) + "Return and PARAM=VALUE string encoded according to RFC2231. +Use `mml-insert-parameter' or `mml-insert-parameter-string' to insert +the result of this function." + (let ((control (ietf-drums-token-to-list ietf-drums-no-ws-ctl-token)) + (tspecial (ietf-drums-token-to-list ietf-drums-tspecials)) + (special (ietf-drums-token-to-list "*'%\n\t")) + (ascii (ietf-drums-token-to-list ietf-drums-text-token)) + (num -1) + ;; Don't make lines exceeding 76 column. + (limit (- 74 (length param))) + spacep encodep charsetp charset broken) + (mm-with-multibyte-buffer + (insert value) + (goto-char (point-min)) + (while (not (eobp)) + (cond + ((or (memq (following-char) control) + (memq (following-char) tspecial) + (memq (following-char) special)) + (setq encodep t)) + ((eq (following-char) ? ) + (setq spacep t)) + ((not (memq (following-char) ascii)) + (setq charsetp t))) + (forward-char 1)) + (when charsetp + (setq charset (mm-encode-body))) + (mm-disable-multibyte) + (cond + ((or encodep charsetp + (progn + (end-of-line) + (> (current-column) (if spacep (- limit 2) limit)))) + (setq limit (- limit 6)) + (goto-char (point-min)) + (insert (symbol-name (or charset 'us-ascii)) "''") + (while (not (eobp)) + (if (or (not (memq (following-char) ascii)) + (memq (following-char) control) + (memq (following-char) tspecial) + (memq (following-char) special) + (eq (following-char) ? )) + (progn + (when (>= (current-column) (1- limit)) + (insert ";\n") + (setq broken t)) + (insert "%" (format "%02x" (following-char))) + (delete-char 1)) + (when (> (current-column) limit) + (insert ";\n") + (setq broken t)) + (forward-char 1))) + (goto-char (point-min)) + (if (not broken) + (insert param "*=") + (while (not (eobp)) + (insert (if (>= num 0) " " "") + param "*" (format "%d" (incf num)) "*=") + (forward-line 1)))) + (spacep + (goto-char (point-min)) + (insert param "=\"") + (goto-char (point-max)) + (insert "\"")) + (t + (goto-char (point-min)) + (insert param "="))) + (buffer-string)))) + +(provide 'rfc2231) + +;;; rfc2231.el ends here diff --git a/lisp/mail/rmail.el b/lisp/mail/rmail.el index 10ba5b38031..734155e217d 100644 --- a/lisp/mail/rmail.el +++ b/lisp/mail/rmail.el @@ -40,6 +40,8 @@ (require 'mail-utils) (require 'rfc2047) +(require 'rmail-loaddefs) + (declare-function compilation--message->loc "compile" (cl-x) t) (declare-function epa--find-coding-system-for-mime-charset "epa" (mime-charset)) @@ -161,7 +163,7 @@ its character representation and its display representation.") (put 'rmail-spool-directory 'standard-value '((cond ((file-exists-p "/var/mail") "/var/mail/") ((file-exists-p "/var/spool/mail") "/var/spool/mail/") - ((memq system-type '(hpux usg-unix-v irix)) "/usr/mail/") + ((memq system-type '(hpux usg-unix-v)) "/usr/mail/") (t "/usr/spool/mail/")))) ;;;###autoload @@ -174,7 +176,7 @@ its character representation and its display representation.") "/var/mail/") ;; Many GNU/Linux systems use this name. ((file-exists-p "/var/spool/mail") "/var/spool/mail/") - ((memq system-type '(hpux usg-unix-v irix)) "/usr/mail/") + ((memq system-type '(hpux usg-unix-v)) "/usr/mail/") (t "/usr/spool/mail/"))) "Name of directory used by system mailer for delivering new mail. Its name should end with a slash." @@ -239,6 +241,7 @@ please report it with \\[report-emacs-bug].") (declare-function mail-dont-reply-to "mail-utils" (destinations)) (declare-function rmail-update-summary "rmailsum" (&rest ignore)) (declare-function rmail-mime-toggle-hidden "rmailmm" ()) +(declare-function rmail-mime-entity-truncated "rmailmm" (entity)) (defun rmail-probe (prog) "Determine what flavor of movemail PROG is. @@ -4588,6 +4591,7 @@ Argument MIME is non-nil if this is a mime message." ;; There doesn't really seem to be an appropriate menu. ;; Eg the edit command is not in a menu either. +(defvar rmail-mime-render-html-function) ; defcustom in rmailmm (defun rmail-epa-decrypt () "Decrypt GnuPG or OpenPGP armors in current message." (interactive) @@ -4730,227 +4734,6 @@ Argument MIME is non-nil if this is a mime message." (setq buffer-file-coding-system rmail-message-encoding)))) (add-hook 'after-save-hook 'rmail-after-save-hook) - -;;; Start of automatically extracted autoloads. - -;;;### (autoloads nil "rmailedit" "rmailedit.el" "03eb8c36b3c57d58eecedb9eeffa623e") -;;; Generated autoloads from rmailedit.el - -(autoload 'rmail-edit-current-message "rmailedit" "\ -Edit the contents of this message. - -\(fn)" t nil) - -;;;*** - -;;;### (autoloads nil "rmailkwd" "rmailkwd.el" "4e1b251929961e2b9d3b126301d697d0") -;;; Generated autoloads from rmailkwd.el - -(autoload 'rmail-add-label "rmailkwd" "\ -Add LABEL to labels associated with current RMAIL message. -Completes (see `rmail-read-label') over known labels when reading. -LABEL may be a symbol or string. Only one label is allowed. - -\(fn LABEL)" t nil) - -(autoload 'rmail-kill-label "rmailkwd" "\ -Remove LABEL from labels associated with current RMAIL message. -Completes (see `rmail-read-label') over known labels when reading. -LABEL may be a symbol or string. Only one label is allowed. - -\(fn LABEL)" t nil) - -(autoload 'rmail-read-label "rmailkwd" "\ -Read a label with completion, prompting with PROMPT. -Completions are chosen from `rmail-label-obarray'. The default -is `rmail-last-label', if that is non-nil. Updates `rmail-last-label' -according to the choice made, and returns a symbol. - -\(fn PROMPT)" nil nil) - -(autoload 'rmail-previous-labeled-message "rmailkwd" "\ -Show previous message with one of the labels LABELS. -LABELS should be a comma-separated list of label names. -If LABELS is empty, the last set of labels specified is used. -With prefix argument N moves backward N messages with these labels. - -\(fn N LABELS)" t nil) - -(autoload 'rmail-next-labeled-message "rmailkwd" "\ -Show next message with one of the labels LABELS. -LABELS should be a comma-separated list of label names. -If LABELS is empty, the last set of labels specified is used. -With prefix argument N moves forward N messages with these labels. - -\(fn N LABELS)" t nil) - -;;;*** - -;;;### (autoloads nil "rmailmm" "rmailmm.el" "7ab6ab96dfdeeec6bc8f4620295b7119") -;;; Generated autoloads from rmailmm.el - -(autoload 'rmail-mime "rmailmm" "\ -Toggle the display of a MIME message. - -The actual behavior depends on the value of `rmail-enable-mime'. - -If `rmail-enable-mime' is non-nil (the default), this command toggles -the display of a MIME message between decoded presentation form and -raw data. With optional prefix argument ARG, it toggles the display only -of the MIME entity at point, if there is one. The optional argument -STATE forces a particular display state, rather than toggling. -`raw' forces raw mode, any other non-nil value forces decoded mode. - -If `rmail-enable-mime' is nil, this creates a temporary \"*RMAIL*\" -buffer holding a decoded copy of the message. Inline content-types are -handled according to `rmail-mime-media-type-handlers-alist'. -By default, this displays text and multipart messages, and offers to -download attachments as specified by `rmail-mime-attachment-dirs-alist'. -The arguments ARG and STATE have no effect in this case. - -\(fn &optional ARG STATE)" t nil) - -;;;*** - -;;;### (autoloads nil "rmailmsc" "rmailmsc.el" "471c370ff9f183806c8d749961ec9d79") -;;; Generated autoloads from rmailmsc.el - -(autoload 'set-rmail-inbox-list "rmailmsc" "\ -Set the inbox list of the current RMAIL file to FILE-NAME. -You can specify one file name, or several names separated by commas. -If FILE-NAME is empty, remove any existing inbox list. - -This applies only to the current session. - -\(fn FILE-NAME)" t nil) - -;;;*** - -;;;### (autoloads nil "rmailsort" "rmailsort.el" "2c8e39f7bae6fcc465a83ebccd46c8a4") -;;; Generated autoloads from rmailsort.el - -(autoload 'rmail-sort-by-date "rmailsort" "\ -Sort messages of current Rmail buffer by \"Date\" header. -If prefix argument REVERSE is non-nil, sorts in reverse order. - -\(fn REVERSE)" t nil) - -(autoload 'rmail-sort-by-subject "rmailsort" "\ -Sort messages of current Rmail buffer by \"Subject\" header. -Ignores any \"Re: \" prefix. If prefix argument REVERSE is -non-nil, sorts in reverse order. - -\(fn REVERSE)" t nil) - -(autoload 'rmail-sort-by-author "rmailsort" "\ -Sort messages of current Rmail buffer by author. -This uses either the \"From\" or \"Sender\" header, downcased. -If prefix argument REVERSE is non-nil, sorts in reverse order. - -\(fn REVERSE)" t nil) - -(autoload 'rmail-sort-by-recipient "rmailsort" "\ -Sort messages of current Rmail buffer by recipient. -This uses either the \"To\" or \"Apparently-To\" header, downcased. -If prefix argument REVERSE is non-nil, sorts in reverse order. - -\(fn REVERSE)" t nil) - -(autoload 'rmail-sort-by-correspondent "rmailsort" "\ -Sort messages of current Rmail buffer by other correspondent. -This uses either the \"From\", \"Sender\", \"To\", or -\"Apparently-To\" header, downcased. Uses the first header not -excluded by `mail-dont-reply-to-names'. If prefix argument -REVERSE is non-nil, sorts in reverse order. - -\(fn REVERSE)" t nil) - -(autoload 'rmail-sort-by-lines "rmailsort" "\ -Sort messages of current Rmail buffer by the number of lines. -If prefix argument REVERSE is non-nil, sorts in reverse order. - -\(fn REVERSE)" t nil) - -(autoload 'rmail-sort-by-labels "rmailsort" "\ -Sort messages of current Rmail buffer by labels. -LABELS is a comma-separated list of labels. The order of these -labels specifies the order of messages: messages with the first -label come first, messages with the second label come second, and -so on. Messages that have none of these labels come last. -If prefix argument REVERSE is non-nil, sorts in reverse order. - -\(fn REVERSE LABELS)" t nil) - -;;;*** - -;;;### (autoloads nil "rmailsum" "rmailsum.el" "8205e67c8188aa5c01715e79e10667c1") -;;; Generated autoloads from rmailsum.el - -(autoload 'rmail-summary "rmailsum" "\ -Display a summary of all messages, one line per message. - -\(fn)" t nil) - -(autoload 'rmail-summary-by-labels "rmailsum" "\ -Display a summary of all messages with one or more LABELS. -LABELS should be a string containing the desired labels, separated by commas. - -\(fn LABELS)" t nil) - -(autoload 'rmail-summary-by-recipients "rmailsum" "\ -Display a summary of all messages with the given RECIPIENTS. -Normally checks the To, From and Cc fields of headers; -but if PRIMARY-ONLY is non-nil (prefix arg given), - only look in the To and From fields. -RECIPIENTS is a regular expression. - -\(fn RECIPIENTS &optional PRIMARY-ONLY)" t nil) - -(autoload 'rmail-summary-by-regexp "rmailsum" "\ -Display a summary of all messages according to regexp REGEXP. -If the regular expression is found in the header of the message -\(including in the date and other lines, as well as the subject line), -Emacs will list the message in the summary. - -\(fn REGEXP)" t nil) - -(autoload 'rmail-summary-by-topic "rmailsum" "\ -Display a summary of all messages with the given SUBJECT. -Normally checks just the Subject field of headers; but with prefix -argument WHOLE-MESSAGE is non-nil, looks in the whole message. -SUBJECT is a regular expression. - -\(fn SUBJECT &optional WHOLE-MESSAGE)" t nil) - -(autoload 'rmail-summary-by-senders "rmailsum" "\ -Display a summary of all messages whose \"From\" field matches SENDERS. -SENDERS is a regular expression. - -\(fn SENDERS)" t nil) - -;;;*** - -;;;### (autoloads nil "undigest" "undigest.el" "20561f083496eb113fa9e501902bfcc3") -;;; Generated autoloads from undigest.el - -(autoload 'undigestify-rmail-message "undigest" "\ -Break up a digest message into its constituent messages. -Leaves original message, deleted, before the undigestified messages. - -\(fn)" t nil) - -(autoload 'unforward-rmail-message "undigest" "\ -Extract a forwarded message from the containing message. -This puts the forwarded message into a separate rmail message following -the containing message. This command is only useful when messages are -forwarded with `rmail-enable-mime-composing' set to nil. - -\(fn)" t nil) - -;;;*** - -;;; End of automatically extracted autoloads. - (provide 'rmail) diff --git a/lisp/mail/rmailedit.el b/lisp/mail/rmailedit.el index 5c29e7ec8bf..46e5e17a2e8 100644 --- a/lisp/mail/rmailedit.el +++ b/lisp/mail/rmailedit.el @@ -448,7 +448,7 @@ HEADER-DIFF should be a return value from `rmail-edit-diff-headers'." (provide 'rmailedit) ;; Local Variables: -;; generated-autoload-file: "rmail.el" +;; generated-autoload-file: "rmail-loaddefs.el" ;; End: ;;; rmailedit.el ends here diff --git a/lisp/mail/rmailkwd.el b/lisp/mail/rmailkwd.el index 0301e512129..6581ee628a7 100644 --- a/lisp/mail/rmailkwd.el +++ b/lisp/mail/rmailkwd.el @@ -192,7 +192,7 @@ With prefix argument N moves forward N messages with these labels." (provide 'rmailkwd) ;; Local Variables: -;; generated-autoload-file: "rmail.el" +;; generated-autoload-file: "rmail-loaddefs.el" ;; End: ;;; rmailkwd.el ends here diff --git a/lisp/mail/rmailmm.el b/lisp/mail/rmailmm.el index 75219747684..9343b118067 100644 --- a/lisp/mail/rmailmm.el +++ b/lisp/mail/rmailmm.el @@ -1560,7 +1560,7 @@ This is the usual value of `rmail-insert-mime-forwarded-message-function'." (provide 'rmailmm) ;; Local Variables: -;; generated-autoload-file: "rmail.el" +;; generated-autoload-file: "rmail-loaddefs.el" ;; End: ;;; rmailmm.el ends here diff --git a/lisp/mail/rmailmsc.el b/lisp/mail/rmailmsc.el index 0a76576dfc2..1185dccf225 100644 --- a/lisp/mail/rmailmsc.el +++ b/lisp/mail/rmailmsc.el @@ -55,7 +55,7 @@ This applies only to the current session." (rmail-show-message-1 rmail-current-message)) ;; Local Variables: -;; generated-autoload-file: "rmail.el" +;; generated-autoload-file: "rmail-loaddefs.el" ;; End: ;;; rmailmsc.el ends here diff --git a/lisp/mail/rmailsort.el b/lisp/mail/rmailsort.el index 1eb60c2d547..60320b929e4 100644 --- a/lisp/mail/rmailsort.el +++ b/lisp/mail/rmailsort.el @@ -251,7 +251,7 @@ Numeric keys are sorted numerically, all others as strings." (provide 'rmailsort) ;; Local Variables: -;; generated-autoload-file: "rmail.el" +;; generated-autoload-file: "rmail-loaddefs.el" ;; End: ;;; rmailsort.el ends here diff --git a/lisp/mail/rmailsum.el b/lisp/mail/rmailsum.el index 52b717fb9d5..0a2ca0b8038 100644 --- a/lisp/mail/rmailsum.el +++ b/lisp/mail/rmailsum.el @@ -1871,7 +1871,7 @@ the summary is only showing a subset of messages." (provide 'rmailsum) ;; Local Variables: -;; generated-autoload-file: "rmail.el" +;; generated-autoload-file: "rmail-loaddefs.el" ;; End: ;;; rmailsum.el ends here diff --git a/lisp/mail/smtpmail.el b/lisp/mail/smtpmail.el index 8e0bb3ae6ba..f21b847b49b 100644 --- a/lisp/mail/smtpmail.el +++ b/lisp/mail/smtpmail.el @@ -858,8 +858,6 @@ Returns an error if the server cannot be contacted." ;; Send the contents. (smtpmail-command-or-throw process "DATA") (smtpmail-send-data process smtpmail-text-buffer) - ;; DATA end "." - (smtpmail-command-or-throw process ".") ;; Return success. nil)) (when (and process @@ -957,10 +955,11 @@ Returns an error if the server cannot be contacted." (process-send-string process "\r\n")) (defun smtpmail-send-data (process buffer) - (let ((data-continue t) sending-data + (let ((data-continue t) (pr (with-current-buffer buffer (make-progress-reporter "Sending email " - (point-min) (point-max))))) + (point-min) (point-max)))) + sending-data) (with-current-buffer buffer (goto-char (point-min))) (while data-continue @@ -970,6 +969,8 @@ Returns an error if the server cannot be contacted." (end-of-line 2) (setq data-continue (not (eobp)))) (smtpmail-send-data-1 process sending-data)) + ;; DATA end "." + (smtpmail-command-or-throw process ".") (progress-reporter-done pr))) (defun smtpmail-deduce-address-list (smtpmail-text-buffer header-start header-end) diff --git a/lisp/mail/undigest.el b/lisp/mail/undigest.el index 1d0a3718a96..54ee99bafb2 100644 --- a/lisp/mail/undigest.el +++ b/lisp/mail/undigest.el @@ -327,7 +327,7 @@ forwarded with `rmail-enable-mime-composing' set to nil." (provide 'undigest) ;; Local Variables: -;; generated-autoload-file: "rmail.el" +;; generated-autoload-file: "rmail-loaddefs.el" ;; End: ;;; undigest.el ends here diff --git a/lisp/mail/yenc.el b/lisp/mail/yenc.el new file mode 100644 index 00000000000..a4ebd0db15b --- /dev/null +++ b/lisp/mail/yenc.el @@ -0,0 +1,139 @@ +;;; yenc.el --- elisp native yenc decoder + +;; Copyright (C) 2002-2016 Free Software Foundation, Inc. + +;; Author: Jesper Harder <harder@ifa.au.dk> +;; Keywords: yenc news + +;; This file is part of GNU Emacs. + +;; 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 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Functions for decoding yenc encoded messages. +;; +;; Limitations: +;; +;; * Does not handle multipart messages. +;; * No support for external decoders. +;; * Doesn't check the crc32 checksum (if present). + +;;; Code: + +(eval-when-compile (require 'cl)) + +(defconst yenc-begin-line + "^=ybegin.*$") + +(defconst yenc-decoding-vector + [214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 + 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 + 248 249 250 251 252 253 254 255 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 + 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 + 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 + 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 + 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 + 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 + 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 + 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 + 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 + 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 + 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 + 208 209 210 211 212 213]) + +(defun yenc-first-part-p () + "Say whether the buffer contains the first part of a yEnc file." + (save-excursion + (goto-char (point-min)) + (re-search-forward "^=ybegin part=1 " nil t))) + +(defun yenc-last-part-p () + "Say whether the buffer contains the last part of a yEnc file." + (save-excursion + (goto-char (point-min)) + (let (total-size end-size) + (when (re-search-forward "^=ybegin.*size=\\([0-9]+\\)" nil t) + (setq total-size (match-string 1))) + (when (re-search-forward "^=ypart.*end=\\([0-9]+\\)" nil t) + (setq end-size (match-string 1))) + (and total-size + end-size + (string= total-size end-size))))) + +;;;###autoload +(defun yenc-decode-region (start end) + "Yenc decode region between START and END using an internal decoder." + (interactive "r") + (let (work-buffer) + (unwind-protect + (save-excursion + (goto-char start) + (when (re-search-forward yenc-begin-line end t) + (let ((first (match-end 0)) + (header-alist (yenc-parse-line (match-string 0))) + bytes last footer-alist char) + (when (re-search-forward "^=ypart.*$" end t) + (setq first (match-end 0))) + (when (re-search-forward "^=yend.*$" end t) + (setq last (match-beginning 0)) + (setq footer-alist (yenc-parse-line (match-string 0))) + (setq work-buffer (generate-new-buffer " *yenc-work*")) + (with-current-buffer work-buffer + (set-buffer-multibyte nil)) + (while (< first last) + (setq char (char-after first)) + (cond ((or (eq char ?\r) + (eq char ?\n))) + ((eq char ?=) + (setq char (char-after (incf first))) + (with-current-buffer work-buffer + (insert-char (mod (- char 106) 256) 1))) + (t + (with-current-buffer work-buffer + ;;(insert-char (mod (- char 42) 256) 1) + (insert-char (aref yenc-decoding-vector char) 1)))) + (incf first)) + (setq bytes (buffer-size work-buffer)) + (unless (and (= (cdr (assq 'size header-alist)) bytes) + (= (cdr (assq 'size footer-alist)) bytes)) + (message "Warning: Size mismatch while decoding.")) + (goto-char start) + (delete-region start end) + (insert-buffer-substring work-buffer)))) + (and work-buffer (kill-buffer work-buffer)))))) + +;;;###autoload +(defun yenc-extract-filename () + "Extract file name from an yenc header." + (save-excursion + (when (re-search-forward yenc-begin-line nil t) + (cdr (assoc 'name (yenc-parse-line (match-string 0))))))) + +(defun yenc-parse-line (str) + "Extract file name and size from STR." + (let (result name) + (when (string-match "^=y.*size=\\([0-9]+\\)" str) + (push (cons 'size (string-to-number (match-string 1 str))) result)) + (when (string-match "^=y.*name=\\(.*\\)$" str) + (setq name (match-string 1 str)) + ;; Remove trailing white space + (when (string-match " +$" name) + (setq name (substring name 0 (match-beginning 0)))) + (push (cons 'name name) result)) + result)) + +(provide 'yenc) + +;;; yenc.el ends here |