git.chise.org Git - elisp/gnus.git-/blob - lisp/mml.el

   1 ;;; mml.el --- A package for parsing and validating MML documents
   2 ;; Copyright (C) 1998,99 Free Software Foundation, Inc.
   3
   4 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   5 ;; This file is part of GNU Emacs.
   6
   7 ;; GNU Emacs is free software; you can redistribute it and/or modify
   8 ;; it under the terms of the GNU General Public License as published by
   9 ;; the Free Software Foundation; either version 2, or (at your option)
  10 ;; any later version.
  11
  12 ;; GNU Emacs is distributed in the hope that it will be useful,
  13 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;; GNU General Public License for more details.
  16
  17 ;; You should have received a copy of the GNU General Public License
  18 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  19 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  20 ;; Boston, MA 02111-1307, USA.
  21
  22 ;;; Commentary:
  23
  24 ;;; Code:
  25
  26 (require 'mm-util)
  27 (require 'mm-bodies)
  28 (require 'mm-encode)
  29 (require 'mm-decode)
  30
  31 (eval-and-compile
  32   (autoload 'message-make-message-id "message"))
  33
  34 (defvar mml-syntax-table
  35   (let ((table (copy-syntax-table emacs-lisp-mode-syntax-table)))
  36     (modify-syntax-entry ?\\ "/" table)
  37     (modify-syntax-entry ?< "(" table)
  38     (modify-syntax-entry ?> ")" table)
  39     (modify-syntax-entry ?@ "w" table)
  40     (modify-syntax-entry ?/ "w" table)
  41     (modify-syntax-entry ?= " " table)
  42     (modify-syntax-entry ?* " " table)
  43     (modify-syntax-entry ?\; " " table)
  44     (modify-syntax-entry ?\' " " table)
  45     table))
  46
  47 (defun mml-parse ()
  48   "Parse the current buffer as an MML document."
  49   (goto-char (point-min))
  50   (let ((table (syntax-table)))
  51     (unwind-protect
  52         (progn
  53           (set-syntax-table mml-syntax-table)
  54           (mml-parse-1))
  55       (set-syntax-table table))))
  56
  57 (defun mml-parse-1 ()
  58   "Parse the current buffer as an MML document."
  59   (let (struct tag point contents charsets warn)
  60     (while (and (not (eobp))
  61                 (not (looking-at "<#/multipart")))
  62       (cond
  63        ((looking-at "<#multipart")
  64         (push (nconc (mml-read-tag) (mml-parse-1)) struct))
  65        ((looking-at "<#external")
  66         (push (nconc (mml-read-tag) (list (cons 'contents (mml-read-part))))
  67               struct))
  68        (t
  69         (if (looking-at "<#part")
  70             (setq tag (mml-read-tag))
  71           (setq tag (list 'part '(type . "text/plain"))
  72                 warn t))
  73         (setq point (point)
  74               contents (mml-read-part)
  75               charsets (mm-find-mime-charset-region point (point)))
  76         (if (< (length charsets) 2)
  77             (push (nconc tag (list (cons 'contents contents)))
  78                   struct)
  79           (let ((nstruct (mml-parse-singlepart-with-multiple-charsets
  80                           tag point (point))))
  81             (when (and warn
  82                        (not
  83                         (y-or-n-p
  84                          (format
  85                           "Warning: Your message contains %d parts.  Really send? "
  86                           (length nstruct)))))
  87               (error "Edit your message to use only one charset"))
  88             (setq struct (nconc nstruct struct)))))))
  89     (unless (eobp)
  90       (forward-line 1))
  91     (nreverse struct)))
  92
  93 (defun mml-parse-singlepart-with-multiple-charsets (orig-tag beg end)
  94   (save-excursion
  95     (narrow-to-region beg end)
  96     (goto-char (point-min))
  97     (let ((current (mm-mime-charset (char-charset (following-char))))
  98           charset struct space newline paragraph)
  99       (while (not (eobp))
 100         (cond
 101          ;; The charset remains the same.
 102          ((or (eq (setq charset (mm-mime-charset
 103                                  (char-charset (following-char)))) 'us-ascii)
 104               (eq charset current)))
 105          ;; The initial charset was ascii.
 106          ((eq current 'us-ascii)
 107           (setq current charset
 108                 space nil
 109                 newline nil
 110                 paragraph nil))
 111          ;; We have a change in charsets.
 112          (t
 113           (push (append
 114                  orig-tag
 115                  (list (cons 'contents
 116                              (buffer-substring-no-properties
 117                               beg (or paragraph newline space (point))))))
 118                 struct)
 119           (setq beg (or paragraph newline space (point))
 120                 current charset
 121                 space nil
 122                 newline nil
 123                 paragraph nil)))
 124         ;; Compute places where it might be nice to break the part.
 125         (cond
 126          ((memq (following-char) '(?  ?\t))
 127           (setq space (1+ (point))))
 128          ((eq (following-char) ?\n)
 129           (setq newline (1+ (point))))
 130          ((and (eq (following-char) ?\n)
 131                (not (bobp))
 132                (eq (char-after (1- (point))) ?\n))
 133           (setq paragraph (point))))
 134         (forward-char 1))
 135       ;; Do the final part.
 136       (unless (= beg (point))
 137         (push (append orig-tag
 138                       (list (cons 'contents
 139                                   (buffer-substring-no-properties
 140                                    beg (point)))))
 141               struct))
 142       struct)))
 143
 144 (defun mml-read-tag ()
 145   "Read a tag and return the contents."
 146   (let (contents name elem val)
 147     (forward-char 2)
 148     (setq name (buffer-substring-no-properties
 149                 (point) (progn (forward-sexp 1) (point))))
 150     (skip-chars-forward " \t\n")
 151     (while (not (looking-at ">"))
 152       (setq elem (buffer-substring-no-properties
 153                   (point) (progn (forward-sexp 1) (point))))
 154       (skip-chars-forward "= \t\n")
 155       (setq val (buffer-substring-no-properties
 156                  (point) (progn (forward-sexp 1) (point))))
 157       (when (string-match "^\"\\(.*\\)\"$" val)
 158         (setq val (match-string 1 val)))
 159       (push (cons (intern elem) val) contents)
 160       (skip-chars-forward " \t\n"))
 161     (forward-char 1)
 162     (skip-chars-forward " \t\n")
 163     (cons (intern name) (nreverse contents))))
 164
 165 (defun mml-read-part ()
 166   "Return the buffer up till the next part, multipart or closing part or multipart."
 167   (let ((beg (point)))
 168     ;; If the tag ended at the end of the line, we go to the next line.
 169     (when (looking-at "[ \t]*\n")
 170       (forward-line 1))
 171     (if (re-search-forward
 172          "<#\\(/\\)?\\(multipart\\|part\\|external\\)." nil t)
 173         (prog1
 174             (buffer-substring-no-properties beg (match-beginning 0))
 175           (if (or (not (match-beginning 1))
 176                   (equal (match-string 2) "multipart"))
 177               (goto-char (match-beginning 0))
 178             (when (looking-at "[ \t]*\n")
 179               (forward-line 1))))
 180       (buffer-substring-no-properties beg (goto-char (point-max))))))
 181
 182 (defvar mml-boundary nil)
 183 (defvar mml-base-boundary "-=-=")
 184 (defvar mml-multipart-number 0)
 185
 186 (defun mml-generate-mime ()
 187   "Generate a MIME message based on the current MML document."
 188   (let ((cont (mml-parse))
 189         (mml-multipart-number 0))
 190     (if (not cont)
 191         nil
 192       (with-temp-buffer
 193         (if (and (consp (car cont))
 194                  (= (length cont) 1))
 195             (mml-generate-mime-1 (car cont))
 196           (mml-generate-mime-1 (nconc (list 'multipart '(type . "mixed"))
 197                                       cont)))
 198         (buffer-string)))))
 199
 200 (defun mml-generate-mime-1 (cont)
 201   (cond
 202    ((eq (car cont) 'part)
 203     (let (coded encoding charset filename type)
 204       (setq type (or (cdr (assq 'type cont)) "text/plain"))
 205       (if (equal (car (split-string type "/")) "text")
 206           (with-temp-buffer
 207             (cond
 208              ((cdr (assq 'buffer cont))
 209               (insert-buffer-substring (cdr (assq 'buffer cont))))
 210              ((setq filename (cdr (assq 'filename cont)))
 211               (insert-file-contents filename))
 212              (t
 213               (save-restriction
 214                 (narrow-to-region (point) (point))
 215                 (insert (cdr (assq 'contents cont)))
 216                 ;; Remove quotes from quoted tags.
 217                 (goto-char (point-min))
 218                 (while (re-search-forward
 219                         "<#!+/?\\(part\\|multipart\\|external\\)" nil t)
 220                   (delete-region (+ (match-beginning 0) 2)
 221                                  (+ (match-beginning 0) 3))))))
 222             (setq charset (mm-encode-body))
 223             (setq encoding (mm-body-encoding charset))
 224             (setq coded (buffer-string)))
 225         (mm-with-unibyte-buffer
 226           (cond
 227            ((cdr (assq 'buffer cont))
 228             (insert-buffer-substring (cdr (assq 'buffer cont))))
 229            ((setq filename (cdr (assq 'filename cont)))
 230             (insert-file-contents filename))
 231            (t
 232             (insert (cdr (assq 'contents cont)))))
 233           (setq encoding (mm-encode-buffer type)
 234                 coded (buffer-string))))
 235       (mml-insert-mime-headers cont type charset encoding)
 236       (insert "\n")
 237       (insert coded)))
 238    ((eq (car cont) 'external)
 239     (insert "Content-Type: message/external-body")
 240     (let ((parameters (mml-parameter-string
 241                        cont '(expiration size permission)))
 242           (name (cdr (assq 'name cont))))
 243       (when name
 244         (setq name (mml-parse-file-name name))
 245         (if (stringp name)
 246             (mml-insert-parameter
 247              (mail-header-encode-parameter "name" name)
 248              "access-type=local-file")
 249           (mml-insert-parameter
 250            (mail-header-encode-parameter
 251             "name" (file-name-nondirectory (nth 2 name)))
 252            (mail-header-encode-parameter "site" (nth 1 name))
 253            (mail-header-encode-parameter
 254             "directory" (file-name-directory (nth 2 name))))
 255           (mml-insert-parameter
 256            (concat "access-type="
 257                    (if (member (nth 0 name) '("ftp@" "anonymous@"))
 258                        "anon-ftp"
 259                      "ftp")))))
 260       (when parameters
 261         (mml-insert-parameter-string
 262          cont '(expiration size permission))))
 263     (insert "\n\n")
 264     (insert "Content-Type: " (cdr (assq 'type cont)) "\n")
 265     (insert "Content-ID: " (message-make-message-id) "\n")
 266     (insert "Content-Transfer-Encoding: "
 267             (or (cdr (assq 'encoding cont)) "binary"))
 268     (insert "\n\n")
 269     (insert (or (cdr (assq 'contents cont))))
 270     (insert "\n"))
 271    ((eq (car cont) 'multipart)
 272     (let ((mml-boundary (mml-compute-boundary cont)))
 273       (insert (format "Content-Type: multipart/%s; boundary=\"%s\"\n"
 274                       (or (cdr (assq 'type cont)) "mixed")
 275                       mml-boundary))
 276       (insert "\n")
 277       (setq cont (cddr cont))
 278       (while cont
 279         (insert "\n--" mml-boundary "\n")
 280         (mml-generate-mime-1 (pop cont)))
 281       (insert "\n--" mml-boundary "--\n")))
 282    (t
 283     (error "Invalid element: %S" cont))))
 284
 285 (defun mml-compute-boundary (cont)
 286   "Return a unique boundary that does not exist in CONT."
 287   (let ((mml-boundary (mml-make-boundary)))
 288     ;; This function tries again and again until it has found
 289     ;; a unique boundary.
 290     (while (not (catch 'not-unique
 291                   (mml-compute-boundary-1 cont))))
 292     mml-boundary))
 293
 294 (defun mml-compute-boundary-1 (cont)
 295   (let (filename)
 296     (cond
 297      ((eq (car cont) 'part)
 298       (with-temp-buffer
 299         (cond
 300          ((cdr (assq 'buffer cont))
 301           (insert-buffer-substring (cdr (assq 'buffer cont))))
 302          ((setq filename (cdr (assq 'filename cont)))
 303           (insert-file-contents filename))
 304          (t
 305           (insert (cdr (assq 'contents cont)))))
 306         (goto-char (point-min))
 307         (when (re-search-forward (concat "^--" (regexp-quote mml-boundary))
 308                                  nil t)
 309           (setq mml-boundary (mml-make-boundary))
 310           (throw 'not-unique nil))))
 311      ((eq (car cont) 'multipart)
 312       (mapcar 'mml-compute-boundary-1 (cddr cont))))
 313     t))
 314
 315 (defun mml-make-boundary ()
 316   (concat (make-string (% (incf mml-multipart-number) 60) ?=)
 317           (if (> mml-multipart-number 17)
 318               (format "%x" mml-multipart-number)
 319             "")
 320           mml-base-boundary))
 321
 322 (defun mml-make-string (num string)
 323   (let ((out ""))
 324     (while (not (zerop (decf num)))
 325       (setq out (concat out string)))
 326     out))
 327
 328 (defun mml-insert-mime-headers (cont type charset encoding)
 329   (let (parameters disposition description)
 330     (setq parameters
 331           (mml-parameter-string
 332            cont '(name access-type expiration size permission)))
 333     (when (or charset
 334               parameters
 335               (not (equal type "text/plain")))
 336       (when (consp charset)
 337         (error
 338          "Can't encode a part with several charsets."))
 339       (insert "Content-Type: " type)
 340       (when charset
 341         (insert "; " (mail-header-encode-parameter
 342                       "charset" (symbol-name charset))))
 343       (when parameters
 344         (mml-insert-parameter-string
 345          cont '(name access-type expiration size permission)))
 346       (insert "\n"))
 347     (setq parameters
 348           (mml-parameter-string
 349            cont '(filename creation-date modification-date read-date)))
 350     (when (or (setq disposition (cdr (assq 'disposition cont)))
 351               parameters)
 352       (insert "Content-Disposition: " (or disposition "inline"))
 353       (when parameters
 354         (mml-insert-parameter-string
 355          cont '(filename creation-date modification-date read-date)))
 356       (insert "\n"))
 357     (unless (eq encoding '7bit)
 358       (insert (format "Content-Transfer-Encoding: %s\n" encoding)))
 359     (when (setq description (cdr (assq 'description cont)))
 360       (insert "Content-Description: "
 361               (mail-encode-encoded-word-string description) "\n"))))
 362
 363 (defun mml-parameter-string (cont types)
 364   (let ((string "")
 365         value type)
 366     (while (setq type (pop types))
 367       (when (setq value (cdr (assq type cont)))
 368         ;; Strip directory component from the filename parameter.
 369         (when (eq type 'filename)
 370           (setq value (file-name-nondirectory value)))
 371         (setq string (concat string "; "
 372                              (mail-header-encode-parameter
 373                               (symbol-name type) value)))))
 374     (when (not (zerop (length string)))
 375       string)))
 376
 377 (defun mml-insert-parameter-string (cont types)
 378   (let (value type)
 379     (while (setq type (pop types))
 380       (when (setq value (cdr (assq type cont)))
 381         ;; Strip directory component from the filename parameter.
 382         (when (eq type 'filename)
 383           (setq value (file-name-nondirectory value)))
 384         (mml-insert-parameter
 385          (mail-header-encode-parameter
 386           (symbol-name type) value))))))
 387
 388 (defvar ange-ftp-path-format)
 389 (defvar efs-path-regexp)
 390 (defun mml-parse-file-name (path)
 391   (if (if (boundp 'efs-path-regexp)
 392           (string-match efs-path-regexp path)
 393         (if (boundp 'ange-ftp-path-format)
 394             (string-match (car ange-ftp-path-format))))
 395       (list (match-string 1 path) (match-string 2 path)
 396             (substring path (1+ (match-end 2))))
 397     path))
 398
 399 (defun mml-insert-buffer (buffer)
 400   "Insert BUFFER at point and quote any MML markup."
 401   (save-restriction
 402     (narrow-to-region (point) (point))
 403     (insert-buffer-substring buffer)
 404     (mml-quote-region (point-min) (point-max))
 405     (goto-char (point-max))))
 406
 407 ;;;
 408 ;;; Transforming MIME to MML
 409 ;;;
 410
 411 (defun mime-to-mml ()
 412   "Translate the current buffer (which should be a message) into MML."
 413   ;; First decode the head.
 414   (save-restriction
 415     (message-narrow-to-head)
 416     (mail-decode-encoded-word-region (point-min) (point-max)))
 417   (let ((handles (mm-dissect-buffer t)))
 418     (goto-char (point-min))
 419     (search-forward "\n\n" nil t)
 420     (delete-region (point) (point-max))
 421     (if (stringp (car handles))
 422         (mml-insert-mime handles)
 423       (mml-insert-mime handles t))
 424     (mm-destroy-parts handles)))
 425
 426 (defun mml-to-mime ()
 427   "Translate the current buffer from MML to MIME."
 428   (message-encode-message-body)
 429   (save-restriction
 430     (message-narrow-to-headers)
 431     (mail-encode-encoded-word-buffer)))
 432
 433 (defun mml-insert-mime (handle &optional no-markup)
 434   (let (textp buffer)
 435     ;; Determine type and stuff.
 436     (unless (stringp (car handle))
 437       (unless (setq textp (equal
 438                            (car (split-string
 439                                  (car (mm-handle-type handle)) "/"))
 440                            "text"))
 441         (save-excursion
 442           (set-buffer (setq buffer (generate-new-buffer " *mml*")))
 443           (mm-insert-part handle))))
 444     (unless no-markup
 445       (mml-insert-mml-markup handle buffer))
 446     (cond
 447      ((stringp (car handle))
 448       (mapcar 'mml-insert-mime (cdr handle))
 449       (insert "<#/multipart>\n"))
 450      (textp
 451       (mm-insert-part handle)
 452       (goto-char (point-max)))
 453      (t
 454       (insert "<#/part>\n")))))
 455
 456 (defun mml-insert-mml-markup (handle &optional buffer)
 457   "Take a MIME handle and insert an MML tag."
 458   (if (stringp (car handle))
 459       (insert "<#multipart type=" (cadr (split-string (car handle) "/"))
 460               ">\n")
 461     (insert "<#part type=" (car (mm-handle-type handle)))
 462     (dolist (elem (append (cdr (mm-handle-type handle))
 463                           (cdr (mm-handle-disposition handle))))
 464       (insert " " (symbol-name (car elem)) "=\"" (cdr elem) "\""))
 465     (when (mm-handle-disposition handle)
 466       (insert " disposition=" (car (mm-handle-disposition handle))))
 467     (when buffer
 468       (insert " buffer=\"" (buffer-name buffer) "\""))
 469     (when (mm-handle-description handle)
 470       (insert " description=\"" (mm-handle-description handle) "\""))
 471     (equal (split-string (car (mm-handle-type handle)) "/") "text")
 472     (insert ">\n")))
 473
 474 (defun mml-insert-parameter (&rest parameters)
 475   "Insert PARAMETERS in a nice way."
 476   (dolist (param parameters)
 477     (insert ";")
 478     (let ((point (point)))
 479       (insert " " param)
 480       (when (> (current-column) 71)
 481         (goto-char point)
 482         (insert "\n ")
 483         (end-of-line)))))
 484
 485 ;;;
 486 ;;; Mode for inserting and editing MML forms
 487 ;;;
 488
 489 (defvar mml-mode-map
 490   (let ((map (make-sparse-keymap))
 491         (main (make-sparse-keymap)))
 492     (define-key map "f" 'mml-attach-file)
 493     (define-key map "b" 'mml-attach-buffer)
 494     (define-key map "e" 'mml-attach-external)
 495     (define-key map "q" 'mml-quote-region)
 496     (define-key map "m" 'mml-insert-multipart)
 497     (define-key map "p" 'mml-insert-part)
 498     (define-key map "v" 'mml-validate)
 499     (define-key map "P" 'mml-preview)
 500     (define-key main "\M-m" map)
 501     main))
 502
 503 (easy-menu-define
 504  mml-menu mml-mode-map ""
 505  '("MML"
 506    ("Attach"
 507     ["File" mml-attach-file t]
 508     ["Buffer" mml-attach-buffer t]
 509     ["External" mml-attach-external t])
 510    ("Insert"
 511     ["Multipart" mml-insert-multipart t]
 512     ["Part" mml-insert-part t])
 513    ["Quote" mml-quote-region t]
 514    ["Validate" mml-validate t]))
 515
 516 (defvar mml-mode nil
 517   "Minor mode for editing MML.")
 518
 519 (defun mml-mode (&optional arg)
 520   "Minor mode for editing MML.
 521
 522 \\{mml-mode-map}"
 523   (interactive "P")
 524   (if (not (set (make-local-variable 'mml-mode)
 525                 (if (null arg) (not mml-mode)
 526                   (> (prefix-numeric-value arg) 0))))
 527       nil
 528     (set (make-local-variable 'mml-mode) t)
 529     (unless (assq 'mml-mode minor-mode-alist)
 530       (push `(mml-mode " MML") minor-mode-alist))
 531     (unless (assq 'mml-mode minor-mode-map-alist)
 532       (push (cons 'mml-mode mml-mode-map)
 533             minor-mode-map-alist)))
 534   (run-hooks 'mml-mode-hook))
 535
 536 ;;;
 537 ;;; Helper functions for reading MIME stuff from the minibuffer and
 538 ;;; inserting stuff to the buffer.
 539 ;;;
 540
 541 (defun mml-minibuffer-read-file (prompt)
 542   (let ((file (read-file-name prompt nil nil t)))
 543     ;; Prevent some common errors.  This is inspired by similar code in
 544     ;; VM.
 545     (when (file-directory-p file)
 546       (error "%s is a directory, cannot attach" file))
 547     (unless (file-exists-p file)
 548       (error "No such file: %s" file))
 549     (unless (file-readable-p file)
 550       (error "Permission denied: %s" file))
 551     file))
 552
 553 (defun mml-minibuffer-read-type (name &optional default)
 554   (let* ((default (or default
 555                       (mm-default-file-encoding name)
 556                       ;; Perhaps here we should check what the file
 557                       ;; looks like, and offer text/plain if it looks
 558                       ;; like text/plain.
 559                       "application/octet-stream"))
 560          (string (completing-read
 561                   (format "Content type (default %s): " default)
 562                   (mapcar
 563                    'list
 564                    (delete-duplicates
 565                     (nconc
 566                      (mapcar (lambda (m) (cdr m))
 567                              mailcap-mime-extensions)
 568                      (apply
 569                       'nconc
 570                       (mapcar
 571                        (lambda (l)
 572                          (delq nil
 573                                (mapcar
 574                                 (lambda (m)
 575                                   (let ((type (cdr (assq 'type (cdr m)))))
 576                                     (if (equal (cadr (split-string type "/"))
 577                                                "*")
 578                                         nil
 579                                       type)))
 580                                 (cdr l))))
 581                        mailcap-mime-data)))
 582                     :test 'equal)))))
 583     (if (not (equal string ""))
 584         string
 585       default)))
 586
 587 (defun mml-minibuffer-read-description ()
 588   (let ((description (read-string "One line description: ")))
 589     (when (string-match "\\`[ \t]*\\'" description)
 590       (setq description nil))
 591     description))
 592
 593 (defun mml-quote-region (beg end)
 594   "Quote the MML tags in the region."
 595   (interactive "r")
 596   (save-excursion
 597     (save-restriction
 598       ;; Temporarily narrow the region to defend from changes
 599       ;; invalidating END.
 600       (narrow-to-region beg end)
 601       (goto-char (point-min))
 602       ;; Quote parts.
 603       (while (re-search-forward
 604               "<#/?!*\\(multipart\\|part\\|external\\)" nil t)
 605         (goto-char (match-beginning 1))
 606         (insert "!")))))
 607
 608 (defun mml-insert-tag (name &rest plist)
 609   "Insert an MML tag described by NAME and PLIST."
 610   (when (symbolp name)
 611     (setq name (symbol-name name)))
 612   (insert "<#" name)
 613   (while plist
 614     (let ((key (pop plist))
 615           (value (pop plist)))
 616       (when value
 617         ;; Quote VALUE if it contains suspicious characters.
 618         (when (string-match "[\"\\~/* \t\n]" value)
 619           (setq value (prin1-to-string value)))
 620         (insert (format " %s=%s" key value)))))
 621   (insert ">\n<#/" name ">\n"))
 622
 623 ;;; Attachment functions.
 624
 625 (defun mml-attach-file (file &optional type description)
 626   "Attach a file to the outgoing MIME message.
 627 The file is not inserted or encoded until you send the message with
 628 `\\[message-send-and-exit]' or `\\[message-send]'.
 629
 630 FILE is the name of the file to attach.  TYPE is its content-type, a
 631 string of the form \"type/subtype\".  DESCRIPTION is a one-line
 632 description of the attachment."
 633   (interactive
 634    (let* ((file (mml-minibuffer-read-file "Attach file: "))
 635           (type (mml-minibuffer-read-type file))
 636           (description (mml-minibuffer-read-description)))
 637      (list file type description)))
 638   (mml-insert-tag 'part 'type type 'filename file 'disposition "attachment"
 639                   'description description))
 640
 641 (defun mml-attach-buffer (buffer &optional type description)
 642   "Attach a buffer to the outgoing MIME message.
 643 See `mml-attach-file' for details of operation."
 644   (interactive
 645    (let* ((buffer (read-buffer "Attach buffer: "))
 646           (type (mml-minibuffer-read-type buffer "text/plain"))
 647           (description (mml-minibuffer-read-description)))
 648      (list buffer type description)))
 649   (mml-insert-tag 'part 'type type 'buffer buffer 'disposition "attachment"
 650                   'description description))
 651
 652 (defun mml-attach-external (file &optional type description)
 653   "Attach an external file into the buffer.
 654 FILE is an ange-ftp/efs specification of the part location.
 655 TYPE is the MIME type to use."
 656   (interactive
 657    (let* ((file (mml-minibuffer-read-file "Attach external file: "))
 658           (type (mml-minibuffer-read-type file))
 659           (description (mml-minibuffer-read-description)))
 660      (list file type description)))
 661   (mml-insert-tag 'external 'type type 'name file 'disposition "attachment"
 662                   'description description))
 663
 664 (defun mml-insert-multipart (&optional type)
 665   (interactive (list (completing-read "Multipart type (default mixed): "
 666                      '(("mixed") ("alternative") ("digest") ("parallel")
 667                        ("signed") ("encrypted"))
 668                      nil nil "mixed")))
 669   (or type
 670       (setq type "mixed"))
 671   (mml-insert-tag "multipart" 'type type)
 672   (forward-line -1))
 673
 674 (defun mml-preview (&optional raw)
 675  "Display current buffer with Gnus, in a new buffer.
 676 If RAW, don't highlight the article."
 677  (interactive "P")
 678  (let ((buf (current-buffer)))
 679    (switch-to-buffer (get-buffer-create
 680                      (concat (if raw "*Raw MIME preview of "
 681                                "*MIME preview of ") (buffer-name))))
 682    (erase-buffer)
 683    (insert-buffer buf)
 684    (mml-to-mime)
 685    (unless raw
 686      (run-hooks 'gnus-article-decode-hook)
 687      (let ((gnus-newsgroup-name "dummy"))
 688       (gnus-article-prepare-display)))
 689    (fundamental-mode)
 690    (setq buffer-read-only t)
 691    (goto-char (point-min))))
 692
 693 (provide 'mml)
 694
 695 ;;; mml.el ends here