cgit.sxemacs.org Git - gnus/blob - lisp/mml.el

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