1;;; mml.el --- A package for parsing and validating MML documents 2 3;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 4;; 2005, 2006, 2007 Free Software Foundation, Inc. 5 6;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> 7;; This file is part of GNU Emacs. 8 9;; GNU Emacs is free software; you can redistribute it and/or modify 10;; it under the terms of the GNU General Public License as published by 11;; the Free Software Foundation; either version 2, or (at your option) 12;; any later version. 13 14;; GNU Emacs is distributed in the hope that it will be useful, 15;; but WITHOUT ANY WARRANTY; without even the implied warranty of 16;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 17;; GNU General Public License for more details. 18 19;; You should have received a copy of the GNU General Public License 20;; along with GNU Emacs; see the file COPYING. If not, write to the 21;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 22;; Boston, MA 02110-1301, USA. 23 24;;; Commentary: 25 26;;; Code: 27 28(require 'mm-util) 29(require 'mm-bodies) 30(require 'mm-encode) 31(require 'mm-decode) 32(require 'mml-sec) 33(eval-when-compile (require 'cl)) 34 35(eval-and-compile 36 (autoload 'message-make-message-id "message") 37 (autoload 'gnus-setup-posting-charset "gnus-msg") 38 (autoload 'gnus-add-minor-mode "gnus-ems") 39 (autoload 'gnus-make-local-hook "gnus-util") 40 (autoload 'message-fetch-field "message") 41 (autoload 'message-info "message") 42 (autoload 'fill-flowed-encode "flow-fill") 43 (autoload 'message-posting-charset "message") 44 (autoload 'dnd-get-local-file-name "dnd")) 45 46(defvar gnus-article-mime-handles) 47(defvar gnus-mouse-2) 48(defvar gnus-newsrc-hashtb) 49(defvar message-default-charset) 50(defvar message-deletable-headers) 51(defvar message-options) 52(defvar message-posting-charset) 53(defvar message-required-mail-headers) 54(defvar message-required-news-headers) 55(defvar dnd-protocol-alist) 56 57(defcustom mml-content-type-parameters 58 '(name access-type expiration size permission format) 59 "*A list of acceptable parameters in MML tag. 60These parameters are generated in Content-Type header if exists." 61 :version "22.1" 62 :type '(repeat (symbol :tag "Parameter")) 63 :group 'message) 64 65(defcustom mml-content-disposition-parameters 66 '(filename creation-date modification-date read-date) 67 "*A list of acceptable parameters in MML tag. 68These parameters are generated in Content-Disposition header if exists." 69 :version "22.1" 70 :type '(repeat (symbol :tag "Parameter")) 71 :group 'message) 72 73(defcustom mml-insert-mime-headers-always nil 74 "If non-nil, always put Content-Type: text/plain at top of empty parts. 75It is necessary to work against a bug in certain clients." 76 :version "22.1" 77 :type 'boolean 78 :group 'message) 79 80(defvar mml-tweak-type-alist nil 81 "A list of (TYPE . FUNCTION) for tweaking MML parts. 82TYPE is a string containing a regexp to match the MIME type. FUNCTION 83is a Lisp function which is called with the MML handle to tweak the 84part. This variable is used only when no TWEAK parameter exists in 85the MML handle.") 86 87(defvar mml-tweak-function-alist nil 88 "A list of (NAME . FUNCTION) for tweaking MML parts. 89NAME is a string containing the name of the TWEAK parameter in the MML 90handle. FUNCTION is a Lisp function which is called with the MML 91handle to tweak the part.") 92 93(defvar mml-tweak-sexp-alist 94 '((mml-externalize-attachments . mml-tweak-externalize-attachments)) 95 "A list of (SEXP . FUNCTION) for tweaking MML parts. 96SEXP is an s-expression. If the evaluation of SEXP is non-nil, FUNCTION 97is called. FUNCTION is a Lisp function which is called with the MML 98handle to tweak the part.") 99 100(defvar mml-externalize-attachments nil 101 "*If non-nil, local-file attachments are generated as external parts.") 102 103(defvar mml-generate-multipart-alist nil 104 "*Alist of multipart generation functions. 105Each entry has the form (NAME . FUNCTION), where 106NAME is a string containing the name of the part (without the 107leading \"/multipart/\"), 108FUNCTION is a Lisp function which is called to generate the part. 109 110The Lisp function has to supply the appropriate MIME headers and the 111contents of this part.") 112 113(defvar mml-syntax-table 114 (let ((table (copy-syntax-table emacs-lisp-mode-syntax-table))) 115 (modify-syntax-entry ?\\ "/" table) 116 (modify-syntax-entry ?< "(" table) 117 (modify-syntax-entry ?> ")" table) 118 (modify-syntax-entry ?@ "w" table) 119 (modify-syntax-entry ?/ "w" table) 120 (modify-syntax-entry ?= " " table) 121 (modify-syntax-entry ?* " " table) 122 (modify-syntax-entry ?\; " " table) 123 (modify-syntax-entry ?\' " " table) 124 table)) 125 126(defvar mml-boundary-function 'mml-make-boundary 127 "A function called to suggest a boundary. 128The function may be called several times, and should try to make a new 129suggestion each time. The function is called with one parameter, 130which is a number that says how many times the function has been 131called for this message.") 132 133(defvar mml-confirmation-set nil 134 "A list of symbols, each of which disables some warning. 135`unknown-encoding': always send messages contain characters with 136unknown encoding; `use-ascii': always use ASCII for those characters 137with unknown encoding; `multipart': always send messages with more than 138one charsets.") 139 140(defvar mml-generate-default-type "text/plain" 141 "Content type by which the Content-Type header can be omitted. 142The Content-Type header will not be put in the MIME part if the type 143equals the value and there's no parameter (e.g. charset, format, etc.) 144and `mml-insert-mime-headers-always' is nil. The value will be bound 145to \"message/rfc822\" when encoding an article to be forwarded as a MIME 146part. This is for the internal use, you should never modify the value.") 147 148(defvar mml-buffer-list nil) 149 150(defun mml-generate-new-buffer (name) 151 (let ((buf (generate-new-buffer name))) 152 (push buf mml-buffer-list) 153 buf)) 154 155(defun mml-destroy-buffers () 156 (let (kill-buffer-hook) 157 (mapcar 'kill-buffer mml-buffer-list) 158 (setq mml-buffer-list nil))) 159 160(defun mml-parse () 161 "Parse the current buffer as an MML document." 162 (save-excursion 163 (goto-char (point-min)) 164 (let ((table (syntax-table))) 165 (unwind-protect 166 (progn 167 (set-syntax-table mml-syntax-table) 168 (mml-parse-1)) 169 (set-syntax-table table))))) 170 171(defun mml-parse-1 () 172 "Parse the current buffer as an MML document." 173 (let (struct tag point contents charsets warn use-ascii no-markup-p raw) 174 (while (and (not (eobp)) 175 (not (looking-at "<#/multipart"))) 176 (cond 177 ((looking-at "<#secure") 178 ;; The secure part is essentially a meta-meta tag, which 179 ;; expands to either a part tag if there are no other parts in 180 ;; the document or a multipart tag if there are other parts 181 ;; included in the message 182 (let* (secure-mode 183 (taginfo (mml-read-tag)) 184 (recipients (cdr (assq 'recipients taginfo))) 185 (sender (cdr (assq 'sender taginfo))) 186 (location (cdr (assq 'tag-location taginfo))) 187 (mode (cdr (assq 'mode taginfo))) 188 (method (cdr (assq 'method taginfo))) 189 tags) 190 (save-excursion 191 (if 192 (re-search-forward 193 "<#\\(/\\)?\\(multipart\\|part\\|external\\|mml\\)." nil t) 194 (setq secure-mode "multipart") 195 (setq secure-mode "part"))) 196 (save-excursion 197 (goto-char location) 198 (re-search-forward "<#secure[^\n]*>\n")) 199 (delete-region (match-beginning 0) (match-end 0)) 200 (cond ((string= mode "sign") 201 (setq tags (list "sign" method))) 202 ((string= mode "encrypt") 203 (setq tags (list "encrypt" method))) 204 ((string= mode "signencrypt") 205 (setq tags (list "sign" method "encrypt" method)))) 206 (eval `(mml-insert-tag ,secure-mode 207 ,@tags 208 ,(if recipients "recipients") 209 ,recipients 210 ,(if sender "sender") 211 ,sender)) 212 ;; restart the parse 213 (goto-char location))) 214 ((looking-at "<#multipart") 215 (push (nconc (mml-read-tag) (mml-parse-1)) struct)) 216 ((looking-at "<#external") 217 (push (nconc (mml-read-tag) (list (cons 'contents (mml-read-part)))) 218 struct)) 219 (t 220 (if (or (looking-at "<#part") (looking-at "<#mml")) 221 (setq tag (mml-read-tag) 222 no-markup-p nil 223 warn nil) 224 (setq tag (list 'part '(type . "text/plain")) 225 no-markup-p t 226 warn t)) 227 (setq raw (cdr (assq 'raw tag)) 228 point (point) 229 contents (mml-read-part (eq 'mml (car tag))) 230 charsets (cond 231 (raw nil) 232 ((assq 'charset tag) 233 (list 234 (intern (downcase (cdr (assq 'charset tag)))))) 235 (t 236 (mm-find-mime-charset-region point (point) 237 mm-hack-charsets)))) 238 (when (and (not raw) (memq nil charsets)) 239 (if (or (memq 'unknown-encoding mml-confirmation-set) 240 (message-options-get 'unknown-encoding) 241 (and (y-or-n-p "\ 242Message contains characters with unknown encoding. Really send? ") 243 (message-options-set 'unknown-encoding t))) 244 (if (setq use-ascii 245 (or (memq 'use-ascii mml-confirmation-set) 246 (message-options-get 'use-ascii) 247 (and (y-or-n-p "Use ASCII as charset? ") 248 (message-options-set 'use-ascii t)))) 249 (setq charsets (delq nil charsets)) 250 (setq warn nil)) 251 (error "Edit your message to remove those characters"))) 252 (if (or raw 253 (eq 'mml (car tag)) 254 (< (length charsets) 2)) 255 (if (or (not no-markup-p) 256 (string-match "[^ \t\r\n]" contents)) 257 ;; Don't create blank parts. 258 (push (nconc tag (list (cons 'contents contents))) 259 struct)) 260 (let ((nstruct (mml-parse-singlepart-with-multiple-charsets 261 tag point (point) use-ascii))) 262 (when (and warn 263 (not (memq 'multipart mml-confirmation-set)) 264 (not (message-options-get 'multipart)) 265 (not (and (y-or-n-p (format "\ 266A message part needs to be split into %d charset parts. Really send? " 267 (length nstruct))) 268 (message-options-set 'multipart t)))) 269 (error "Edit your message to use only one charset")) 270 (setq struct (nconc nstruct struct))))))) 271 (unless (eobp) 272 (forward-line 1)) 273 (nreverse struct))) 274 275(defun mml-parse-singlepart-with-multiple-charsets 276 (orig-tag beg end &optional use-ascii) 277 (save-excursion 278 (save-restriction 279 (narrow-to-region beg end) 280 (goto-char (point-min)) 281 (let ((current (or (mm-mime-charset (mm-charset-after)) 282 (and use-ascii 'us-ascii))) 283 charset struct space newline paragraph) 284 (while (not (eobp)) 285 (setq charset (mm-mime-charset (mm-charset-after))) 286 (cond 287 ;; The charset remains the same. 288 ((eq charset 'us-ascii)) 289 ((or (and use-ascii (not charset)) 290 (eq charset current)) 291 (setq space nil 292 newline nil 293 paragraph nil)) 294 ;; The initial charset was ascii. 295 ((eq current 'us-ascii) 296 (setq current charset 297 space nil 298 newline nil 299 paragraph nil)) 300 ;; We have a change in charsets. 301 (t 302 (push (append 303 orig-tag 304 (list (cons 'contents 305 (buffer-substring-no-properties 306 beg (or paragraph newline space (point)))))) 307 struct) 308 (setq beg (or paragraph newline space (point)) 309 current charset 310 space nil 311 newline nil 312 paragraph nil))) 313 ;; Compute places where it might be nice to break the part. 314 (cond 315 ((memq (following-char) '(? ?\t)) 316 (setq space (1+ (point)))) 317 ((and (eq (following-char) ?\n) 318 (not (bobp)) 319 (eq (char-after (1- (point))) ?\n)) 320 (setq paragraph (point))) 321 ((eq (following-char) ?\n) 322 (setq newline (1+ (point))))) 323 (forward-char 1)) 324 ;; Do the final part. 325 (unless (= beg (point)) 326 (push (append orig-tag 327 (list (cons 'contents 328 (buffer-substring-no-properties 329 beg (point))))) 330 struct)) 331 struct)))) 332 333(defun mml-read-tag () 334 "Read a tag and return the contents." 335 (let ((orig-point (point)) 336 contents name elem val) 337 (forward-char 2) 338 (setq name (buffer-substring-no-properties 339 (point) (progn (forward-sexp 1) (point)))) 340 (skip-chars-forward " \t\n") 341 (while (not (looking-at ">[ \t]*\n?")) 342 (setq elem (buffer-substring-no-properties 343 (point) (progn (forward-sexp 1) (point)))) 344 (skip-chars-forward "= \t\n") 345 (setq val (buffer-substring-no-properties 346 (point) (progn (forward-sexp 1) (point)))) 347 (when (string-match "^\"\\(.*\\)\"$" val) 348 (setq val (match-string 1 val))) 349 (push (cons (intern elem) val) contents) 350 (skip-chars-forward " \t\n")) 351 (goto-char (match-end 0)) 352 ;; Don't skip the leading space. 353 ;;(skip-chars-forward " \t\n") 354 ;; Put the tag location into the returned contents 355 (setq contents (append (list (cons 'tag-location orig-point)) contents)) 356 (cons (intern name) (nreverse contents)))) 357 358(defun mml-buffer-substring-no-properties-except-hard-newlines (start end) 359 (let ((str (buffer-substring-no-properties start end)) 360 (bufstart start) tmp) 361 (while (setq tmp (text-property-any start end 'hard 't)) 362 (set-text-properties (- tmp bufstart) (- tmp bufstart -1) 363 '(hard t) str) 364 (setq start (1+ tmp))) 365 str)) 366 367(defun mml-read-part (&optional mml) 368 "Return the buffer up till the next part, multipart or closing part or multipart. 369If MML is non-nil, return the buffer up till the correspondent mml tag." 370 (let ((beg (point)) (count 1)) 371 ;; If the tag ended at the end of the line, we go to the next line. 372 (when (looking-at "[ \t]*\n") 373 (forward-line 1)) 374 (if mml 375 (progn 376 (while (and (> count 0) (not (eobp))) 377 (if (re-search-forward "<#\\(/\\)?mml." nil t) 378 (setq count (+ count (if (match-beginning 1) -1 1))) 379 (goto-char (point-max)))) 380 (mml-buffer-substring-no-properties-except-hard-newlines 381 beg (if (> count 0) 382 (point) 383 (match-beginning 0)))) 384 (if (re-search-forward 385 "<#\\(/\\)?\\(multipart\\|part\\|external\\|mml\\)." nil t) 386 (prog1 387 (mml-buffer-substring-no-properties-except-hard-newlines 388 beg (match-beginning 0)) 389 (if (or (not (match-beginning 1)) 390 (equal (match-string 2) "multipart")) 391 (goto-char (match-beginning 0)) 392 (when (looking-at "[ \t]*\n") 393 (forward-line 1)))) 394 (mml-buffer-substring-no-properties-except-hard-newlines 395 beg (goto-char (point-max))))))) 396 397(defvar mml-boundary nil) 398(defvar mml-base-boundary "-=-=") 399(defvar mml-multipart-number 0) 400 401(defun mml-generate-mime () 402 "Generate a MIME message based on the current MML document." 403 (let ((cont (mml-parse)) 404 (mml-multipart-number mml-multipart-number)) 405 (if (not cont) 406 nil 407 (with-temp-buffer 408 (if (and (consp (car cont)) 409 (= (length cont) 1)) 410 (mml-generate-mime-1 (car cont)) 411 (mml-generate-mime-1 (nconc (list 'multipart '(type . "mixed")) 412 cont))) 413 (buffer-string))))) 414 415(defun mml-generate-mime-1 (cont) 416 (let ((mm-use-ultra-safe-encoding 417 (or mm-use-ultra-safe-encoding (assq 'sign cont)))) 418 (save-restriction 419 (narrow-to-region (point) (point)) 420 (mml-tweak-part cont) 421 (cond 422 ((or (eq (car cont) 'part) (eq (car cont) 'mml)) 423 (let* ((raw (cdr (assq 'raw cont))) 424 (filename (cdr (assq 'filename cont))) 425 (type (or (cdr (assq 'type cont)) 426 (if filename 427 (or (mm-default-file-encoding filename) 428 "application/octet-stream") 429 "text/plain"))) 430 coded encoding charset flowed) 431 (if (and (not raw) 432 (member (car (split-string type "/")) '("text" "message"))) 433 (progn 434 (with-temp-buffer 435 (setq charset (mm-charset-to-coding-system 436 (cdr (assq 'charset cont)))) 437 (when (eq charset 'ascii) 438 (setq charset nil)) 439 (cond 440 ((cdr (assq 'buffer cont)) 441 (insert-buffer-substring (cdr (assq 'buffer cont)))) 442 ((and filename 443 (not (equal (cdr (assq 'nofile cont)) "yes"))) 444 (let ((coding-system-for-read charset)) 445 (mm-insert-file-contents filename))) 446 ((eq 'mml (car cont)) 447 (insert (cdr (assq 'contents cont)))) 448 (t 449 (save-restriction 450 (narrow-to-region (point) (point)) 451 (insert (cdr (assq 'contents cont))) 452 ;; Remove quotes from quoted tags. 453 (goto-char (point-min)) 454 (while (re-search-forward 455 "<#!+/?\\(part\\|multipart\\|external\\|mml\\)" 456 nil t) 457 (delete-region (+ (match-beginning 0) 2) 458 (+ (match-beginning 0) 3)))))) 459 (cond 460 ((eq (car cont) 'mml) 461 (let ((mml-boundary (mml-compute-boundary cont)) 462 ;; It is necessary for the case where this 463 ;; function is called recursively since 464 ;; `m-g-d-t' will be bound to "message/rfc822" 465 ;; when encoding an article to be forwarded. 466 (mml-generate-default-type "text/plain")) 467 (mml-to-mime)) 468 (let ((mm-7bit-chars (concat mm-7bit-chars "\x1b"))) 469 ;; ignore 0x1b, it is part of iso-2022-jp 470 (setq encoding (mm-body-7-or-8)))) 471 ((string= (car (split-string type "/")) "message") 472 (let ((mm-7bit-chars (concat mm-7bit-chars "\x1b"))) 473 ;; ignore 0x1b, it is part of iso-2022-jp 474 (setq encoding (mm-body-7-or-8)))) 475 (t 476 ;; Only perform format=flowed filling on text/plain 477 ;; parts where there either isn't a format parameter 478 ;; in the mml tag or it says "flowed" and there 479 ;; actually are hard newlines in the text. 480 (let (use-hard-newlines) 481 (when (and (string= type "text/plain") 482 (not (string= (cdr (assq 'sign cont)) "pgp")) 483 (or (null (assq 'format cont)) 484 (string= (cdr (assq 'format cont)) 485 "flowed")) 486 (setq use-hard-newlines 487 (text-property-any 488 (point-min) (point-max) 'hard 't))) 489 (fill-flowed-encode) 490 ;; Indicate that `mml-insert-mime-headers' should 491 ;; insert a "; format=flowed" string unless the 492 ;; user has already specified it. 493 (setq flowed (null (assq 'format cont))))) 494 (setq charset (mm-encode-body charset)) 495 (setq encoding (mm-body-encoding 496 charset (cdr (assq 'encoding cont)))))) 497 (setq coded (buffer-string))) 498 (mml-insert-mime-headers cont type charset encoding flowed) 499 (insert "\n") 500 (insert coded)) 501 (mm-with-unibyte-buffer 502 (cond 503 ((cdr (assq 'buffer cont)) 504 (insert (mm-string-as-unibyte 505 (with-current-buffer (cdr (assq 'buffer cont)) 506 (buffer-string))))) 507 ((and filename 508 (not (equal (cdr (assq 'nofile cont)) "yes"))) 509 (let ((coding-system-for-read mm-binary-coding-system)) 510 (mm-insert-file-contents filename nil nil nil nil t))) 511 (t 512 (let ((contents (cdr (assq 'contents cont)))) 513 (if (if (featurep 'xemacs) 514 (string-match "[^\000-\377]" contents) 515 (mm-multibyte-string-p contents)) 516 (progn 517 (mm-enable-multibyte) 518 (insert contents) 519 (setq charset (mm-encode-body))) 520 (insert contents))))) 521 (setq encoding (mm-encode-buffer type) 522 coded (mm-string-as-multibyte (buffer-string)))) 523 (mml-insert-mime-headers cont type charset encoding nil) 524 (insert "\n") 525 (mm-with-unibyte-current-buffer 526 (insert coded))))) 527 ((eq (car cont) 'external) 528 (insert "Content-Type: message/external-body") 529 (let ((parameters (mml-parameter-string 530 cont '(expiration size permission))) 531 (name (cdr (assq 'name cont))) 532 (url (cdr (assq 'url cont)))) 533 (when name 534 (setq name (mml-parse-file-name name)) 535 (if (stringp name) 536 (mml-insert-parameter 537 (mail-header-encode-parameter "name" name) 538 "access-type=local-file") 539 (mml-insert-parameter 540 (mail-header-encode-parameter 541 "name" (file-name-nondirectory (nth 2 name))) 542 (mail-header-encode-parameter "site" (nth 1 name)) 543 (mail-header-encode-parameter 544 "directory" (file-name-directory (nth 2 name)))) 545 (mml-insert-parameter 546 (concat "access-type=" 547 (if (member (nth 0 name) '("ftp@" "anonymous@")) 548 "anon-ftp" 549 "ftp"))))) 550 (when url 551 (mml-insert-parameter 552 (mail-header-encode-parameter "url" url) 553 "access-type=url")) 554 (when parameters 555 (mml-insert-parameter-string 556 cont '(expiration size permission))) 557 (insert "\n\n") 558 (insert "Content-Type: " 559 (or (cdr (assq 'type cont)) 560 (if name 561 (or (mm-default-file-encoding name) 562 "application/octet-stream") 563 "text/plain")) 564 "\n") 565 (insert "Content-ID: " (message-make-message-id) "\n") 566 (insert "Content-Transfer-Encoding: " 567 (or (cdr (assq 'encoding cont)) "binary")) 568 (insert "\n\n") 569 (insert (or (cdr (assq 'contents cont)))) 570 (insert "\n"))) 571 ((eq (car cont) 'multipart) 572 (let* ((type (or (cdr (assq 'type cont)) "mixed")) 573 (mml-generate-default-type (if (equal type "digest") 574 "message/rfc822" 575 "text/plain")) 576 (handler (assoc type mml-generate-multipart-alist))) 577 (if handler 578 (funcall (cdr handler) cont) 579 ;; No specific handler. Use default one. 580 (let ((mml-boundary (mml-compute-boundary cont))) 581 (insert (format "Content-Type: multipart/%s; boundary=\"%s\"" 582 type mml-boundary) 583 (if (cdr (assq 'start cont)) 584 (format "; start=\"%s\"\n" (cdr (assq 'start cont))) 585 "\n")) 586 (let ((cont cont) part) 587 (while (setq part (pop cont)) 588 ;; Skip `multipart' and attributes. 589 (when (and (consp part) (consp (cdr part))) 590 (insert "\n--" mml-boundary "\n") 591 (mml-generate-mime-1 part) 592 (goto-char (point-max))))) 593 (insert "\n--" mml-boundary "--\n"))))) 594 (t 595 (error "Invalid element: %S" cont))) 596 ;; handle sign & encrypt tags in a semi-smart way. 597 (let ((sign-item (assoc (cdr (assq 'sign cont)) mml-sign-alist)) 598 (encrypt-item (assoc (cdr (assq 'encrypt cont)) 599 mml-encrypt-alist)) 600 sender recipients) 601 (when (or sign-item encrypt-item) 602 (when (setq sender (cdr (assq 'sender cont))) 603 (message-options-set 'mml-sender sender) 604 (message-options-set 'message-sender sender)) 605 (if (setq recipients (cdr (assq 'recipients cont))) 606 (message-options-set 'message-recipients recipients)) 607 (let ((style (mml-signencrypt-style 608 (first (or sign-item encrypt-item))))) 609 ;; check if: we're both signing & encrypting, both methods 610 ;; are the same (why would they be different?!), and that 611 ;; the signencrypt style allows for combined operation. 612 (if (and sign-item encrypt-item (equal (first sign-item) 613 (first encrypt-item)) 614 (equal style 'combined)) 615 (funcall (nth 1 encrypt-item) cont t) 616 ;; otherwise, revert to the old behavior. 617 (when sign-item 618 (funcall (nth 1 sign-item) cont)) 619 (when encrypt-item 620 (funcall (nth 1 encrypt-item) cont))))))))) 621 622(defun mml-compute-boundary (cont) 623 "Return a unique boundary that does not exist in CONT." 624 (let ((mml-boundary (funcall mml-boundary-function 625 (incf mml-multipart-number)))) 626 ;; This function tries again and again until it has found 627 ;; a unique boundary. 628 (while (not (catch 'not-unique 629 (mml-compute-boundary-1 cont)))) 630 mml-boundary)) 631 632(defun mml-compute-boundary-1 (cont) 633 (let (filename) 634 (cond 635 ((eq (car cont) 'part) 636 (with-temp-buffer 637 (cond 638 ((cdr (assq 'buffer cont)) 639 (insert-buffer-substring (cdr (assq 'buffer cont)))) 640 ((and (setq filename (cdr (assq 'filename cont))) 641 (not (equal (cdr (assq 'nofile cont)) "yes"))) 642 (mm-insert-file-contents filename nil nil nil nil t)) 643 (t 644 (insert (cdr (assq 'contents cont))))) 645 (goto-char (point-min)) 646 (when (re-search-forward (concat "^--" (regexp-quote mml-boundary)) 647 nil t) 648 (setq mml-boundary (funcall mml-boundary-function 649 (incf mml-multipart-number))) 650 (throw 'not-unique nil)))) 651 ((eq (car cont) 'multipart) 652 (mapcar 'mml-compute-boundary-1 (cddr cont)))) 653 t)) 654 655(defun mml-make-boundary (number) 656 (concat (make-string (% number 60) ?=) 657 (if (> number 17) 658 (format "%x" number) 659 "") 660 mml-base-boundary)) 661 662(defun mml-insert-mime-headers (cont type charset encoding flowed) 663 (let (parameters id disposition description) 664 (setq parameters 665 (mml-parameter-string 666 cont mml-content-type-parameters)) 667 (when (or charset 668 parameters 669 flowed 670 (not (equal type mml-generate-default-type)) 671 mml-insert-mime-headers-always) 672 (when (consp charset) 673 (error 674 "Can't encode a part with several charsets")) 675 (insert "Content-Type: " type) 676 (when charset 677 (mml-insert-parameter 678 (mail-header-encode-parameter "charset" (symbol-name charset)))) 679 (when flowed 680 (mml-insert-parameter "format=flowed")) 681 (when parameters 682 (mml-insert-parameter-string 683 cont mml-content-type-parameters)) 684 (insert "\n")) 685 (when (setq id (cdr (assq 'id cont))) 686 (insert "Content-ID: " id "\n")) 687 (setq parameters 688 (mml-parameter-string 689 cont mml-content-disposition-parameters)) 690 (when (or (setq disposition (cdr (assq 'disposition cont))) 691 parameters) 692 (insert "Content-Disposition: " (or disposition "inline")) 693 (when parameters 694 (mml-insert-parameter-string 695 cont mml-content-disposition-parameters)) 696 (insert "\n")) 697 (unless (eq encoding '7bit) 698 (insert (format "Content-Transfer-Encoding: %s\n" encoding))) 699 (when (setq description (cdr (assq 'description cont))) 700 (insert "Content-Description: ") 701 (setq description (prog1 702 (point) 703 (insert description "\n"))) 704 (mail-encode-encoded-word-region description (point))))) 705 706(defun mml-parameter-string (cont types) 707 (let ((string "") 708 value type) 709 (while (setq type (pop types)) 710 (when (setq value (cdr (assq type cont))) 711 ;; Strip directory component from the filename parameter. 712 (when (eq type 'filename) 713 (setq value (file-name-nondirectory value))) 714 (setq string (concat string "; " 715 (mail-header-encode-parameter 716 (symbol-name type) value))))) 717 (when (not (zerop (length string))) 718 string))) 719 720(defun mml-insert-parameter-string (cont types) 721 (let (value type) 722 (while (setq type (pop types)) 723 (when (setq value (cdr (assq type cont))) 724 ;; Strip directory component from the filename parameter. 725 (when (eq type 'filename) 726 (setq value (file-name-nondirectory value))) 727 (mml-insert-parameter 728 (mail-header-encode-parameter 729 (symbol-name type) value)))))) 730 731(eval-when-compile 732 (defvar ange-ftp-name-format) 733 (defvar efs-path-regexp)) 734(defun mml-parse-file-name (path) 735 (if (if (boundp 'efs-path-regexp) 736 (string-match efs-path-regexp path) 737 (if (boundp 'ange-ftp-name-format) 738 (string-match (car ange-ftp-name-format) path))) 739 (list (match-string 1 path) (match-string 2 path) 740 (substring path (1+ (match-end 2)))) 741 path)) 742 743(defun mml-insert-buffer (buffer) 744 "Insert BUFFER at point and quote any MML markup." 745 (save-restriction 746 (narrow-to-region (point) (point)) 747 (insert-buffer-substring buffer) 748 (mml-quote-region (point-min) (point-max)) 749 (goto-char (point-max)))) 750 751;;; 752;;; Transforming MIME to MML 753;;; 754 755(defun mime-to-mml (&optional handles) 756 "Translate the current buffer (which should be a message) into MML. 757If HANDLES is non-nil, use it instead reparsing the buffer." 758 ;; First decode the head. 759 (save-restriction 760 (message-narrow-to-head) 761 (let ((rfc2047-quote-decoded-words-containing-tspecials t)) 762 (mail-decode-encoded-word-region (point-min) (point-max)))) 763 (unless handles 764 (setq handles (mm-dissect-buffer t))) 765 (goto-char (point-min)) 766 (search-forward "\n\n" nil t) 767 (delete-region (point) (point-max)) 768 (if (stringp (car handles)) 769 (mml-insert-mime handles) 770 (mml-insert-mime handles t)) 771 (mm-destroy-parts handles) 772 (save-restriction 773 (message-narrow-to-head) 774 ;; Remove them, they are confusing. 775 (message-remove-header "Content-Type") 776 (message-remove-header "MIME-Version") 777 (message-remove-header "Content-Disposition") 778 (message-remove-header "Content-Transfer-Encoding"))) 779 780(defun mml-to-mime () 781 "Translate the current buffer from MML to MIME." 782 (message-encode-message-body) 783 (save-restriction 784 (message-narrow-to-headers-or-head) 785 ;; Skip past any From_ headers. 786 (while (looking-at "From ") 787 (forward-line 1)) 788 (let ((mail-parse-charset message-default-charset)) 789 (mail-encode-encoded-word-buffer)))) 790 791(defun mml-insert-mime (handle &optional no-markup) 792 (let (textp buffer mmlp) 793 ;; Determine type and stuff. 794 (unless (stringp (car handle)) 795 (unless (setq textp (equal (mm-handle-media-supertype handle) "text")) 796 (save-excursion 797 (set-buffer (setq buffer (mml-generate-new-buffer " *mml*"))) 798 (mm-insert-part handle 'no-cache) 799 (if (setq mmlp (equal (mm-handle-media-type handle) 800 "message/rfc822")) 801 (mime-to-mml))))) 802 (if mmlp 803 (mml-insert-mml-markup handle nil t t) 804 (unless (and no-markup 805 (equal (mm-handle-media-type handle) "text/plain")) 806 (mml-insert-mml-markup handle buffer textp))) 807 (cond 808 (mmlp 809 (insert-buffer-substring buffer) 810 (goto-char (point-max)) 811 (insert "<#/mml>\n")) 812 ((stringp (car handle)) 813 (mapcar 'mml-insert-mime (cdr handle)) 814 (insert "<#/multipart>\n")) 815 (textp 816 (let ((charset (mail-content-type-get 817 (mm-handle-type handle) 'charset)) 818 (start (point))) 819 (if (eq charset 'gnus-decoded) 820 (mm-insert-part handle) 821 (insert (mm-decode-string (mm-get-part handle) charset))) 822 (mml-quote-region start (point))) 823 (goto-char (point-max))) 824 (t 825 (insert "<#/part>\n"))))) 826 827(defun mml-insert-mml-markup (handle &optional buffer nofile mmlp) 828 "Take a MIME handle and insert an MML tag." 829 (if (stringp (car handle)) 830 (progn 831 (insert "<#multipart type=" (mm-handle-media-subtype handle)) 832 (let ((start (mm-handle-multipart-ctl-parameter handle 'start))) 833 (when start 834 (insert " start=\"" start "\""))) 835 (insert ">\n")) 836 (if mmlp 837 (insert "<#mml type=" (mm-handle-media-type handle)) 838 (insert "<#part type=" (mm-handle-media-type handle))) 839 (dolist (elem (append (cdr (mm-handle-type handle)) 840 (cdr (mm-handle-disposition handle)))) 841 (unless (symbolp (cdr elem)) 842 (insert " " (symbol-name (car elem)) "=\"" (cdr elem) "\""))) 843 (when (mm-handle-id handle) 844 (insert " id=\"" (mm-handle-id handle) "\"")) 845 (when (mm-handle-disposition handle) 846 (insert " disposition=" (car (mm-handle-disposition handle)))) 847 (when buffer 848 (insert " buffer=\"" (buffer-name buffer) "\"")) 849 (when nofile 850 (insert " nofile=yes")) 851 (when (mm-handle-description handle) 852 (insert " description=\"" (mm-handle-description handle) "\"")) 853 (insert ">\n"))) 854 855(defun mml-insert-parameter (&rest parameters) 856 "Insert PARAMETERS in a nice way." 857 (let (start end) 858 (dolist (param parameters) 859 (insert ";") 860 (setq start (point)) 861 (insert " " param) 862 (setq end (point)) 863 (goto-char start) 864 (end-of-line) 865 (if (> (current-column) 76) 866 (progn 867 (goto-char start) 868 (insert "\n") 869 (goto-char (1+ end))) 870 (goto-char end))))) 871 872;;; 873;;; Mode for inserting and editing MML forms 874;;; 875 876(defvar mml-mode-map 877 (let ((sign (make-sparse-keymap)) 878 (encrypt (make-sparse-keymap)) 879 (signpart (make-sparse-keymap)) 880 (encryptpart (make-sparse-keymap)) 881 (map (make-sparse-keymap)) 882 (main (make-sparse-keymap))) 883 (define-key map "\C-s" 'mml-secure-message-sign) 884 (define-key map "\C-c" 'mml-secure-message-encrypt) 885 (define-key map "\C-e" 'mml-secure-message-sign-encrypt) 886 (define-key map "\C-p\C-s" 'mml-secure-sign) 887 (define-key map "\C-p\C-c" 'mml-secure-encrypt) 888 (define-key sign "p" 'mml-secure-message-sign-pgpmime) 889 (define-key sign "o" 'mml-secure-message-sign-pgp) 890 (define-key sign "s" 'mml-secure-message-sign-smime) 891 (define-key signpart "p" 'mml-secure-sign-pgpmime) 892 (define-key signpart "o" 'mml-secure-sign-pgp) 893 (define-key signpart "s" 'mml-secure-sign-smime) 894 (define-key encrypt "p" 'mml-secure-message-encrypt-pgpmime) 895 (define-key encrypt "o" 'mml-secure-message-encrypt-pgp) 896 (define-key encrypt "s" 'mml-secure-message-encrypt-smime) 897 (define-key encryptpart "p" 'mml-secure-encrypt-pgpmime) 898 (define-key encryptpart "o" 'mml-secure-encrypt-pgp) 899 (define-key encryptpart "s" 'mml-secure-encrypt-smime) 900 (define-key map "\C-n" 'mml-unsecure-message) 901 (define-key map "f" 'mml-attach-file) 902 (define-key map "b" 'mml-attach-buffer) 903 (define-key map "e" 'mml-attach-external) 904 (define-key map "q" 'mml-quote-region) 905 (define-key map "m" 'mml-insert-multipart) 906 (define-key map "p" 'mml-insert-part) 907 (define-key map "v" 'mml-validate) 908 (define-key map "P" 'mml-preview) 909 (define-key map "s" sign) 910 (define-key map "S" signpart) 911 (define-key map "c" encrypt) 912 (define-key map "C" encryptpart) 913 ;;(define-key map "n" 'mml-narrow-to-part) 914 ;; `M-m' conflicts with `back-to-indentation'. 915 ;; (define-key main "\M-m" map) 916 (define-key main "\C-c\C-m" map) 917 main)) 918 919(easy-menu-define 920 mml-menu mml-mode-map "" 921 `("Attachments" 922 ["Attach File..." mml-attach-file 923 ,@(if (featurep 'xemacs) '(t) 924 '(:help "Attach a file at point"))] 925 ["Attach Buffer..." mml-attach-buffer 926 ,@(if (featurep 'xemacs) '(t) 927 '(:help "Attach a buffer to the outgoing MIME message"))] 928 ["Attach External..." mml-attach-external 929 ,@(if (featurep 'xemacs) '(t) 930 '(:help "Attach reference to file"))] 931 ;; 932 ("Change Security Method" 933 ["PGP/MIME" 934 (lambda () (interactive) (setq mml-secure-method "pgpmime")) 935 ,@(if (featurep 'xemacs) nil 936 '(:help "Set Security Method to PGP/MIME")) 937 :style radio 938 :selected (equal mml-secure-method "pgpmime") ] 939 ["S/MIME" 940 (lambda () (interactive) (setq mml-secure-method "smime")) 941 ,@(if (featurep 'xemacs) nil 942 '(:help "Set Security Method to S/MIME")) 943 :style radio 944 :selected (equal mml-secure-method "smime") ] 945 ["Inline PGP" 946 (lambda () (interactive) (setq mml-secure-method "pgp")) 947 ,@(if (featurep 'xemacs) nil 948 '(:help "Set Security Method to inline PGP")) 949 :style radio 950 :selected (equal mml-secure-method "pgp") ] ) 951 ;; 952 ["Sign Message" mml-secure-message-sign t] 953 ["Encrypt Message" mml-secure-message-encrypt t] 954 ["Sign and Encrypt Message" mml-secure-message-sign-encrypt t] 955 ["Encrypt/Sign off" mml-unsecure-message 956 ,@(if (featurep 'xemacs) '(t) 957 '(:help "Don't Encrypt/Sign Message"))] 958 ;; Maybe we could remove these, because people who write MML most probably 959 ;; don't use the menu: 960 ["Insert Part..." mml-insert-part 961 :active (message-in-body-p)] 962 ["Insert Multipart..." mml-insert-multipart 963 :active (message-in-body-p)] 964 ;; 965 ;; Do we have separate encrypt and encrypt/sign commands for parts? 966 ["Sign Part" mml-secure-sign t] 967 ["Encrypt Part" mml-secure-encrypt t] 968 ;;["Narrow" mml-narrow-to-part t] 969 ["Quote MML in region" mml-quote-region 970 :active (message-mark-active-p) 971 ,@(if (featurep 'xemacs) nil 972 '(:help "Quote MML tags in region"))] 973 ["Validate MML" mml-validate t] 974 ["Preview" mml-preview t] 975 "----" 976 ["Emacs MIME manual" (lambda () (interactive) (message-info 4)) 977 ,@(if (featurep 'xemacs) '(t) 978 '(:help "Display the Emacs MIME manual"))] 979 ["PGG manual" (lambda () (interactive) (message-info 16)) 980 ,@(if (featurep 'xemacs) '(t) 981 '(:help "Display the PGG manual"))])) 982 983(defvar mml-mode nil 984 "Minor mode for editing MML.") 985 986(defun mml-mode (&optional arg) 987 "Minor mode for editing MML. 988MML is the MIME Meta Language, a minor mode for composing MIME articles. 989See Info node `(emacs-mime)Composing'. 990 991\\{mml-mode-map}" 992 (interactive "P") 993 (when (set (make-local-variable 'mml-mode) 994 (if (null arg) (not mml-mode) 995 (> (prefix-numeric-value arg) 0))) 996 (add-minor-mode 'mml-mode " MML" mml-mode-map) 997 (easy-menu-add mml-menu mml-mode-map) 998 (when (boundp 'dnd-protocol-alist) 999 (set (make-local-variable 'dnd-protocol-alist) 1000 (append mml-dnd-protocol-alist dnd-protocol-alist))) 1001 (run-hooks 'mml-mode-hook))) 1002 1003;;; 1004;;; Helper functions for reading MIME stuff from the minibuffer and 1005;;; inserting stuff to the buffer. 1006;;; 1007 1008(defun mml-minibuffer-read-file (prompt) 1009 (let* ((completion-ignored-extensions nil) 1010 (file (read-file-name prompt nil nil t))) 1011 ;; Prevent some common errors. This is inspired by similar code in 1012 ;; VM. 1013 (when (file-directory-p file) 1014 (error "%s is a directory, cannot attach" file)) 1015 (unless (file-exists-p file) 1016 (error "No such file: %s" file)) 1017 (unless (file-readable-p file) 1018 (error "Permission denied: %s" file)) 1019 file)) 1020 1021(defun mml-minibuffer-read-type (name &optional default) 1022 (mailcap-parse-mimetypes) 1023 (let* ((default (or default 1024 (mm-default-file-encoding name) 1025 ;; Perhaps here we should check what the file 1026 ;; looks like, and offer text/plain if it looks 1027 ;; like text/plain. 1028 "application/octet-stream")) 1029 (string (completing-read 1030 (format "Content type (default %s): " default) 1031 (mapcar 'list (mailcap-mime-types))))) 1032 (if (not (equal string "")) 1033 string 1034 default))) 1035 1036(defun mml-minibuffer-read-description () 1037 (let ((description (read-string "One line description: "))) 1038 (when (string-match "\\`[ \t]*\\'" description) 1039 (setq description nil)) 1040 description)) 1041 1042(defun mml-minibuffer-read-disposition (type &optional default) 1043 (unless default (setq default 1044 (if (and (string-match "\\`text/" type) 1045 (not (string-match "\\`text/rtf\\'" type))) 1046 "inline" 1047 "attachment"))) 1048 (let ((disposition (completing-read 1049 (format "Disposition (default %s): " default) 1050 '(("attachment") ("inline") ("")) 1051 nil t nil nil default))) 1052 (if (not (equal disposition "")) 1053 disposition 1054 default))) 1055 1056(defun mml-quote-region (beg end) 1057 "Quote the MML tags in the region." 1058 (interactive "r") 1059 (save-excursion 1060 (save-restriction 1061 ;; Temporarily narrow the region to defend from changes 1062 ;; invalidating END. 1063 (narrow-to-region beg end) 1064 (goto-char (point-min)) 1065 ;; Quote parts. 1066 (while (re-search-forward 1067 "<#!*/?\\(multipart\\|part\\|external\\|mml\\)" nil t) 1068 ;; Insert ! after the #. 1069 (goto-char (+ (match-beginning 0) 2)) 1070 (insert "!"))))) 1071 1072(defun mml-insert-tag (name &rest plist) 1073 "Insert an MML tag described by NAME and PLIST." 1074 (when (symbolp name) 1075 (setq name (symbol-name name))) 1076 (insert "<#" name) 1077 (while plist 1078 (let ((key (pop plist)) 1079 (value (pop plist))) 1080 (when value 1081 ;; Quote VALUE if it contains suspicious characters. 1082 (when (string-match "[\"'\\~/*;() \t\n]" value) 1083 (setq value (with-output-to-string 1084 (let (print-escape-nonascii) 1085 (prin1 value))))) 1086 (insert (format " %s=%s" key value))))) 1087 (insert ">\n")) 1088 1089(defun mml-insert-empty-tag (name &rest plist) 1090 "Insert an empty MML tag described by NAME and PLIST." 1091 (when (symbolp name) 1092 (setq name (symbol-name name))) 1093 (apply #'mml-insert-tag name plist) 1094 (insert "<#/" name ">\n")) 1095 1096;;; Attachment functions. 1097 1098(defcustom mml-dnd-protocol-alist 1099 '(("^file:///" . mml-dnd-attach-file) 1100 ("^file://" . dnd-open-file) 1101 ("^file:" . mml-dnd-attach-file)) 1102 "The functions to call when a drop in `mml-mode' is made. 1103See `dnd-protocol-alist' for more information. When nil, behave 1104as in other buffers." 1105 :type '(choice (repeat (cons (regexp) (function))) 1106 (const :tag "Behave as in other buffers" nil)) 1107 :version "22.1" ;; Gnus 5.10.9 1108 :group 'message) 1109 1110(defcustom mml-dnd-attach-options nil 1111 "Which options should be queried when attaching a file via drag and drop. 1112 1113If it is a list, valid members are `type', `description' and 1114`disposition'. `disposition' implies `type'. If it is nil, 1115don't ask for options. If it is t, ask the user whether or not 1116to specify options." 1117 :type '(choice 1118 (const :tag "Non" nil) 1119 (const :tag "Query" t) 1120 (list :value (type description disposition) 1121 (set :inline t 1122 (const type) 1123 (const description) 1124 (const disposition)))) 1125 :version "22.1" ;; Gnus 5.10.9 1126 :group 'message) 1127 1128(defun mml-attach-file (file &optional type description disposition) 1129 "Attach a file to the outgoing MIME message. 1130The file is not inserted or encoded until you send the message with 1131`\\[message-send-and-exit]' or `\\[message-send]'. 1132 1133FILE is the name of the file to attach. TYPE is its 1134content-type, a string of the form \"type/subtype\". DESCRIPTION 1135is a one-line description of the attachment. The DISPOSITION 1136specifies how the attachment is intended to be displayed. It can 1137be either \"inline\" (displayed automatically within the message 1138body) or \"attachment\" (separate from the body)." 1139 (interactive 1140 (let* ((file (mml-minibuffer-read-file "Attach file: ")) 1141 (type (mml-minibuffer-read-type file)) 1142 (description (mml-minibuffer-read-description)) 1143 (disposition (mml-minibuffer-read-disposition type))) 1144 (list file type description disposition))) 1145 (save-excursion 1146 (unless (message-in-body-p) (goto-char (point-max))) 1147 (mml-insert-empty-tag 'part 1148 'type type 1149 'filename file 1150 'disposition (or disposition "attachment") 1151 'description description))) 1152 1153(defun mml-dnd-attach-file (uri action) 1154 "Attach a drag and drop file. 1155 1156Ask for type, description or disposition according to 1157`mml-dnd-attach-options'." 1158 (let ((file (dnd-get-local-file-name uri t))) 1159 (when (and file (file-regular-p file)) 1160 (let ((mml-dnd-attach-options mml-dnd-attach-options) 1161 type description disposition) 1162 (setq mml-dnd-attach-options 1163 (when (and (eq mml-dnd-attach-options t) 1164 (not 1165 (y-or-n-p 1166 "Use default type, disposition and description? "))) 1167 '(type description disposition))) 1168 (when (or (memq 'type mml-dnd-attach-options) 1169 (memq 'disposition mml-dnd-attach-options)) 1170 (setq type (mml-minibuffer-read-type file))) 1171 (when (memq 'description mml-dnd-attach-options) 1172 (setq description (mml-minibuffer-read-description))) 1173 (when (memq 'disposition mml-dnd-attach-options) 1174 (setq disposition (mml-minibuffer-read-disposition type))) 1175 (mml-attach-file file type description disposition))))) 1176 1177(defun mml-attach-buffer (buffer &optional type description) 1178 "Attach a buffer to the outgoing MIME message. 1179See `mml-attach-file' for details of operation." 1180 (interactive 1181 (let* ((buffer (read-buffer "Attach buffer: ")) 1182 (type (mml-minibuffer-read-type buffer "text/plain")) 1183 (description (mml-minibuffer-read-description))) 1184 (list buffer type description))) 1185 (save-excursion 1186 (unless (message-in-body-p) (goto-char (point-max))) 1187 (mml-insert-empty-tag 'part 'type type 'buffer buffer 1188 'disposition "attachment" 1189 'description description))) 1190 1191(defun mml-attach-external (file &optional type description) 1192 "Attach an external file into the buffer. 1193FILE is an ange-ftp/efs specification of the part location. 1194TYPE is the MIME type to use." 1195 (interactive 1196 (let* ((file (mml-minibuffer-read-file "Attach external file: ")) 1197 (type (mml-minibuffer-read-type file)) 1198 (description (mml-minibuffer-read-description))) 1199 (list file type description))) 1200 (save-excursion 1201 (unless (message-in-body-p) (goto-char (point-max))) 1202 (mml-insert-empty-tag 'external 'type type 'name file 1203 'disposition "attachment" 'description description))) 1204 1205(defun mml-insert-multipart (&optional type) 1206 (interactive (list (completing-read "Multipart type (default mixed): " 1207 '(("mixed") ("alternative") ("digest") ("parallel") 1208 ("signed") ("encrypted")) 1209 nil nil "mixed"))) 1210 (or type 1211 (setq type "mixed")) 1212 (mml-insert-empty-tag "multipart" 'type type) 1213 (forward-line -1)) 1214 1215(defun mml-insert-part (&optional type) 1216 (interactive 1217 (list (mml-minibuffer-read-type ""))) 1218 (mml-insert-tag 'part 'type type 'disposition "inline") 1219 (forward-line -1)) 1220 1221(defun mml-preview-insert-mail-followup-to () 1222 "Insert a Mail-Followup-To header before previewing an article. 1223Should be adopted if code in `message-send-mail' is changed." 1224 (when (and (message-mail-p) 1225 (message-subscribed-p) 1226 (not (mail-fetch-field "mail-followup-to")) 1227 (message-make-mail-followup-to)) 1228 (message-position-on-field "Mail-Followup-To" "X-Draft-From") 1229 (insert (message-make-mail-followup-to)))) 1230 1231(defun mml-preview (&optional raw) 1232 "Display current buffer with Gnus, in a new buffer. 1233If RAW, display a raw encoded MIME message." 1234 (interactive "P") 1235 (save-excursion 1236 (let* ((buf (current-buffer)) 1237 (message-options message-options) 1238 (message-this-is-mail (message-mail-p)) 1239 (message-this-is-news (message-news-p)) 1240 (message-posting-charset (or (gnus-setup-posting-charset 1241 (save-restriction 1242 (message-narrow-to-headers-or-head) 1243 (message-fetch-field "Newsgroups"))) 1244 message-posting-charset))) 1245 (message-options-set-recipient) 1246 (pop-to-buffer (generate-new-buffer 1247 (concat (if raw "*Raw MIME preview of " 1248 "*MIME preview of ") (buffer-name)))) 1249 (when (boundp 'gnus-buffers) 1250 (push (current-buffer) gnus-buffers)) 1251 (erase-buffer) 1252 (insert-buffer-substring buf) 1253 (mml-preview-insert-mail-followup-to) 1254 (let ((message-deletable-headers (if (message-news-p) 1255 nil 1256 message-deletable-headers))) 1257 (message-generate-headers 1258 (copy-sequence (if (message-news-p) 1259 message-required-news-headers 1260 message-required-mail-headers)))) 1261 (if (re-search-forward 1262 (concat "^" (regexp-quote mail-header-separator) "\n") nil t) 1263 (replace-match "\n")) 1264 (let ((mail-header-separator ""));; mail-header-separator is removed. 1265 (mml-to-mime)) 1266 (if raw 1267 (when (fboundp 'set-buffer-multibyte) 1268 (let ((s (buffer-string))) 1269 ;; Insert the content into unibyte buffer. 1270 (erase-buffer) 1271 (mm-disable-multibyte) 1272 (insert s))) 1273 (let ((gnus-newsgroup-charset (car message-posting-charset)) 1274 gnus-article-prepare-hook gnus-original-article-buffer) 1275 (run-hooks 'gnus-article-decode-hook) 1276 (let ((gnus-newsgroup-name "dummy") 1277 (gnus-newsrc-hashtb (or gnus-newsrc-hashtb 1278 (gnus-make-hashtable 5)))) 1279 (gnus-article-prepare-display)))) 1280 ;; Disable article-mode-map. 1281 (use-local-map nil) 1282 (gnus-make-local-hook 'kill-buffer-hook) 1283 (add-hook 'kill-buffer-hook 1284 (lambda () 1285 (mm-destroy-parts gnus-article-mime-handles)) nil t) 1286 (setq buffer-read-only t) 1287 (local-set-key "q" (lambda () (interactive) (kill-buffer nil))) 1288 (local-set-key "=" (lambda () (interactive) (delete-other-windows))) 1289 (local-set-key "\r" 1290 (lambda () 1291 (interactive) 1292 (widget-button-press (point)))) 1293 (local-set-key gnus-mouse-2 1294 (lambda (event) 1295 (interactive "@e") 1296 (widget-button-press (widget-event-point event) event))) 1297 (goto-char (point-min))))) 1298 1299(defun mml-validate () 1300 "Validate the current MML document." 1301 (interactive) 1302 (mml-parse)) 1303 1304(defun mml-tweak-part (cont) 1305 "Tweak a MML part." 1306 (let ((tweak (cdr (assq 'tweak cont))) 1307 func) 1308 (cond 1309 (tweak 1310 (setq func 1311 (or (cdr (assoc tweak mml-tweak-function-alist)) 1312 (intern tweak)))) 1313 (mml-tweak-type-alist 1314 (let ((alist mml-tweak-type-alist) 1315 (type (or (cdr (assq 'type cont)) "text/plain"))) 1316 (while alist 1317 (if (string-match (caar alist) type) 1318 (setq func (cdar alist) 1319 alist nil) 1320 (setq alist (cdr alist))))))) 1321 (if func 1322 (funcall func cont) 1323 cont) 1324 (let ((alist mml-tweak-sexp-alist)) 1325 (while alist 1326 (if (eval (caar alist)) 1327 (funcall (cdar alist) cont)) 1328 (setq alist (cdr alist))))) 1329 cont) 1330 1331(defun mml-tweak-externalize-attachments (cont) 1332 "Tweak attached files as external parts." 1333 (let (filename-cons) 1334 (when (and (eq (car cont) 'part) 1335 (not (cdr (assq 'buffer cont))) 1336 (and (setq filename-cons (assq 'filename cont)) 1337 (not (equal (cdr (assq 'nofile cont)) "yes")))) 1338 (setcar cont 'external) 1339 (setcar filename-cons 'name)))) 1340 1341(provide 'mml) 1342 1343;;; arch-tag: 583c96cf-1ffe-451b-a5e5-4733ae9ddd12 1344;;; mml.el ends here 1345