projects
/
gnus
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
* gnus-art.el (article-make-date-line): Limit the length a bit more.
[gnus]
/
lisp
/
mml.el
diff --git
a/lisp/mml.el
b/lisp/mml.el
index
6028ce8
..
8b196fa
100644
(file)
--- a/
lisp/mml.el
+++ b/
lisp/mml.el
@@
-1,7
+1,6
@@
;;; mml.el --- A package for parsing and validating MML documents
;;; mml.el --- A package for parsing and validating MML documents
-;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
-;; 2007, 2008, 2009 Free Software Foundation, Inc.
+;; Copyright (C) 1998-2011 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; This file is part of GNU Emacs.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; This file is part of GNU Emacs.
@@
-23,7
+22,7
@@
;;; Code:
;;; Code:
-;; For Emacs <
22.2
.
+;; For Emacs <
22.2 and XEmacs
.
(eval-and-compile
(unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
(eval-and-compile
(unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
@@
-33,10
+32,14
@@
(require 'mm-decode)
(require 'mml-sec)
(eval-when-compile (require 'cl))
(require 'mm-decode)
(require 'mml-sec)
(eval-when-compile (require 'cl))
+(eval-when-compile
+ (when (featurep 'xemacs)
+ (require 'easy-mmode))) ; for `define-minor-mode'
(autoload 'message-make-message-id "message")
(autoload 'message-make-message-id "message")
-(
autoload 'gnus-setup-posting-charset "gnus-msg"
)
+(
declare-function gnus-setup-posting-charset "gnus-msg" (group)
)
(autoload 'gnus-make-local-hook "gnus-util")
(autoload 'gnus-make-local-hook "gnus-util")
+(autoload 'gnus-completing-read "gnus-util")
(autoload 'message-fetch-field "message")
(autoload 'message-mark-active-p "message")
(autoload 'message-info "message")
(autoload 'message-fetch-field "message")
(autoload 'message-mark-active-p "message")
(autoload 'message-info "message")
@@
-117,10
+120,18
@@
match found will be used."
,dispositions))))
:group 'message)
,dispositions))))
:group 'message)
-(defcustom mml-insert-mime-headers-always
nil
+(defcustom mml-insert-mime-headers-always
t
"If non-nil, always put Content-Type: text/plain at top of empty parts.
It is necessary to work against a bug in certain clients."
"If non-nil, always put Content-Type: text/plain at top of empty parts.
It is necessary to work against a bug in certain clients."
- :version "22.1"
+ :version "24.1"
+ :type 'boolean
+ :group 'message)
+
+(defcustom mml-enable-flowed t
+ "If non-nil, enable format=flowed usage when encoding a message.
+This is only performed when filling on text/plain with hard
+newlines in the text."
+ :version "24.1"
:type 'boolean
:group 'message)
:type 'boolean
:group 'message)
@@
-225,7
+236,10
@@
part. This is for the internal use, you should never modify the value.")
(let* (secure-mode
(taginfo (mml-read-tag))
(keyfile (cdr (assq 'keyfile taginfo)))
(let* (secure-mode
(taginfo (mml-read-tag))
(keyfile (cdr (assq 'keyfile taginfo)))
- (certfile (cdr (assq 'certfile taginfo)))
+ (certfiles (delq nil (mapcar (lambda (tag)
+ (if (eq (car-safe tag) 'certfile)
+ (cdr tag)))
+ taginfo)))
(recipients (cdr (assq 'recipients taginfo)))
(sender (cdr (assq 'sender taginfo)))
(location (cdr (assq 'tag-location taginfo)))
(recipients (cdr (assq 'recipients taginfo)))
(sender (cdr (assq 'sender taginfo)))
(location (cdr (assq 'tag-location taginfo)))
@@
-251,8
+265,10
@@
part. This is for the internal use, you should never modify the value.")
,@tags
,(if keyfile "keyfile")
,keyfile
,@tags
,(if keyfile "keyfile")
,keyfile
- ,(if certfile "certfile")
- ,certfile
+ ,@(apply #'append
+ (mapcar (lambda (certfile)
+ (list "certfile" certfile))
+ certfiles))
,(if recipients "recipients")
,recipients
,(if sender "sender")
,(if recipients "recipients")
,recipients
,(if sender "sender")
@@
-392,8
+408,8
@@
A message part needs to be split into %d charset parts. Really send? "
(skip-chars-forward "= \t\n")
(setq val (buffer-substring-no-properties
(point) (progn (forward-sexp 1) (point))))
(skip-chars-forward "= \t\n")
(setq val (buffer-substring-no-properties
(point) (progn (forward-sexp 1) (point))))
- (when (string-match "
^\"\\(.*\\)\"$
" val)
- (setq val (
match-string 1 val)))
+ (when (string-match "
\\`\"
" val)
+ (setq val (
read val))) ;; inverse of prin1 in mml-insert-tag
(push (cons (intern elem) val) contents)
(skip-chars-forward " \t\n"))
(goto-char (match-end 0))
(push (cons (intern elem) val) contents)
(skip-chars-forward " \t\n"))
(goto-char (match-end 0))
@@
-520,7
+536,10
@@
If MML is non-nil, return the buffer up till the correspondent mml tag."
;; `m-g-d-t' will be bound to "message/rfc822"
;; when encoding an article to be forwarded.
(mml-generate-default-type "text/plain"))
;; `m-g-d-t' will be bound to "message/rfc822"
;; when encoding an article to be forwarded.
(mml-generate-default-type "text/plain"))
- (mml-to-mime))
+ (mml-to-mime)
+ ;; Update handle so mml-compute-boundary can
+ ;; detect collisions with the nested parts.
+ (setcdr (assoc 'contents cont) (buffer-string)))
(let ((mm-7bit-chars (concat mm-7bit-chars "\x1b")))
;; ignore 0x1b, it is part of iso-2022-jp
(setq encoding (mm-body-7-or-8))))
(let ((mm-7bit-chars (concat mm-7bit-chars "\x1b")))
;; ignore 0x1b, it is part of iso-2022-jp
(setq encoding (mm-body-7-or-8))))
@@
-534,7
+553,8
@@
If MML is non-nil, return the buffer up till the correspondent mml tag."
;; in the mml tag or it says "flowed" and there
;; actually are hard newlines in the text.
(let (use-hard-newlines)
;; in the mml tag or it says "flowed" and there
;; actually are hard newlines in the text.
(let (use-hard-newlines)
- (when (and (string= type "text/plain")
+ (when (and mml-enable-flowed
+ (string= type "text/plain")
(not (string= (cdr (assq 'sign cont)) "pgp"))
(or (null (assq 'format cont))
(string= (cdr (assq 'format cont))
(not (string= (cdr (assq 'sign cont)) "pgp"))
(or (null (assq 'format cont))
(string= (cdr (assq 'format cont))
@@
-585,7
+605,9
@@
If MML is non-nil, return the buffer up till the correspondent mml tag."
(unless raw
(setq charset (mm-encode-body charset))))
(insert contents)))))
(unless raw
(setq charset (mm-encode-body charset))))
(insert contents)))))
- (setq encoding (mm-encode-buffer type)
+ (if (setq encoding (cdr (assq 'encoding cont)))
+ (setq encoding (intern (downcase encoding))))
+ (setq encoding (mm-encode-buffer type encoding)
coded (mm-string-as-multibyte (buffer-string))))
(mml-insert-mime-headers cont type charset encoding nil)
(insert "\n" coded))))
coded (mm-string-as-multibyte (buffer-string))))
(mml-insert-mime-headers cont type charset encoding nil)
(insert "\n" coded))))
@@
-697,7
+719,7
@@
If MML is non-nil, return the buffer up till the correspondent mml tag."
(defun mml-compute-boundary-1 (cont)
(let (filename)
(cond
(defun mml-compute-boundary-1 (cont)
(let (filename)
(cond
- ((
eq (car cont) 'part
)
+ ((
member (car cont) '(part mml)
)
(with-temp-buffer
(cond
((cdr (assq 'buffer cont))
(with-temp-buffer
(cond
((cdr (assq 'buffer cont))
@@
-896,8
+918,7
@@
If HANDLES is non-nil, use it instead reparsing the buffer."
;; Determine type and stuff.
(unless (stringp (car handle))
(unless (setq textp (equal (mm-handle-media-supertype handle) "text"))
;; Determine type and stuff.
(unless (stringp (car handle))
(unless (setq textp (equal (mm-handle-media-supertype handle) "text"))
- (save-excursion
- (set-buffer (setq buffer (mml-generate-new-buffer " *mml*")))
+ (with-current-buffer (setq buffer (mml-generate-new-buffer " *mml*"))
(if (eq (mail-content-type-get (mm-handle-type handle) 'charset)
'gnus-decoded)
;; A part that mm-uu dissected from a non-MIME message
(if (eq (mail-content-type-get (mm-handle-type handle) 'charset)
'gnus-decoded)
;; A part that mm-uu dissected from a non-MIME message
@@
-1124,25
+1145,18
@@
If HANDLES is non-nil, use it instead reparsing the buffer."
,@(if (featurep 'xemacs) '(t)
'(:help "Display the EasyPG manual"))]))
,@(if (featurep 'xemacs) '(t)
'(:help "Display the EasyPG manual"))]))
-(defvar mml-mode nil
- "Minor mode for editing MML.")
-
-(defun mml-mode (&optional arg)
+(define-minor-mode mml-mode
"Minor mode for editing MML.
MML is the MIME Meta Language, a minor mode for composing MIME articles.
See Info node `(emacs-mime)Composing'.
\\{mml-mode-map}"
"Minor mode for editing MML.
MML is the MIME Meta Language, a minor mode for composing MIME articles.
See Info node `(emacs-mime)Composing'.
\\{mml-mode-map}"
- (interactive "P")
- (when (set (make-local-variable 'mml-mode)
- (if (null arg) (not mml-mode)
- (> (prefix-numeric-value arg) 0)))
- (add-minor-mode 'mml-mode " MML" mml-mode-map)
+ :lighter " MML" :keymap mml-mode-map
+ (when mml-mode
(easy-menu-add mml-menu mml-mode-map)
(when (boundp 'dnd-protocol-alist)
(set (make-local-variable 'dnd-protocol-alist)
(easy-menu-add mml-menu mml-mode-map)
(when (boundp 'dnd-protocol-alist)
(set (make-local-variable 'dnd-protocol-alist)
- (append mml-dnd-protocol-alist dnd-protocol-alist)))
- (run-hooks 'mml-mode-hook)))
+ (append mml-dnd-protocol-alist dnd-protocol-alist)))))
;;;
;;; Helper functions for reading MIME stuff from the minibuffer and
;;;
;;; Helper functions for reading MIME stuff from the minibuffer and
@@
-1171,7
+1185,11
@@
If not set, `default-directory' will be used."
(error "Permission denied: %s" file))
file))
(error "Permission denied: %s" file))
file))
+(declare-function mailcap-parse-mimetypes "mailcap" (&optional path force))
+(declare-function mailcap-mime-types "mailcap" ())
+
(defun mml-minibuffer-read-type (name &optional default)
(defun mml-minibuffer-read-type (name &optional default)
+ (require 'mailcap)
(mailcap-parse-mimetypes)
(let* ((default (or default
(mm-default-file-encoding name)
(mailcap-parse-mimetypes)
(let* ((default (or default
(mm-default-file-encoding name)
@@
-1179,9
+1197,10
@@
If not set, `default-directory' will be used."
;; looks like, and offer text/plain if it looks
;; like text/plain.
"application/octet-stream"))
;; looks like, and offer text/plain if it looks
;; like text/plain.
"application/octet-stream"))
- (string (completing-read
- (format "Content type (default %s): " default)
- (mapcar 'list (mailcap-mime-types)))))
+ (string (gnus-completing-read
+ "Content type"
+ (mailcap-mime-types)
+ nil nil nil default)))
(if (not (equal string ""))
string
default)))
(if (not (equal string ""))
string
default)))
@@
-1195,10
+1214,10
@@
If not set, `default-directory' will be used."
(defun mml-minibuffer-read-disposition (type &optional default filename)
(unless default
(setq default (mml-content-disposition type filename)))
(defun mml-minibuffer-read-disposition (type &optional default filename)
(unless default
(setq default (mml-content-disposition type filename)))
- (let ((disposition (completing-read
- (format "Disposition (default %s): " default)
- '(
("attachment") ("inline") ("")
)
-
nil
t nil nil default)))
+ (let ((disposition (
gnus-
completing-read
+ "Disposition"
+ '(
"attachment" "inline"
)
+ t nil nil default)))
(if (not (equal disposition ""))
disposition
default)))
(if (not (equal disposition ""))
disposition
default)))
@@
-1292,15
+1311,24
@@
body) or \"attachment\" (separate from the body)."
(description (mml-minibuffer-read-description))
(disposition (mml-minibuffer-read-disposition type nil file)))
(list file type description disposition)))
(description (mml-minibuffer-read-description))
(disposition (mml-minibuffer-read-disposition type nil file)))
(list file type description disposition)))
- (save-excursion
- (unless (message-in-body-p) (goto-char (point-max)))
+ ;; Don't move point if this command is invoked inside the message header.
+ (let ((head (unless (message-in-body-p)
+ (prog1
+ (point)
+ (goto-char (point-max))))))
(mml-insert-empty-tag 'part
'type type
;; icicles redefines read-file-name and returns a
;; string w/ text properties :-/
'filename (mm-substring-no-properties file)
'disposition (or disposition "attachment")
(mml-insert-empty-tag 'part
'type type
;; icicles redefines read-file-name and returns a
;; string w/ text properties :-/
'filename (mm-substring-no-properties file)
'disposition (or disposition "attachment")
- 'description description)))
+ 'description description)
+ (when head
+ (unless (prog1
+ (pos-visible-in-window-p)
+ (goto-char head))
+ (message "The file \"%s\" has been attached at the end of the message"
+ (file-name-nondirectory file))))))
(defun mml-dnd-attach-file (uri action)
"Attach a drag and drop file.
(defun mml-dnd-attach-file (uri action)
"Attach a drag and drop file.
@@
-1336,11
+1364,21
@@
BUFFER is the name of the buffer to attach. See
(description (mml-minibuffer-read-description))
(disposition (mml-minibuffer-read-disposition type nil)))
(list buffer type description disposition)))
(description (mml-minibuffer-read-description))
(disposition (mml-minibuffer-read-disposition type nil)))
(list buffer type description disposition)))
- (save-excursion
- (unless (message-in-body-p) (goto-char (point-max)))
+ ;; Don't move point if this command is invoked inside the message header.
+ (let ((head (unless (message-in-body-p)
+ (prog1
+ (point)
+ (goto-char (point-max))))))
(mml-insert-empty-tag 'part 'type type 'buffer buffer
'disposition disposition
(mml-insert-empty-tag 'part 'type type 'buffer buffer
'disposition disposition
- 'description description)))
+ 'description description)
+ (when head
+ (unless (prog1
+ (pos-visible-in-window-p)
+ (goto-char head))
+ (message
+ "The buffer \"%s\" has been attached at the end of the message"
+ buffer)))))
(defun mml-attach-external (file &optional type description)
"Attach an external file into the buffer.
(defun mml-attach-external (file &optional type description)
"Attach an external file into the buffer.
@@
-1351,26
+1389,38
@@
TYPE is the MIME type to use."
(type (mml-minibuffer-read-type file))
(description (mml-minibuffer-read-description)))
(list file type description)))
(type (mml-minibuffer-read-type file))
(description (mml-minibuffer-read-description)))
(list file type description)))
- (save-excursion
- (unless (message-in-body-p) (goto-char (point-max)))
+ ;; Don't move point if this command is invoked inside the message header.
+ (let ((head (unless (message-in-body-p)
+ (prog1
+ (point)
+ (goto-char (point-max))))))
(mml-insert-empty-tag 'external 'type type 'name file
(mml-insert-empty-tag 'external 'type type 'name file
- 'disposition "attachment" 'description description)))
+ 'disposition "attachment" 'description description)
+ (when head
+ (unless (prog1
+ (pos-visible-in-window-p)
+ (goto-char head))
+ (message "The file \"%s\" has been attached at the end of the message"
+ (file-name-nondirectory file))))))
(defun mml-insert-multipart (&optional type)
(defun mml-insert-multipart (&optional type)
- (interactive (list (completing-read "Multipart type (default mixed): "
- '(("mixed") ("alternative") ("digest") ("parallel")
- ("signed") ("encrypted"))
- nil nil "mixed")))
+ (interactive (if (message-in-body-p)
+ (list (gnus-completing-read "Multipart type"
+ '("mixed" "alternative"
+ "digest" "parallel"
+ "signed" "encrypted")
+ nil "mixed"))
+ (error "Use this command in the message body")))
(or type
(setq type "mixed"))
(mml-insert-empty-tag "multipart" 'type type)
(forward-line -1))
(defun mml-insert-part (&optional type)
(or type
(setq type "mixed"))
(mml-insert-empty-tag "multipart" 'type type)
(forward-line -1))
(defun mml-insert-part (&optional type)
- (interactive
-
(list (mml-minibuffer-read-type "")
))
-
(mml-insert-tag 'part 'type type 'disposition "inline"
)
- (
forward-line -1
))
+ (interactive
(if (message-in-body-p)
+
(list (mml-minibuffer-read-type ""
))
+
(error "Use this command in the message body"))
)
+ (
mml-insert-tag 'part 'type type 'disposition "inline"
))
(declare-function message-subscribed-p "message" ())
(declare-function message-make-mail-followup-to "message"
(declare-function message-subscribed-p "message" ())
(declare-function message-make-mail-followup-to "message"
@@
-1412,8
+1462,10
@@
or the `pop-to-buffer' function."
(setq mml-preview-buffer (generate-new-buffer
(concat (if raw "*Raw MIME preview of "
"*MIME preview of ") (buffer-name))))
(setq mml-preview-buffer (generate-new-buffer
(concat (if raw "*Raw MIME preview of "
"*MIME preview of ") (buffer-name))))
+ (require 'gnus-msg) ; for gnus-setup-posting-charset
(save-excursion
(let* ((buf (current-buffer))
(save-excursion
(let* ((buf (current-buffer))
+ (article-editing (eq major-mode 'gnus-article-edit-mode))
(message-options message-options)
(message-this-is-mail (message-mail-p))
(message-this-is-news (message-news-p))
(message-options message-options)
(message-this-is-mail (message-mail-p))
(message-this-is-news (message-news-p))
@@
-1433,15
+1485,19
@@
or the `pop-to-buffer' function."
(mml-preview-insert-mail-followup-to)
(let ((message-deletable-headers (if (message-news-p)
nil
(mml-preview-insert-mail-followup-to)
(let ((message-deletable-headers (if (message-news-p)
nil
- message-deletable-headers)))
+ message-deletable-headers))
+ (mail-header-separator (if article-editing
+ ""
+ mail-header-separator)))
(message-generate-headers
(copy-sequence (if (message-news-p)
message-required-news-headers
(message-generate-headers
(copy-sequence (if (message-news-p)
message-required-news-headers
- message-required-mail-headers))))
- (if (re-search-forward
- (concat "^" (regexp-quote mail-header-separator) "\n") nil t)
- (replace-match "\n"))
- (let ((mail-header-separator ""));; mail-header-separator is removed.
+ message-required-mail-headers)))
+ (unless article-editing
+ (if (re-search-forward
+ (concat "^" (regexp-quote mail-header-separator) "\n") nil t)
+ (replace-match "\n"))
+ (setq mail-header-separator ""))
(message-sort-headers)
(mml-to-mime))
(if raw
(message-sort-headers)
(mml-to-mime))
(if raw
@@
-1452,7
+1508,8
@@
or the `pop-to-buffer' function."
(mm-disable-multibyte)
(insert s)))
(let ((gnus-newsgroup-charset (car message-posting-charset))
(mm-disable-multibyte)
(insert s)))
(let ((gnus-newsgroup-charset (car message-posting-charset))
- gnus-article-prepare-hook gnus-original-article-buffer)
+ gnus-article-prepare-hook gnus-original-article-buffer
+ gnus-displaying-mime)
(run-hooks 'gnus-article-decode-hook)
(let ((gnus-newsgroup-name "dummy")
(gnus-newsrc-hashtb (or gnus-newsrc-hashtb
(run-hooks 'gnus-article-decode-hook)
(let ((gnus-newsgroup-name "dummy")
(gnus-newsrc-hashtb (or gnus-newsrc-hashtb
@@
-1529,5
+1586,4
@@
or the `pop-to-buffer' function."
(provide 'mml)
(provide 'mml)
-;; arch-tag: 583c96cf-1ffe-451b-a5e5-4733ae9ddd12
;;; mml.el ends here
;;; mml.el ends here