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 (member (car (split-string type "/")) '("text" "message"))
 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               (mm-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             (mm-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           (mm-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    ["Preview" mml-preview t]))
 516
 517 (defvar mml-mode nil
 518   "Minor mode for editing MML.")
 519
 520 (defun mml-mode (&optional arg)
 521   "Minor mode for editing MML.
 522
 523 \\{mml-mode-map}"
 524   (interactive "P")
 525   (if (not (set (make-local-variable 'mml-mode)
 526                 (if (null arg) (not mml-mode)
 527                   (> (prefix-numeric-value arg) 0))))
 528       nil
 529     (set (make-local-variable 'mml-mode) t)
 530     (unless (assq 'mml-mode minor-mode-alist)
 531       (push `(mml-mode " MML") minor-mode-alist))
 532     (unless (assq 'mml-mode minor-mode-map-alist)
 533       (push (cons 'mml-mode mml-mode-map)
 534             minor-mode-map-alist)))
 535   (run-hooks 'mml-mode-hook))
 536
 537 ;;;
 538 ;;; Helper functions for reading MIME stuff from the minibuffer and
 539 ;;; inserting stuff to the buffer.
 540 ;;;
 541
 542 (defun mml-minibuffer-read-file (prompt)
 543   (let ((file (read-file-name prompt nil nil t)))
 544     ;; Prevent some common errors.  This is inspired by similar code in
 545     ;; VM.
 546     (when (file-directory-p file)
 547       (error "%s is a directory, cannot attach" file))
 548     (unless (file-exists-p file)
 549       (error "No such file: %s" file))
 550     (unless (file-readable-p file)
 551       (error "Permission denied: %s" file))
 552     file))
 553
 554 (defun mml-minibuffer-read-type (name &optional default)
 555   (let* ((default (or default
 556                       (mm-default-file-encoding name)
 557                       ;; Perhaps here we should check what the file
 558                       ;; looks like, and offer text/plain if it looks
 559                       ;; like text/plain.
 560                       "application/octet-stream"))
 561          (string (completing-read
 562                   (format "Content type (default %s): " default)
 563                   (mapcar
 564                    'list
 565                    (delete-duplicates
 566                     (nconc
 567                      (mapcar (lambda (m) (cdr m))
 568                              mailcap-mime-extensions)
 569                      (apply
 570                       'nconc
 571                       (mapcar
 572                        (lambda (l)
 573                          (delq nil
 574                                (mapcar
 575                                 (lambda (m)
 576                                   (let ((type (cdr (assq 'type (cdr m)))))
 577                                     (if (equal (cadr (split-string type "/"))
 578                                                "*")
 579                                         nil
 580                                       type)))
 581                                 (cdr l))))
 582                        mailcap-mime-data)))
 583                     :test 'equal)))))
 584     (if (not (equal string ""))
 585         string
 586       default)))
 587
 588 (defun mml-minibuffer-read-description ()
 589   (let ((description (read-string "One line description: ")))
 590     (when (string-match "\\`[ \t]*\\'" description)
 591       (setq description nil))
 592     description))
 593
 594 (defun mml-quote-region (beg end)
 595   "Quote the MML tags in the region."
 596   (interactive "r")
 597   (save-excursion
 598     (save-restriction
 599       ;; Temporarily narrow the region to defend from changes
 600       ;; invalidating END.
 601       (narrow-to-region beg end)
 602       (goto-char (point-min))
 603       ;; Quote parts.
 604       (while (re-search-forward
 605               "<#/?!*\\(multipart\\|part\\|external\\)" nil t)
 606         (goto-char (match-beginning 1))
 607         (insert "!")))))
 608
 609 (defun mml-insert-tag (name &rest plist)
 610   "Insert an MML tag described by NAME and PLIST."
 611   (when (symbolp name)
 612     (setq name (symbol-name name)))
 613   (insert "<#" name)
 614   (while plist
 615     (let ((key (pop plist))
 616           (value (pop plist)))
 617       (when value
 618         ;; Quote VALUE if it contains suspicious characters.
 619         (when (string-match "[\"\\~/* \t\n]" value)
 620           (setq value (prin1-to-string value)))
 621         (insert (format " %s=%s" key value)))))
 622   (insert ">\n<#/" name ">\n"))
 623
 624 ;;; Attachment functions.
 625
 626 (defun mml-attach-file (file &optional type description)
 627   "Attach a file to the outgoing MIME message.
 628 The file is not inserted or encoded until you send the message with
 629 `\\[message-send-and-exit]' or `\\[message-send]'.
 630
 631 FILE is the name of the file to attach.  TYPE is its content-type, a
 632 string of the form \"type/subtype\".  DESCRIPTION is a one-line
 633 description of the attachment."
 634   (interactive
 635    (let* ((file (mml-minibuffer-read-file "Attach file: "))
 636           (type (mml-minibuffer-read-type file))
 637           (description (mml-minibuffer-read-description)))
 638      (list file type description)))
 639   (mml-insert-tag 'part 'type type 'filename file 'disposition "attachment"
 640                   'description description))
 641
 642 (defun mml-attach-buffer (buffer &optional type description)
 643   "Attach a buffer to the outgoing MIME message.
 644 See `mml-attach-file' for details of operation."
 645   (interactive
 646    (let* ((buffer (read-buffer "Attach buffer: "))
 647           (type (mml-minibuffer-read-type buffer "text/plain"))
 648           (description (mml-minibuffer-read-description)))
 649      (list buffer type description)))
 650   (mml-insert-tag 'part 'type type 'buffer buffer 'disposition "attachment"
 651                   'description description))
 652
 653 (defun mml-attach-external (file &optional type description)
 654   "Attach an external file into the buffer.
 655 FILE is an ange-ftp/efs specification of the part location.
 656 TYPE is the MIME type to use."
 657   (interactive
 658    (let* ((file (mml-minibuffer-read-file "Attach external file: "))
 659           (type (mml-minibuffer-read-type file))
 660           (description (mml-minibuffer-read-description)))
 661      (list file type description)))
 662   (mml-insert-tag 'external 'type type 'name file 'disposition "attachment"
 663                   'description description))
 664
 665 (defun mml-insert-multipart (&optional type)
 666   (interactive (list (completing-read "Multipart type (default mixed): "
 667                      '(("mixed") ("alternative") ("digest") ("parallel")
 668                        ("signed") ("encrypted"))
 669                      nil nil "mixed")))
 670   (or type
 671       (setq type "mixed"))
 672   (mml-insert-tag "multipart" 'type type)
 673   (forward-line -1))
 674
 675 (defun mml-preview (&optional raw)
 676  "Display current buffer with Gnus, in a new buffer.
 677 If RAW, don't highlight the article."
 678  (interactive "P")
 679  (let ((buf (current-buffer)))
 680    (switch-to-buffer (get-buffer-create
 681                      (concat (if raw "*Raw MIME preview of "
 682                                "*MIME preview of ") (buffer-name))))
 683    (erase-buffer)
 684    (insert-buffer buf)
 685    (mml-to-mime)
 686    (unless raw
 687      (run-hooks 'gnus-article-decode-hook)
 688      (let ((gnus-newsgroup-name "dummy"))
 689       (gnus-article-prepare-display)))
 690    (fundamental-mode)
 691    (setq buffer-read-only t)
 692    (goto-char (point-min))))
 693
 694 (defun mml-validate ()
 695   "Validate the current MML document."
 696   (interactive)
 697   (mml-parse))
 698
 699 (provide 'mml)
 700
 701 ;;; mml.el ends here