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