X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fmml.el;h=6950d6c7ff32d2564effc01cd0e4869c3e343779;hb=1af25b1aeba0b49aa3978a7ac236f76cb41ad73e;hp=71abcda14327905d45a69e907e1cc1a59ab4b427;hpb=0f298699ae83e75ef0eaf269f1c4e53e6576cef7;p=elisp%2Fgnus.git- diff --git a/lisp/mml.el b/lisp/mml.el index 71abcda..6950d6c 100644 --- a/lisp/mml.el +++ b/lisp/mml.el @@ -1,5 +1,5 @@ ;;; mml.el --- A package for parsing and validating MML documents -;; Copyright (C) 1998, 1999, 2000, 2001 Free Software Foundation, Inc. +;; Copyright (C) 1998, 1999, 2000, 2001, 2002 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; This file is part of GNU Emacs. @@ -35,6 +35,7 @@ (autoload 'gnus-setup-posting-charset "gnus-msg") (autoload 'gnus-add-minor-mode "gnus-ems") (autoload 'message-fetch-field "message") + (autoload 'fill-flowed-encode "flow-fill") (autoload 'message-posting-charset "message")) (defcustom mml-content-type-parameters @@ -64,6 +65,16 @@ NAME is a string containing the name of the TWEAK parameter in the MML handle. FUNCTION is a Lisp function which is called with the MML handle to tweak the part.") +(defvar mml-tweak-sexp-alist + '((mml-externalize-attachments . mml-tweak-externalize-attachments)) + "A list of (SEXP . FUNCTION) for tweaking MML parts. +SEXP is a s-expression. If the evaluation of SEXP is non-nil, FUNCTION +is called. FUNCTION is a Lisp function which is called with the MML +handle to tweak the part.") + +(defvar mml-externalize-attachments nil + "*If non-nil, local-file attachments are generated as external parts.") + (defvar mml-generate-multipart-alist nil "*Alist of multipart generation functions. Each entry has the form (NAME . FUNCTION), where @@ -132,6 +143,40 @@ one charsets.") (while (and (not (eobp)) (not (looking-at "<#/multipart"))) (cond + ((looking-at "<#secure") + ;; The secure part is essentially a meta-meta tag, which + ;; expands to either a part tag if there are no other parts in + ;; the document or a multipart tag if there are other parts + ;; included in the message + (let* (secure-mode + (taginfo (mml-read-tag)) + (recipients (cdr (assq 'recipients taginfo))) + (location (cdr (assq 'tag-location taginfo))) + (mode (cdr (assq 'mode taginfo))) + (method (cdr (assq 'method taginfo))) + tags) + (save-excursion + (if + (re-search-forward + "<#\\(/\\)?\\(multipart\\|part\\|external\\|mml\\)." nil t) + (setq secure-mode "multipart") + (setq secure-mode "part"))) + (save-excursion + (goto-char location) + (re-search-forward "<#secure[^\n]*>\n")) + (delete-region (match-beginning 0) (match-end 0)) + (cond ((string= mode "sign") + (setq tags (list "sign" method))) + ((string= mode "encrypt") + (setq tags (list "encrypt" method))) + ((string= mode "signencrypt") + (setq tags (list "sign" method "encrypt" method)))) + (eval `(mml-insert-tag ,secure-mode + ,@tags + ,(if recipients 'recipients) + ,recipients)) + ;; restart the parse + (goto-char location))) ((looking-at "<#multipart") (push (nconc (mml-read-tag) (mml-parse-1)) struct)) ((looking-at "<#external") @@ -154,7 +199,7 @@ one charsets.") (list (intern (downcase (cdr (assq 'charset tag)))))) (t - (mm-find-mime-charset-region point (point) + (mm-find-mime-charset-region point (point) mm-hack-charsets)))) (when (and (not raw) (memq nil charsets)) (if (or (memq 'unknown-encoding mml-confirmation-set) @@ -276,6 +321,15 @@ A message part needs to be split into %d charset parts. Really send? " (setq contents (append (list (cons 'tag-location orig-point)) contents)) (cons (intern name) (nreverse contents)))) +(defun mml-buffer-substring-no-properties-except-hard-newlines (start end) + (let ((str (buffer-substring-no-properties start end)) + (bufstart start) tmp) + (while (setq tmp (text-property-any start end 'hard 't)) + (set-text-properties (- tmp bufstart) (- tmp bufstart -1) + '(hard t) str) + (setq start (1+ tmp))) + str)) + (defun mml-read-part (&optional mml) "Return the buffer up till the next part, multipart or closing part or multipart. If MML is non-nil, return the buffer up till the correspondent mml tag." @@ -289,19 +343,22 @@ If MML is non-nil, return the buffer up till the correspondent mml tag." (if (re-search-forward "<#\\(/\\)?mml." nil t) (setq count (+ count (if (match-beginning 1) -1 1))) (goto-char (point-max)))) - (buffer-substring-no-properties beg (if (> count 0) - (point) - (match-beginning 0)))) + (mml-buffer-substring-no-properties-except-hard-newlines + beg (if (> count 0) + (point) + (match-beginning 0)))) (if (re-search-forward "<#\\(/\\)?\\(multipart\\|part\\|external\\|mml\\)." nil t) (prog1 - (buffer-substring-no-properties beg (match-beginning 0)) + (mml-buffer-substring-no-properties-except-hard-newlines + beg (match-beginning 0)) (if (or (not (match-beginning 1)) (equal (match-string 2) "multipart")) (goto-char (match-beginning 0)) (when (looking-at "[ \t]*\n") (forward-line 1)))) - (buffer-substring-no-properties beg (goto-char (point-max))))))) + (mml-buffer-substring-no-properties-except-hard-newlines + beg (goto-char (point-max))))))) (defvar mml-boundary nil) (defvar mml-base-boundary "-=-=") @@ -330,7 +387,7 @@ If MML is non-nil, return the buffer up till the correspondent mml tag." (cond ((or (eq (car cont) 'part) (eq (car cont) 'mml)) (let ((raw (cdr (assq 'raw cont))) - coded encoding charset filename type) + coded encoding charset filename type flowed) (setq type (or (cdr (assq 'type cont)) "text/plain")) (if (and (not raw) (member (car (split-string type "/")) '("text" "message"))) @@ -377,8 +434,25 @@ If MML is non-nil, return the buffer up till the correspondent mml tag." (setq charset (mm-encode-body charset)) (setq encoding (mm-body-encoding charset (cdr (assq 'encoding cont)))))) + ;; Only perform format=flowed filling on text/plain + ;; parts where there either isn't a format parameter + ;; 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") + (or (null (assq 'format cont)) + (string= (cdr (assq 'format cont)) + "flowed")) + (setq use-hard-newlines + (text-property-any + (point-min) (point-max) 'hard 't))) + (fill-flowed-encode) + ;; Indicate that `mml-insert-mime-headers' should + ;; insert a "; format=flowed" string unless the + ;; user has already specified it. + (setq flowed (null (assq 'format cont))))) (setq coded (buffer-string))) - (mml-insert-mime-headers cont type charset encoding) + (mml-insert-mime-headers cont type charset encoding flowed) (insert "\n") (insert coded)) (mm-with-unibyte-buffer @@ -393,7 +467,7 @@ If MML is non-nil, return the buffer up till the correspondent mml tag." (insert (cdr (assq 'contents cont))))) (setq encoding (mm-encode-buffer type) coded (mm-string-as-multibyte (buffer-string)))) - (mml-insert-mime-headers cont type charset encoding) + (mml-insert-mime-headers cont type charset encoding nil) (insert "\n") (mm-with-unibyte-current-buffer (insert coded))))) @@ -456,22 +530,29 @@ If MML is non-nil, return the buffer up till the correspondent mml tag." (insert "\n--" mml-boundary "--\n"))))) (t (error "Invalid element: %S" cont))) - (let ((item (assoc (cdr (assq 'sign cont)) mml-sign-alist)) + ;; handle sign & encrypt tags in a semi-smart way. + (let ((sign-item (assoc (cdr (assq 'sign cont)) mml-sign-alist)) + (encrypt-item (assoc (cdr (assq 'encrypt cont)) + mml-encrypt-alist)) sender recipients) - (when item + (when (or sign-item encrypt-item) (if (setq sender (cdr (assq 'sender cont))) (message-options-set 'message-sender sender)) (if (setq recipients (cdr (assq 'recipients cont))) - (message-options-set 'message-sender recipients)) - (funcall (nth 1 item) cont))) - (let ((item (assoc (cdr (assq 'encrypt cont)) mml-encrypt-alist)) - sender recipients) - (when item - (if (setq sender (cdr (assq 'sender cont))) - (message-options-set 'message-sender sender)) - (if (setq recipients (cdr (assq 'recipients cont))) - (message-options-set 'message-sender recipients)) - (funcall (nth 1 item) cont)))))) + (message-options-set 'message-recipients recipients)) + (let ((style (mml-signencrypt-style (first (or sign-item encrypt-item))))) + ;; check if: we're both signing & encrypting, both methods + ;; are the same (why would they be different?!), and that + ;; the signencrypt style allows for combined operation. + (if (and sign-item encrypt-item (equal (first sign-item) + (first encrypt-item)) + (equal style 'combined)) + (funcall (nth 1 encrypt-item) cont t) + ;; otherwise, revert to the old behavior. + (when sign-item + (funcall (nth 1 sign-item) cont)) + (when encrypt-item + (funcall (nth 1 encrypt-item) cont))))))))) (defun mml-compute-boundary (cont) "Return a unique boundary that does not exist in CONT." @@ -513,13 +594,14 @@ If MML is non-nil, return the buffer up till the correspondent mml tag." "") mml-base-boundary)) -(defun mml-insert-mime-headers (cont type charset encoding) +(defun mml-insert-mime-headers (cont type charset encoding flowed) (let (parameters disposition description) (setq parameters (mml-parameter-string cont mml-content-type-parameters)) (when (or charset parameters + flowed (not (equal type mml-generate-default-type))) (when (consp charset) (error @@ -528,6 +610,8 @@ If MML is non-nil, return the buffer up till the correspondent mml tag." (when charset (insert "; " (mail-header-encode-parameter "charset" (symbol-name charset)))) + (when flowed + (insert "; format=flowed")) (when parameters (mml-insert-parameter-string cont mml-content-type-parameters)) @@ -618,6 +702,7 @@ If HANDLES is non-nil, use it instead reparsing the buffer." ;; Remove them, they are confusing. (message-remove-header "Content-Type") (message-remove-header "MIME-Version") + (message-remove-header "Content-Disposition") (message-remove-header "Content-Transfer-Encoding"))) (defun mml-to-mime () @@ -625,6 +710,9 @@ If HANDLES is non-nil, use it instead reparsing the buffer." (message-encode-message-body) (save-restriction (message-narrow-to-headers-or-head) + ;; Skip past any From_ headers. + (while (looking-at "From ") + (forward-line 1)) (let ((mail-parse-charset message-default-charset)) (mail-encode-encoded-word-buffer)))) @@ -704,10 +792,13 @@ If HANDLES is non-nil, use it instead reparsing the buffer." (encrypt (make-sparse-keymap)) (map (make-sparse-keymap)) (main (make-sparse-keymap))) - (define-key sign "p" 'mml-secure-sign-pgpmime) - (define-key sign "s" 'mml-secure-sign-smime) - (define-key encrypt "p" 'mml-secure-encrypt-pgpmime) - (define-key encrypt "s" 'mml-secure-encrypt-smime) + (define-key sign "p" 'mml-secure-message-sign-pgpmime) + (define-key sign "o" 'mml-secure-message-sign-pgp) + (define-key sign "s" 'mml-secure-message-sign-smime) + (define-key encrypt "p" 'mml-secure-message-encrypt-pgpmime) + (define-key encrypt "o" 'mml-secure-message-encrypt-pgp) + (define-key encrypt "s" 'mml-secure-message-encrypt-smime) + (define-key map "\C-n" 'mml-unsecure-message) (define-key map "f" 'mml-attach-file) (define-key map "b" 'mml-attach-buffer) (define-key map "e" 'mml-attach-external) @@ -726,16 +817,21 @@ If HANDLES is non-nil, use it instead reparsing the buffer." (easy-menu-define mml-menu mml-mode-map "" - '("Attachments" - ["Attach File" mml-attach-file t] + `("Attachments" + ["Attach File" mml-attach-file + ,@(if (featurep 'xemacs) '(t) + '(:help "Attach a file at point"))] ["Attach Buffer" mml-attach-buffer t] ["Attach External" mml-attach-external t] ["Insert Part" mml-insert-part t] ["Insert Multipart" mml-insert-multipart t] - ["PGP/MIME Sign" mml-secure-sign-pgpmime t] - ["PGP/MIME Encrypt" mml-secure-encrypt-pgpmime t] - ["S/MIME Sign" mml-secure-sign-smime t] - ["S/MIME Encrypt" mml-secure-encrypt-smime t] + ["PGP/MIME Sign" mml-secure-message-sign-pgpmime t] + ["PGP/MIME Encrypt" mml-secure-message-encrypt-pgpmime t] + ["PGP Sign" mml-secure-message-sign-pgp t] + ["PGP Encrypt" mml-secure-message-encrypt-pgp t] + ["S/MIME Sign" mml-secure-message-sign-smime t] + ["S/MIME Encrypt" mml-secure-message-encrypt-smime t] + ["Encrypt/Sign off" mml-unsecure-message t] ;;["Narrow" mml-narrow-to-part t] ["Quote MML" mml-quote-region t] ["Validate MML" mml-validate t] @@ -895,41 +991,52 @@ TYPE is the MIME type to use." "Display current buffer with Gnus, in a new buffer. If RAW, don't highlight the article." (interactive "P") - (let* ((buf (current-buffer)) - (message-options message-options) - (message-this-is-news (message-news-p)) - (message-posting-charset (or (gnus-setup-posting-charset - (save-restriction - (message-narrow-to-headers-or-head) - (message-fetch-field "Newsgroups"))) - message-posting-charset))) - (message-options-set-recipient) - (switch-to-buffer (generate-new-buffer - (concat (if raw "*Raw MIME preview of " - "*MIME preview of ") (buffer-name)))) - (erase-buffer) - (insert-buffer buf) - (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. - (mml-to-mime)) - (if raw - (when (fboundp 'set-buffer-multibyte) - (let ((s (buffer-string))) - ;; Insert the content into unibyte buffer. - (erase-buffer) - (mm-disable-multibyte) - (insert s))) - (let ((gnus-newsgroup-charset (car message-posting-charset))) - (run-hooks 'gnus-article-decode-hook) - (let ((gnus-newsgroup-name "dummy")) - (gnus-article-prepare-display)))) - ;; Disable article-mode-map. - (use-local-map nil) - (setq buffer-read-only t) - (local-set-key "q" (lambda () (interactive) (kill-buffer nil))) - (goto-char (point-min)))) + (save-excursion + (let* ((buf (current-buffer)) + (message-options message-options) + (message-this-is-news (message-news-p)) + (message-posting-charset (or (gnus-setup-posting-charset + (save-restriction + (message-narrow-to-headers-or-head) + (message-fetch-field "Newsgroups"))) + message-posting-charset))) + (message-options-set-recipient) + (switch-to-buffer (generate-new-buffer + (concat (if raw "*Raw MIME preview of " + "*MIME preview of ") (buffer-name)))) + (erase-buffer) + (insert-buffer buf) + (let ((message-deletable-headers (if (message-news-p) + nil + message-deletable-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. + (mml-to-mime)) + (if raw + (when (fboundp 'set-buffer-multibyte) + (let ((s (buffer-string))) + ;; Insert the content into unibyte buffer. + (erase-buffer) + (mm-disable-multibyte) + (insert s))) + (let ((gnus-newsgroup-charset (car message-posting-charset)) + gnus-article-prepare-hook gnus-original-article-buffer) + (run-hooks 'gnus-article-decode-hook) + (let ((gnus-newsgroup-name "dummy") + (gnus-newsrc-hashtb (or gnus-newsrc-hashtb + (gnus-make-hashtable 5)))) + (gnus-article-prepare-display)))) + ;; Disable article-mode-map. + (use-local-map nil) + (setq buffer-read-only t) + (local-set-key "q" (lambda () (interactive) (kill-buffer nil))) + (goto-char (point-min))))) (defun mml-validate () "Validate the current MML document." @@ -955,7 +1062,23 @@ If RAW, don't highlight the article." (setq alist (cdr alist))))))) (if func (funcall func cont) - cont))) + cont) + (let ((alist mml-tweak-sexp-alist)) + (while alist + (if (eval (caar alist)) + (funcall (cdar alist) cont)) + (setq alist (cdr alist))))) + cont) + +(defun mml-tweak-externalize-attachments (cont) + "Tweak attached files as external parts." + (let (filename-cons) + (when (and (eq (car cont) 'part) + (not (cdr (assq 'buffer cont))) + (and (setq filename-cons (assq 'filename cont)) + (not (equal (cdr (assq 'nofile cont)) "yes")))) + (setcar cont 'external) + (setcar filename-cons 'name)))) (provide 'mml)