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