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

   1 ;;; mml.el --- A package for parsing and validating MML documents
   2
   3 ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
   4 ;;   2005, 2006, 2007, 2008 Free Software Foundation, Inc.
   5
   6 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   7 ;; This file is part of GNU Emacs.
   8
   9 ;; GNU Emacs is free software: you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation, either version 3 of the License, or
  12 ;; (at your option) any later version.
  13
  14 ;; GNU Emacs is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  21
  22 ;;; Commentary:
  23
  24 ;;; Code:
  25
  26 ;; For Emacs < 22.2.
  27 (eval-and-compile
  28   (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
  29
  30 (require 'mm-util)
  31 (require 'mm-bodies)
  32 (require 'mm-encode)
  33 (require 'mm-decode)
  34 (require 'mml-sec)
  35 (eval-when-compile (require 'cl))
  36
  37 (eval-and-compile
  38   (autoload 'message-make-message-id "message")
  39   (autoload 'gnus-setup-posting-charset "gnus-msg")
  40   (autoload 'gnus-make-local-hook "gnus-util")
  41   (autoload 'message-fetch-field "message")
  42   (autoload 'message-mark-active-p "message")
  43   (autoload 'message-info "message")
  44   (autoload 'fill-flowed-encode "flow-fill")
  45   (autoload 'message-posting-charset "message")
  46   (autoload 'dnd-get-local-file-name "dnd"))
  47
  48 (autoload 'message-options-set    "message")
  49 (autoload 'message-narrow-to-head "message")
  50 (autoload 'message-in-body-p      "message")
  51 (autoload 'message-mail-p         "message")
  52
  53 (defvar gnus-article-mime-handles)
  54 (defvar gnus-mouse-2)
  55 (defvar gnus-newsrc-hashtb)
  56 (defvar message-default-charset)
  57 (defvar message-deletable-headers)
  58 (defvar message-options)
  59 (defvar message-posting-charset)
  60 (defvar message-required-mail-headers)
  61 (defvar message-required-news-headers)
  62 (defvar dnd-protocol-alist)
  63 (defvar mml-dnd-protocol-alist)
  64
  65 (defcustom mml-content-type-parameters
  66   '(name access-type expiration size permission format)
  67   "*A list of acceptable parameters in MML tag.
  68 These parameters are generated in Content-Type header if exists."
  69   :version "22.1"
  70   :type '(repeat (symbol :tag "Parameter"))
  71   :group 'message)
  72
  73 (defcustom mml-content-disposition-parameters
  74   '(filename creation-date modification-date read-date)
  75   "*A list of acceptable parameters in MML tag.
  76 These parameters are generated in Content-Disposition header if exists."
  77   :version "22.1"
  78   :type '(repeat (symbol :tag "Parameter"))
  79   :group 'message)
  80
  81 (defcustom mml-content-disposition-alist
  82   '((text (rtf . "attachment") (t . "inline"))
  83     (t . "attachment"))
  84   "Alist of MIME types or regexps matching file names and default dispositions.
  85 Each element should be one of the following three forms:
  86
  87   (REGEXP . DISPOSITION)
  88   (SUPERTYPE (SUBTYPE . DISPOSITION) (SUBTYPE . DISPOSITION)...)
  89   (TYPE . DISPOSITION)
  90
  91 Where REGEXP is a string which matches the file name (if any) of an
  92 attachment, SUPERTYPE, SUBTYPE and TYPE should be symbols which are a
  93 MIME supertype (e.g., text), a MIME subtype (e.g., plain) and a MIME
  94 type (e.g., text/plain) respectively, and DISPOSITION should be either
  95 the string \"attachment\" or the string \"inline\".  The value t for
  96 SUPERTYPE, SUBTYPE or TYPE matches any of those types.  The first
  97 match found will be used."
  98   :version "23.1" ;; No Gnus
  99   :type (let ((dispositions '(radio :format "DISPOSITION: %v"
 100                                     :value "attachment"
 101                                     (const :format "%v " "attachment")
 102                                     (const :format "%v\n" "inline"))))
 103           `(repeat
 104             :offset 0
 105             (choice :format "%[Value Menu%]%v"
 106                     (cons :tag "(REGEXP . DISPOSITION)" :extra-offset 4
 107                           (regexp :tag "REGEXP" :value ".*")
 108                           ,dispositions)
 109                     (cons :tag "(SUPERTYPE (SUBTYPE . DISPOSITION)...)"
 110                           :indent 0
 111                           (symbol :tag "    SUPERTYPE" :value text)
 112                           (repeat :format "%v%i\n" :offset 0 :extra-offset 4
 113                                   (cons :format "%v" :extra-offset 5
 114                                         (symbol :tag "SUBTYPE" :value t)
 115                                         ,dispositions)))
 116                     (cons :tag "(TYPE . DISPOSITION)" :extra-offset 4
 117                           (symbol :tag "TYPE" :value t)
 118                           ,dispositions))))
 119   :group 'message)
 120
 121 (defcustom mml-insert-mime-headers-always nil
 122   "If non-nil, always put Content-Type: text/plain at top of empty parts.
 123 It is necessary to work against a bug in certain clients."
 124   :version "22.1"
 125   :type 'boolean
 126   :group 'message)
 127
 128 (defvar mml-tweak-type-alist nil
 129   "A list of (TYPE . FUNCTION) for tweaking MML parts.
 130 TYPE is a string containing a regexp to match the MIME type.  FUNCTION
 131 is a Lisp function which is called with the MML handle to tweak the
 132 part.  This variable is used only when no TWEAK parameter exists in
 133 the MML handle.")
 134
 135 (defvar mml-tweak-function-alist nil
 136   "A list of (NAME . FUNCTION) for tweaking MML parts.
 137 NAME is a string containing the name of the TWEAK parameter in the MML
 138 handle.  FUNCTION is a Lisp function which is called with the MML
 139 handle to tweak the part.")
 140
 141 (defvar mml-tweak-sexp-alist
 142   '((mml-externalize-attachments . mml-tweak-externalize-attachments))
 143   "A list of (SEXP . FUNCTION) for tweaking MML parts.
 144 SEXP is an s-expression.  If the evaluation of SEXP is non-nil, FUNCTION
 145 is called.  FUNCTION is a Lisp function which is called with the MML
 146 handle to tweak the part.")
 147
 148 (defvar mml-externalize-attachments nil
 149   "*If non-nil, local-file attachments are generated as external parts.")
 150
 151 (defvar mml-generate-multipart-alist nil
 152   "*Alist of multipart generation functions.
 153 Each entry has the form (NAME . FUNCTION), where
 154 NAME is a string containing the name of the part (without the
 155 leading \"/multipart/\"),
 156 FUNCTION is a Lisp function which is called to generate the part.
 157
 158 The Lisp function has to supply the appropriate MIME headers and the
 159 contents of this part.")
 160
 161 (defvar mml-syntax-table
 162   (let ((table (copy-syntax-table emacs-lisp-mode-syntax-table)))
 163     (modify-syntax-entry ?\\ "/" table)
 164     (modify-syntax-entry ?< "(" table)
 165     (modify-syntax-entry ?> ")" table)
 166     (modify-syntax-entry ?@ "w" table)
 167     (modify-syntax-entry ?/ "w" table)
 168     (modify-syntax-entry ?= " " table)
 169     (modify-syntax-entry ?* " " table)
 170     (modify-syntax-entry ?\; " " table)
 171     (modify-syntax-entry ?\' " " table)
 172     table))
 173
 174 (defvar mml-boundary-function 'mml-make-boundary
 175   "A function called to suggest a boundary.
 176 The function may be called several times, and should try to make a new
 177 suggestion each time.  The function is called with one parameter,
 178 which is a number that says how many times the function has been
 179 called for this message.")
 180
 181 (defvar mml-confirmation-set nil
 182   "A list of symbols, each of which disables some warning.
 183 `unknown-encoding': always send messages contain characters with
 184 unknown encoding; `use-ascii': always use ASCII for those characters
 185 with unknown encoding; `multipart': always send messages with more than
 186 one charsets.")
 187
 188 (defvar mml-generate-default-type "text/plain"
 189   "Content type by which the Content-Type header can be omitted.
 190 The Content-Type header will not be put in the MIME part if the type
 191 equals the value and there's no parameter (e.g. charset, format, etc.)
 192 and `mml-insert-mime-headers-always' is nil.  The value will be bound
 193 to \"message/rfc822\" when encoding an article to be forwarded as a MIME
 194 part.  This is for the internal use, you should never modify the value.")
 195
 196 (defvar mml-buffer-list nil)
 197
 198 (defun mml-generate-new-buffer (name)
 199   (let ((buf (generate-new-buffer name)))
 200     (push buf mml-buffer-list)
 201     buf))
 202
 203 (defun mml-destroy-buffers ()
 204   (let (kill-buffer-hook)
 205     (mapc 'kill-buffer mml-buffer-list)
 206     (setq mml-buffer-list nil)))
 207
 208 (defun mml-parse ()
 209   "Parse the current buffer as an MML document."
 210   (save-excursion
 211     (goto-char (point-min))
 212     (with-syntax-table mml-syntax-table
 213       (mml-parse-1))))
 214
 215 (defun mml-parse-1 ()
 216   "Parse the current buffer as an MML document."
 217   (let (struct tag point contents charsets warn use-ascii no-markup-p raw)
 218     (while (and (not (eobp))
 219                 (not (looking-at "<#/multipart")))
 220       (cond
 221        ((looking-at "<#secure")
 222         ;; The secure part is essentially a meta-meta tag, which
 223         ;; expands to either a part tag if there are no other parts in
 224         ;; the document or a multipart tag if there are other parts
 225         ;; included in the message
 226         (let* (secure-mode
 227                (taginfo (mml-read-tag))
 228                (keyfile (cdr (assq 'keyfile taginfo)))
 229                (certfile (cdr (assq 'certfile taginfo)))
 230                (recipients (cdr (assq 'recipients taginfo)))
 231                (sender (cdr (assq 'sender taginfo)))
 232                (location (cdr (assq 'tag-location taginfo)))
 233                (mode (cdr (assq 'mode taginfo)))
 234                (method (cdr (assq 'method taginfo)))
 235                tags)
 236           (save-excursion
 237             (if (re-search-forward
 238                  "<#/?\\(multipart\\|part\\|external\\|mml\\)." nil t)
 239                 (setq secure-mode "multipart")
 240               (setq secure-mode "part")))
 241           (save-excursion
 242             (goto-char location)
 243             (re-search-forward "<#secure[^\n]*>\n"))
 244           (delete-region (match-beginning 0) (match-end 0))
 245           (cond ((string= mode "sign")
 246                  (setq tags (list "sign" method)))
 247                 ((string= mode "encrypt")
 248                  (setq tags (list "encrypt" method)))
 249                 ((string= mode "signencrypt")
 250                  (setq tags (list "sign" method "encrypt" method))))
 251           (eval `(mml-insert-tag ,secure-mode
 252                                  ,@tags
 253                                  ,(if keyfile "keyfile")
 254                                  ,keyfile
 255                                  ,(if certfile "certfile")
 256                                  ,certfile
 257                                  ,(if recipients "recipients")
 258                                  ,recipients
 259                                  ,(if sender "sender")
 260                                  ,sender))
 261           ;; restart the parse
 262           (goto-char location)))
 263        ((looking-at "<#multipart")
 264         (push (nconc (mml-read-tag) (mml-parse-1)) struct))
 265        ((looking-at "<#external")
 266         (push (nconc (mml-read-tag) (list (cons 'contents (mml-read-part))))
 267               struct))
 268        (t
 269         (if (or (looking-at "<#part") (looking-at "<#mml"))
 270             (setq tag (mml-read-tag)
 271                   no-markup-p nil
 272                   warn nil)
 273           (setq tag (list 'part '(type . "text/plain"))
 274                 no-markup-p t
 275                 warn t))
 276         (setq raw (cdr (assq 'raw tag))
 277               point (point)
 278               contents (mml-read-part (eq 'mml (car tag)))
 279               charsets (cond
 280                         (raw nil)
 281                         ((assq 'charset tag)
 282                          (list
 283                           (intern (downcase (cdr (assq 'charset tag))))))
 284                         (t
 285                          (mm-find-mime-charset-region point (point)
 286                                                       mm-hack-charsets))))
 287         (when (and (not raw) (memq nil charsets))
 288           (if (or (memq 'unknown-encoding mml-confirmation-set)
 289                   (message-options-get 'unknown-encoding)
 290                   (and (y-or-n-p "\
 291 Message contains characters with unknown encoding.  Really send? ")
 292                        (message-options-set 'unknown-encoding t)))
 293               (if (setq use-ascii
 294                         (or (memq 'use-ascii mml-confirmation-set)
 295                             (message-options-get 'use-ascii)
 296                             (and (y-or-n-p "Use ASCII as charset? ")
 297                                  (message-options-set 'use-ascii t))))
 298                   (setq charsets (delq nil charsets))
 299                 (setq warn nil))
 300             (error "Edit your message to remove those characters")))
 301         (if (or raw
 302                 (eq 'mml (car tag))
 303                 (< (length charsets) 2))
 304             (if (or (not no-markup-p)
 305                     (string-match "[^ \t\r\n]" contents))
 306                 ;; Don't create blank parts.
 307                 (push (nconc tag (list (cons 'contents contents)))
 308                       struct))
 309           (let ((nstruct (mml-parse-singlepart-with-multiple-charsets
 310                           tag point (point) use-ascii)))
 311             (when (and warn
 312                        (not (memq 'multipart mml-confirmation-set))
 313                        (not (message-options-get 'multipart))
 314                        (not (and (y-or-n-p (format "\
 315 A message part needs to be split into %d charset parts.  Really send? "
 316                                                    (length nstruct)))
 317                                  (message-options-set 'multipart t))))
 318               (error "Edit your message to use only one charset"))
 319             (setq struct (nconc nstruct struct)))))))
 320     (unless (eobp)
 321       (forward-line 1))
 322     (nreverse struct)))
 323
 324 (defun mml-parse-singlepart-with-multiple-charsets
 325   (orig-tag beg end &optional use-ascii)
 326   (save-excursion
 327     (save-restriction
 328       (narrow-to-region beg end)
 329       (goto-char (point-min))
 330       (let ((current (or (mm-mime-charset (mm-charset-after))
 331                          (and use-ascii 'us-ascii)))
 332             charset struct space newline paragraph)
 333         (while (not (eobp))
 334           (setq charset (mm-mime-charset (mm-charset-after)))
 335           (cond
 336            ;; The charset remains the same.
 337            ((eq charset 'us-ascii))
 338            ((or (and use-ascii (not charset))
 339                 (eq charset current))
 340             (setq space nil
 341                   newline nil
 342                   paragraph nil))
 343            ;; The initial charset was ascii.
 344            ((eq current 'us-ascii)
 345             (setq current charset
 346                   space nil
 347                   newline nil
 348                   paragraph nil))
 349            ;; We have a change in charsets.
 350            (t
 351             (push (append
 352                    orig-tag
 353                    (list (cons 'contents
 354                                (buffer-substring-no-properties
 355                                 beg (or paragraph newline space (point))))))
 356                   struct)
 357             (setq beg (or paragraph newline space (point))
 358                   current charset
 359                   space nil
 360                   newline nil
 361                   paragraph nil)))
 362           ;; Compute places where it might be nice to break the part.
 363           (cond
 364            ((memq (following-char) '(?  ?\t))
 365             (setq space (1+ (point))))
 366            ((and (eq (following-char) ?\n)
 367                  (not (bobp))
 368                  (eq (char-after (1- (point))) ?\n))
 369             (setq paragraph (point)))
 370            ((eq (following-char) ?\n)
 371             (setq newline (1+ (point)))))
 372           (forward-char 1))
 373         ;; Do the final part.
 374         (unless (= beg (point))
 375           (push (append orig-tag
 376                         (list (cons 'contents
 377                                     (buffer-substring-no-properties
 378                                      beg (point)))))
 379                 struct))
 380         struct))))
 381
 382 (defun mml-read-tag ()
 383   "Read a tag and return the contents."
 384   (let ((orig-point (point))
 385         contents name elem val)
 386     (forward-char 2)
 387     (setq name (buffer-substring-no-properties
 388                 (point) (progn (forward-sexp 1) (point))))
 389     (skip-chars-forward " \t\n")
 390     (while (not (looking-at ">[ \t]*\n?"))
 391       (setq elem (buffer-substring-no-properties
 392                   (point) (progn (forward-sexp 1) (point))))
 393       (skip-chars-forward "= \t\n")
 394       (setq val (buffer-substring-no-properties
 395                  (point) (progn (forward-sexp 1) (point))))
 396       (when (string-match "^\"\\(.*\\)\"$" val)
 397         (setq val (match-string 1 val)))
 398       (push (cons (intern elem) val) contents)
 399       (skip-chars-forward " \t\n"))
 400     (goto-char (match-end 0))
 401     ;; Don't skip the leading space.
 402     ;;(skip-chars-forward " \t\n")
 403     ;; Put the tag location into the returned contents
 404     (setq contents (append (list (cons 'tag-location orig-point)) contents))
 405     (cons (intern name) (nreverse contents))))
 406
 407 (defun mml-buffer-substring-no-properties-except-hard-newlines (start end)
 408   (let ((str (buffer-substring-no-properties start end))
 409         (bufstart start) tmp)
 410     (while (setq tmp (text-property-any start end 'hard 't))
 411       (set-text-properties (- tmp bufstart) (- tmp bufstart -1)
 412                            '(hard t) str)
 413       (setq start (1+ tmp)))
 414     str))
 415
 416 (defun mml-read-part (&optional mml)
 417   "Return the buffer up till the next part, multipart or closing part or multipart.
 418 If MML is non-nil, return the buffer up till the correspondent mml tag."
 419   (let ((beg (point)) (count 1))
 420     ;; If the tag ended at the end of the line, we go to the next line.
 421     (when (looking-at "[ \t]*\n")
 422       (forward-line 1))
 423     (if mml
 424         (progn
 425           (while (and (> count 0) (not (eobp)))
 426             (if (re-search-forward "<#\\(/\\)?mml." nil t)
 427                 (setq count (+ count (if (match-beginning 1) -1 1)))
 428               (goto-char (point-max))))
 429           (mml-buffer-substring-no-properties-except-hard-newlines
 430            beg (if (> count 0)
 431                    (point)
 432                  (match-beginning 0))))
 433       (if (re-search-forward
 434            "<#\\(/\\)?\\(multipart\\|part\\|external\\|mml\\)." nil t)
 435           (prog1
 436               (mml-buffer-substring-no-properties-except-hard-newlines
 437                beg (match-beginning 0))
 438             (if (or (not (match-beginning 1))
 439                     (equal (match-string 2) "multipart"))
 440                 (goto-char (match-beginning 0))
 441               (when (looking-at "[ \t]*\n")
 442                 (forward-line 1))))
 443         (mml-buffer-substring-no-properties-except-hard-newlines
 444          beg (goto-char (point-max)))))))
 445
 446 (defvar mml-boundary nil)
 447 (defvar mml-base-boundary "-=-=")
 448 (defvar mml-multipart-number 0)
 449
 450 (defun mml-generate-mime ()
 451   "Generate a MIME message based on the current MML document."
 452   (let ((cont (mml-parse))
 453         (mml-multipart-number mml-multipart-number))
 454     (if (not cont)
 455         nil
 456       (mm-with-multibyte-buffer
 457         (if (and (consp (car cont))
 458                  (= (length cont) 1))
 459             (mml-generate-mime-1 (car cont))
 460           (mml-generate-mime-1 (nconc (list 'multipart '(type . "mixed"))
 461                                       cont)))
 462         (buffer-string)))))
 463
 464 (defun mml-generate-mime-1 (cont)
 465   (let ((mm-use-ultra-safe-encoding
 466          (or mm-use-ultra-safe-encoding (assq 'sign cont))))
 467     (save-restriction
 468       (narrow-to-region (point) (point))
 469       (mml-tweak-part cont)
 470       (cond
 471        ((or (eq (car cont) 'part) (eq (car cont) 'mml))
 472         (let* ((raw (cdr (assq 'raw cont)))
 473                (filename (cdr (assq 'filename cont)))
 474                (type (or (cdr (assq 'type cont))
 475                          (if filename
 476                              (or (mm-default-file-encoding filename)
 477                                  "application/octet-stream")
 478                            "text/plain")))
 479                (charset (cdr (assq 'charset cont)))
 480                (coding (mm-charset-to-coding-system charset))
 481                encoding flowed coded)
 482           (cond ((eq coding 'ascii)
 483                  (setq charset nil
 484                        coding nil))
 485                 (charset
 486                  (setq charset (intern (downcase charset)))))
 487           (if (and (not raw)
 488                    (member (car (split-string type "/")) '("text" "message")))
 489               (progn
 490                 (with-temp-buffer
 491                   (cond
 492                    ((cdr (assq 'buffer cont))
 493                     (insert-buffer-substring (cdr (assq 'buffer cont))))
 494                    ((and filename
 495                          (not (equal (cdr (assq 'nofile cont)) "yes")))
 496                     (let ((coding-system-for-read coding))
 497                       (mm-insert-file-contents filename)))
 498                    ((eq 'mml (car cont))
 499                     (insert (cdr (assq 'contents cont))))
 500                    (t
 501                     (save-restriction
 502                       (narrow-to-region (point) (point))
 503                       (insert (cdr (assq 'contents cont)))
 504                       ;; Remove quotes from quoted tags.
 505                       (goto-char (point-min))
 506                       (while (re-search-forward
 507                               "<#!+/?\\(part\\|multipart\\|external\\|mml\\)"
 508                               nil t)
 509                         (delete-region (+ (match-beginning 0) 2)
 510                                        (+ (match-beginning 0) 3))))))
 511                   (cond
 512                    ((eq (car cont) 'mml)
 513                     (let ((mml-boundary (mml-compute-boundary cont))
 514                           ;; It is necessary for the case where this
 515                           ;; function is called recursively since
 516                           ;; `m-g-d-t' will be bound to "message/rfc822"
 517                           ;; when encoding an article to be forwarded.
 518                           (mml-generate-default-type "text/plain"))
 519                       (mml-to-mime))
 520                     (let ((mm-7bit-chars (concat mm-7bit-chars "\x1b")))
 521                       ;; ignore 0x1b, it is part of iso-2022-jp
 522                       (setq encoding (mm-body-7-or-8))))
 523                    ((string= (car (split-string type "/")) "message")
 524                     (let ((mm-7bit-chars (concat mm-7bit-chars "\x1b")))
 525                       ;; ignore 0x1b, it is part of iso-2022-jp
 526                       (setq encoding (mm-body-7-or-8))))
 527                    (t
 528                     ;; Only perform format=flowed filling on text/plain
 529                     ;; parts where there either isn't a format parameter
 530                     ;; in the mml tag or it says "flowed" and there
 531                     ;; actually are hard newlines in the text.
 532                     (let (use-hard-newlines)
 533                       (when (and (string= type "text/plain")
 534                                  (not (string= (cdr (assq 'sign cont)) "pgp"))
 535                                  (or (null (assq 'format cont))
 536                                      (string= (cdr (assq 'format cont))
 537                                               "flowed"))
 538                                  (setq use-hard-newlines
 539                                        (text-property-any
 540                                         (point-min) (point-max) 'hard 't)))
 541                         (fill-flowed-encode)
 542                         ;; Indicate that `mml-insert-mime-headers' should
 543                         ;; insert a "; format=flowed" string unless the
 544                         ;; user has already specified it.
 545                         (setq flowed (null (assq 'format cont)))))
 546                     ;; Prefer `utf-8' for text/calendar parts.
 547                     (if (or charset
 548                             (not (string= type "text/calendar")))
 549                         (setq charset (mm-encode-body charset))
 550                       (let ((mm-coding-system-priorities
 551                              (cons 'utf-8 mm-coding-system-priorities)))
 552                         (setq charset (mm-encode-body))))
 553                     (setq encoding (mm-body-encoding
 554                                     charset (cdr (assq 'encoding cont))))))
 555                   (setq coded (buffer-string)))
 556                 (mml-insert-mime-headers cont type charset encoding flowed)
 557                 (insert "\n")
 558                 (insert coded))
 559             (mm-with-unibyte-buffer
 560               (cond
 561                ((cdr (assq 'buffer cont))
 562                 (insert (mm-string-as-unibyte
 563                          (with-current-buffer (cdr (assq 'buffer cont))
 564                            (buffer-string)))))
 565                ((and filename
 566                      (not (equal (cdr (assq 'nofile cont)) "yes")))
 567                 (let ((coding-system-for-read mm-binary-coding-system))
 568                   (mm-insert-file-contents filename nil nil nil nil t))
 569                 (unless charset
 570                   (setq charset (mm-coding-system-to-mime-charset
 571                                  (mm-find-buffer-file-coding-system
 572                                   filename)))))
 573                (t
 574                 (let ((contents (cdr (assq 'contents cont))))
 575                   (if (if (featurep 'xemacs)
 576                           (string-match "[^\000-\377]" contents)
 577                         (mm-multibyte-string-p contents))
 578                       (progn
 579                         (mm-enable-multibyte)
 580                         (insert contents)
 581                         (unless raw
 582                           (setq charset (mm-encode-body charset))))
 583                     (insert contents)))))
 584               (setq encoding (mm-encode-buffer type)
 585                     coded (mm-string-as-multibyte (buffer-string))))
 586             (mml-insert-mime-headers cont type charset encoding nil)
 587             (insert "\n" coded))))
 588        ((eq (car cont) 'external)
 589         (insert "Content-Type: message/external-body")
 590         (let ((parameters (mml-parameter-string
 591                            cont '(expiration size permission)))
 592               (name (cdr (assq 'name cont)))
 593               (url (cdr (assq 'url cont))))
 594           (when name
 595             (setq name (mml-parse-file-name name))
 596             (if (stringp name)
 597                 (mml-insert-parameter
 598                  (mail-header-encode-parameter "name" name)
 599                  "access-type=local-file")
 600               (mml-insert-parameter
 601                (mail-header-encode-parameter
 602                 "name" (file-name-nondirectory (nth 2 name)))
 603                (mail-header-encode-parameter "site" (nth 1 name))
 604                (mail-header-encode-parameter
 605                 "directory" (file-name-directory (nth 2 name))))
 606               (mml-insert-parameter
 607                (concat "access-type="
 608                        (if (member (nth 0 name) '("ftp@" "anonymous@"))
 609                            "anon-ftp"
 610                          "ftp")))))
 611           (when url
 612             (mml-insert-parameter
 613              (mail-header-encode-parameter "url" url)
 614              "access-type=url"))
 615           (when parameters
 616             (mml-insert-parameter-string
 617              cont '(expiration size permission)))
 618           (insert "\n\n")
 619           (insert "Content-Type: "
 620                   (or (cdr (assq 'type cont))
 621                       (if name
 622                           (or (mm-default-file-encoding name)
 623                               "application/octet-stream")
 624                         "text/plain"))
 625                   "\n")
 626           (insert "Content-ID: " (message-make-message-id) "\n")
 627           (insert "Content-Transfer-Encoding: "
 628                   (or (cdr (assq 'encoding cont)) "binary"))
 629           (insert "\n\n")
 630           (insert (or (cdr (assq 'contents cont))))
 631           (insert "\n")))
 632        ((eq (car cont) 'multipart)
 633         (let* ((type (or (cdr (assq 'type cont)) "mixed"))
 634                (mml-generate-default-type (if (equal type "digest")
 635                                               "message/rfc822"
 636                                             "text/plain"))
 637                (handler (assoc type mml-generate-multipart-alist)))
 638           (if handler
 639               (funcall (cdr handler) cont)
 640             ;; No specific handler.  Use default one.
 641             (let ((mml-boundary (mml-compute-boundary cont)))
 642               (insert (format "Content-Type: multipart/%s; boundary=\"%s\""
 643                               type mml-boundary)
 644                       (if (cdr (assq 'start cont))
 645                           (format "; start=\"%s\"\n" (cdr (assq 'start cont)))
 646                         "\n"))
 647               (let ((cont cont) part)
 648                 (while (setq part (pop cont))
 649                   ;; Skip `multipart' and attributes.
 650                   (when (and (consp part) (consp (cdr part)))
 651                     (insert "\n--" mml-boundary "\n")
 652                     (mml-generate-mime-1 part)
 653                     (goto-char (point-max)))))
 654               (insert "\n--" mml-boundary "--\n")))))
 655        (t
 656         (error "Invalid element: %S" cont)))
 657       ;; handle sign & encrypt tags in a semi-smart way.
 658       (let ((sign-item (assoc (cdr (assq 'sign cont)) mml-sign-alist))
 659             (encrypt-item (assoc (cdr (assq 'encrypt cont))
 660                                  mml-encrypt-alist))
 661             sender recipients)
 662         (when (or sign-item encrypt-item)
 663           (when (setq sender (cdr (assq 'sender cont)))
 664             (message-options-set 'mml-sender sender)
 665             (message-options-set 'message-sender sender))
 666           (if (setq recipients (cdr (assq 'recipients cont)))
 667               (message-options-set 'message-recipients recipients))
 668           (let ((style (mml-signencrypt-style
 669                         (first (or sign-item encrypt-item)))))
 670             ;; check if: we're both signing & encrypting, both methods
 671             ;; are the same (why would they be different?!), and that
 672             ;; the signencrypt style allows for combined operation.
 673             (if (and sign-item encrypt-item (equal (first sign-item)
 674                                                    (first encrypt-item))
 675                      (equal style 'combined))
 676                 (funcall (nth 1 encrypt-item) cont t)
 677               ;; otherwise, revert to the old behavior.
 678               (when sign-item
 679                 (funcall (nth 1 sign-item) cont))
 680               (when encrypt-item
 681                 (funcall (nth 1 encrypt-item) cont)))))))))
 682
 683 (defun mml-compute-boundary (cont)
 684   "Return a unique boundary that does not exist in CONT."
 685   (let ((mml-boundary (funcall mml-boundary-function
 686                                (incf mml-multipart-number))))
 687     ;; This function tries again and again until it has found
 688     ;; a unique boundary.
 689     (while (not (catch 'not-unique
 690                   (mml-compute-boundary-1 cont))))
 691     mml-boundary))
 692
 693 (defun mml-compute-boundary-1 (cont)
 694   (let (filename)
 695     (cond
 696      ((eq (car cont) 'part)
 697       (with-temp-buffer
 698         (cond
 699          ((cdr (assq 'buffer cont))
 700           (insert-buffer-substring (cdr (assq 'buffer cont))))
 701          ((and (setq filename (cdr (assq 'filename cont)))
 702                (not (equal (cdr (assq 'nofile cont)) "yes")))
 703           (mm-insert-file-contents filename nil nil nil nil t))
 704          (t
 705           (insert (cdr (assq 'contents cont)))))
 706         (goto-char (point-min))
 707         (when (re-search-forward (concat "^--" (regexp-quote mml-boundary))
 708                                  nil t)
 709           (setq mml-boundary (funcall mml-boundary-function
 710                                       (incf mml-multipart-number)))
 711           (throw 'not-unique nil))))
 712      ((eq (car cont) 'multipart)
 713       (mapc 'mml-compute-boundary-1 (cddr cont))))
 714     t))
 715
 716 (defun mml-make-boundary (number)
 717   (concat (make-string (% number 60) ?=)
 718           (if (> number 17)
 719               (format "%x" number)
 720             "")
 721           mml-base-boundary))
 722
 723 (defun mml-content-disposition (type &optional filename)
 724   "Return a default disposition name suitable to TYPE or FILENAME."
 725   (let ((defs mml-content-disposition-alist)
 726         disposition def types)
 727     (while (and (not disposition) defs)
 728       (setq def (pop defs))
 729       (cond ((stringp (car def))
 730              (when (and filename
 731                         (string-match (car def) filename))
 732                (setq disposition (cdr def))))
 733             ((consp (cdr def))
 734              (when (string= (car (setq types (split-string type "/")))
 735                             (car def))
 736                (setq type (cadr types)
 737                      types (cdr def))
 738                (while (and (not disposition) types)
 739                  (setq def (pop types))
 740                  (when (or (eq (car def) t) (string= type (car def)))
 741                    (setq disposition (cdr def))))))
 742             (t
 743              (when (or (eq (car def) t) (string= type (car def)))
 744                (setq disposition (cdr def))))))
 745     (or disposition "attachment")))
 746
 747 (defun mml-insert-mime-headers (cont type charset encoding flowed)
 748   (let (parameters id disposition description)
 749     (setq parameters
 750           (mml-parameter-string
 751            cont mml-content-type-parameters))
 752     (when (or charset
 753               parameters
 754               flowed
 755               (not (equal type mml-generate-default-type))
 756               mml-insert-mime-headers-always)
 757       (when (consp charset)
 758         (error
 759          "Can't encode a part with several charsets"))
 760       (insert "Content-Type: " type)
 761       (when charset
 762         (mml-insert-parameter
 763          (mail-header-encode-parameter "charset" (symbol-name charset))))
 764       (when flowed
 765         (mml-insert-parameter "format=flowed"))
 766       (when parameters
 767         (mml-insert-parameter-string
 768          cont mml-content-type-parameters))
 769       (insert "\n"))
 770     (when (setq id (cdr (assq 'id cont)))
 771       (insert "Content-ID: " id "\n"))
 772     (setq parameters
 773           (mml-parameter-string
 774            cont mml-content-disposition-parameters))
 775     (when (or (setq disposition (cdr (assq 'disposition cont)))
 776               parameters)
 777       (insert "Content-Disposition: "
 778               (or disposition
 779                   (mml-content-disposition type (cdr (assq 'filename cont)))))
 780       (when parameters
 781         (mml-insert-parameter-string
 782          cont mml-content-disposition-parameters))
 783       (insert "\n"))
 784     (unless (eq encoding '7bit)
 785       (insert (format "Content-Transfer-Encoding: %s\n" encoding)))
 786     (when (setq description (cdr (assq 'description cont)))
 787       (insert "Content-Description: ")
 788       (setq description (prog1
 789                             (point)
 790                           (insert description "\n")))
 791       (mail-encode-encoded-word-region description (point)))))
 792
 793 (defun mml-parameter-string (cont types)
 794   (let ((string "")
 795         value type)
 796     (while (setq type (pop types))
 797       (when (setq value (cdr (assq type cont)))
 798         ;; Strip directory component from the filename parameter.
 799         (when (eq type 'filename)
 800           (setq value (file-name-nondirectory value)))
 801         (setq string (concat string "; "
 802                              (mail-header-encode-parameter
 803                               (symbol-name type) value)))))
 804     (when (not (zerop (length string)))
 805       string)))
 806
 807 (defun mml-insert-parameter-string (cont types)
 808   (let (value type)
 809     (while (setq type (pop types))
 810       (when (setq value (cdr (assq type cont)))
 811         ;; Strip directory component from the filename parameter.
 812         (when (eq type 'filename)
 813           (setq value (file-name-nondirectory value)))
 814         (mml-insert-parameter
 815          (mail-header-encode-parameter
 816           (symbol-name type) value))))))
 817
 818 (defvar ange-ftp-name-format)
 819 (defvar efs-path-regexp)
 820
 821 (defun mml-parse-file-name (path)
 822   (if (if (boundp 'efs-path-regexp)
 823           (string-match efs-path-regexp path)
 824         (if (boundp 'ange-ftp-name-format)
 825             (string-match (car ange-ftp-name-format) path)))
 826       (list (match-string 1 path) (match-string 2 path)
 827             (substring path (1+ (match-end 2))))
 828     path))
 829
 830 (defun mml-insert-buffer (buffer)
 831   "Insert BUFFER at point and quote any MML markup."
 832   (save-restriction
 833     (narrow-to-region (point) (point))
 834     (insert-buffer-substring buffer)
 835     (mml-quote-region (point-min) (point-max))
 836     (goto-char (point-max))))
 837
 838 ;;;
 839 ;;; Transforming MIME to MML
 840 ;;;
 841
 842 ;; message-narrow-to-head autoloads message.
 843 (declare-function message-remove-header "message"
 844                   (header &optional is-regexp first reverse))
 845
 846 (defun mime-to-mml (&optional handles)
 847   "Translate the current buffer (which should be a message) into MML.
 848 If HANDLES is non-nil, use it instead reparsing the buffer."
 849   ;; First decode the head.
 850   (save-restriction
 851     (message-narrow-to-head)
 852     (let ((rfc2047-quote-decoded-words-containing-tspecials t))
 853       (mail-decode-encoded-word-region (point-min) (point-max))))
 854   (unless handles
 855     (setq handles (mm-dissect-buffer t)))
 856   (goto-char (point-min))
 857   (search-forward "\n\n" nil t)
 858   (delete-region (point) (point-max))
 859   (if (stringp (car handles))
 860       (mml-insert-mime handles)
 861     (mml-insert-mime handles t))
 862   (mm-destroy-parts handles)
 863   (save-restriction
 864     (message-narrow-to-head)
 865     ;; Remove them, they are confusing.
 866     (message-remove-header "Content-Type")
 867     (message-remove-header "MIME-Version")
 868     (message-remove-header "Content-Disposition")
 869     (message-remove-header "Content-Transfer-Encoding")))
 870
 871 (autoload 'message-encode-message-body "message")
 872 (declare-function message-narrow-to-headers-or-head "message" ())
 873
 874 (defun mml-to-mime ()
 875   "Translate the current buffer from MML to MIME."
 876   ;; `message-encode-message-body' will insert an encoded Content-Description
 877   ;; header in the message header if the body contains a single part
 878   ;; that is specified by a user with a MML tag containing a description
 879   ;; token.  So, we encode the message header first to prevent the encoded
 880   ;; Content-Description header from being encoded again.
 881   (save-restriction
 882     (message-narrow-to-headers-or-head)
 883     ;; Skip past any From_ headers.
 884     (while (looking-at "From ")
 885       (forward-line 1))
 886     (let ((mail-parse-charset message-default-charset))
 887       (mail-encode-encoded-word-buffer)))
 888   (message-encode-message-body))
 889
 890 (defun mml-insert-mime (handle &optional no-markup)
 891   (let (textp buffer mmlp)
 892     ;; Determine type and stuff.
 893     (unless (stringp (car handle))
 894       (unless (setq textp (equal (mm-handle-media-supertype handle) "text"))
 895         (save-excursion
 896           (set-buffer (setq buffer (mml-generate-new-buffer " *mml*")))
 897           (mm-insert-part handle 'no-cache)
 898           (if (setq mmlp (equal (mm-handle-media-type handle)
 899                                 "message/rfc822"))
 900               (mime-to-mml)))))
 901     (if mmlp
 902         (mml-insert-mml-markup handle nil t t)
 903       (unless (and no-markup
 904                    (equal (mm-handle-media-type handle) "text/plain"))
 905         (mml-insert-mml-markup handle buffer textp)))
 906     (cond
 907      (mmlp
 908       (insert-buffer-substring buffer)
 909       (goto-char (point-max))
 910       (insert "<#/mml>\n"))
 911      ((stringp (car handle))
 912       (mapc 'mml-insert-mime (cdr handle))
 913       (insert "<#/multipart>\n"))
 914      (textp
 915       (let ((charset (mail-content-type-get
 916                       (mm-handle-type handle) 'charset))
 917             (start (point)))
 918         (if (eq charset 'gnus-decoded)
 919             (mm-insert-part handle)
 920           (insert (mm-decode-string (mm-get-part handle) charset)))
 921         (mml-quote-region start (point)))
 922       (goto-char (point-max)))
 923      (t
 924       (insert "<#/part>\n")))))
 925
 926 (defun mml-insert-mml-markup (handle &optional buffer nofile mmlp)
 927   "Take a MIME handle and insert an MML tag."
 928   (if (stringp (car handle))
 929       (progn
 930         (insert "<#multipart type=" (mm-handle-media-subtype handle))
 931         (let ((start (mm-handle-multipart-ctl-parameter handle 'start)))
 932           (when start
 933             (insert " start=\"" start "\"")))
 934         (insert ">\n"))
 935     (if mmlp
 936         (insert "<#mml type=" (mm-handle-media-type handle))
 937       (insert "<#part type=" (mm-handle-media-type handle)))
 938     (dolist (elem (append (cdr (mm-handle-type handle))
 939                           (cdr (mm-handle-disposition handle))))
 940       (unless (symbolp (cdr elem))
 941         (insert " " (symbol-name (car elem)) "=\"" (cdr elem) "\"")))
 942     (when (mm-handle-id handle)
 943       (insert " id=\"" (mm-handle-id handle) "\""))
 944     (when (mm-handle-disposition handle)
 945       (insert " disposition=" (car (mm-handle-disposition handle))))
 946     (when buffer
 947       (insert " buffer=\"" (buffer-name buffer) "\""))
 948     (when nofile
 949       (insert " nofile=yes"))
 950     (when (mm-handle-description handle)
 951       (insert " description=\"" (mm-handle-description handle) "\""))
 952     (insert ">\n")))
 953
 954 (defun mml-insert-parameter (&rest parameters)
 955   "Insert PARAMETERS in a nice way."
 956   (let (start end)
 957     (dolist (param parameters)
 958       (insert ";")
 959       (setq start (point))
 960       (insert " " param)
 961       (setq end (point))
 962       (goto-char start)
 963       (end-of-line)
 964       (if (> (current-column) 76)
 965           (progn
 966             (goto-char start)
 967             (insert "\n")
 968             (goto-char (1+ end)))
 969         (goto-char end)))))
 970
 971 ;;;
 972 ;;; Mode for inserting and editing MML forms
 973 ;;;
 974
 975 (defvar mml-mode-map
 976   (let ((sign (make-sparse-keymap))
 977         (encrypt (make-sparse-keymap))
 978         (signpart (make-sparse-keymap))
 979         (encryptpart (make-sparse-keymap))
 980         (map (make-sparse-keymap))
 981         (main (make-sparse-keymap)))
 982     (define-key map "\C-s" 'mml-secure-message-sign)
 983     (define-key map "\C-c" 'mml-secure-message-encrypt)
 984     (define-key map "\C-e" 'mml-secure-message-sign-encrypt)
 985     (define-key map "\C-p\C-s" 'mml-secure-sign)
 986     (define-key map "\C-p\C-c" 'mml-secure-encrypt)
 987     (define-key sign "p" 'mml-secure-message-sign-pgpmime)
 988     (define-key sign "o" 'mml-secure-message-sign-pgp)
 989     (define-key sign "s" 'mml-secure-message-sign-smime)
 990     (define-key signpart "p" 'mml-secure-sign-pgpmime)
 991     (define-key signpart "o" 'mml-secure-sign-pgp)
 992     (define-key signpart "s" 'mml-secure-sign-smime)
 993     (define-key encrypt "p" 'mml-secure-message-encrypt-pgpmime)
 994     (define-key encrypt "o" 'mml-secure-message-encrypt-pgp)
 995     (define-key encrypt "s" 'mml-secure-message-encrypt-smime)
 996     (define-key encryptpart "p" 'mml-secure-encrypt-pgpmime)
 997     (define-key encryptpart "o" 'mml-secure-encrypt-pgp)
 998     (define-key encryptpart "s" 'mml-secure-encrypt-smime)
 999     (define-key map "\C-n" 'mml-unsecure-message)
1000     (define-key map "f" 'mml-attach-file)
1001     (define-key map "b" 'mml-attach-buffer)
1002     (define-key map "e" 'mml-attach-external)
1003     (define-key map "q" 'mml-quote-region)
1004     (define-key map "m" 'mml-insert-multipart)
1005     (define-key map "p" 'mml-insert-part)
1006     (define-key map "v" 'mml-validate)
1007     (define-key map "P" 'mml-preview)
1008     (define-key map "s" sign)
1009     (define-key map "S" signpart)
1010     (define-key map "c" encrypt)
1011     (define-key map "C" encryptpart)
1012     ;;(define-key map "n" 'mml-narrow-to-part)
1013     ;; `M-m' conflicts with `back-to-indentation'.
1014     ;; (define-key main "\M-m" map)
1015     (define-key main "\C-c\C-m" map)
1016     main))
1017
1018 (easy-menu-define
1019   mml-menu mml-mode-map ""
1020   `("Attachments"
1021     ["Attach File..." mml-attach-file
1022      ,@(if (featurep 'xemacs) '(t)
1023          '(:help "Attach a file at point"))]
1024     ["Attach Buffer..." mml-attach-buffer
1025      ,@(if (featurep 'xemacs) '(t)
1026          '(:help "Attach a buffer to the outgoing message"))]
1027     ["Attach External..." mml-attach-external
1028      ,@(if (featurep 'xemacs) '(t)
1029          '(:help "Attach reference to an external file"))]
1030     ;; FIXME: Is it possible to do this without using
1031     ;; `gnus-gcc-externalize-attachments'?
1032     ["Externalize Attachments"
1033      (lambda ()
1034        (interactive)
1035        (if (not (and (boundp 'gnus-gcc-externalize-attachments)
1036                      (memq gnus-gcc-externalize-attachments
1037                            '(all t nil))))
1038            ;; Stupid workaround for XEmacs not honoring :visible.
1039            (message "Can't handle this value of `gnus-gcc-externalize-attachments'")
1040          (setq gnus-gcc-externalize-attachments
1041                (not gnus-gcc-externalize-attachments))
1042          (message "gnus-gcc-externalize-attachments is `%s'."
1043                   gnus-gcc-externalize-attachments)))
1044      ;; XEmacs barfs on :visible.
1045      ,@(if (featurep 'xemacs) nil
1046          '(:visible (and (boundp 'gnus-gcc-externalize-attachments)
1047                          (memq gnus-gcc-externalize-attachments
1048                                '(all t nil)))))
1049      :style toggle
1050      :selected gnus-gcc-externalize-attachments
1051      ,@(if (featurep 'xemacs) nil
1052          '(:help "Save attachments as external parts in Gcc copies"))]
1053     "----"
1054     ;;
1055     ("Change Security Method"
1056      ["PGP/MIME"
1057       (lambda () (interactive) (setq mml-secure-method "pgpmime"))
1058       ,@(if (featurep 'xemacs) nil
1059           '(:help "Set Security Method to PGP/MIME"))
1060       :style radio
1061       :selected (equal mml-secure-method "pgpmime") ]
1062      ["S/MIME"
1063       (lambda () (interactive) (setq mml-secure-method "smime"))
1064       ,@(if (featurep 'xemacs) nil
1065           '(:help "Set Security Method to S/MIME"))
1066       :style radio
1067       :selected (equal mml-secure-method "smime") ]
1068      ["Inline PGP"
1069       (lambda () (interactive) (setq mml-secure-method "pgp"))
1070       ,@(if (featurep 'xemacs) nil
1071           '(:help "Set Security Method to inline PGP"))
1072       :style radio
1073       :selected (equal mml-secure-method "pgp") ] )
1074     ;;
1075     ["Sign Message" mml-secure-message-sign t]
1076     ["Encrypt Message" mml-secure-message-encrypt t]
1077     ["Sign and Encrypt Message" mml-secure-message-sign-encrypt t]
1078     ["Encrypt/Sign off" mml-unsecure-message
1079      ,@(if (featurep 'xemacs) '(t)
1080          '(:help "Don't Encrypt/Sign Message"))]
1081     ;; Do we have separate encrypt and encrypt/sign commands for parts?
1082     ["Sign Part" mml-secure-sign t]
1083     ["Encrypt Part" mml-secure-encrypt t]
1084     "----"
1085     ;; Maybe we could remove these, because people who write MML most probably
1086     ;; don't use the menu:
1087     ["Insert Part..." mml-insert-part
1088      :active (message-in-body-p)]
1089     ["Insert Multipart..." mml-insert-multipart
1090      :active (message-in-body-p)]
1091     ;;
1092     ;;["Narrow" mml-narrow-to-part t]
1093     ["Quote MML in region" mml-quote-region
1094      :active (message-mark-active-p)
1095      ,@(if (featurep 'xemacs) nil
1096          '(:help "Quote MML tags in region"))]
1097     ["Validate MML" mml-validate t]
1098     ["Preview" mml-preview t]
1099     "----"
1100     ["Emacs MIME manual" (lambda () (interactive) (message-info 4))
1101      ,@(if (featurep 'xemacs) '(t)
1102          '(:help "Display the Emacs MIME manual"))]
1103     ["PGG manual" (lambda () (interactive) (message-info mml2015-use))
1104      ;; XEmacs barfs on :visible.
1105      ,@(if (featurep 'xemacs) nil
1106          '(:visible (equal mml2015-use 'pgg)))
1107      ,@(if (featurep 'xemacs) '(t)
1108          '(:help "Display the PGG manual"))]
1109     ["EasyPG manual" (lambda () (interactive) (message-info mml2015-use))
1110      ;; XEmacs barfs on :visible.
1111      ,@(if (featurep 'xemacs) nil
1112          '(:visible (equal mml2015-use 'epg)))
1113      ,@(if (featurep 'xemacs) '(t)
1114          '(:help "Display the EasyPG manual"))]))
1115
1116 (defvar mml-mode nil
1117   "Minor mode for editing MML.")
1118
1119 (defun mml-mode (&optional arg)
1120   "Minor mode for editing MML.
1121 MML is the MIME Meta Language, a minor mode for composing MIME articles.
1122 See Info node `(emacs-mime)Composing'.
1123
1124 \\{mml-mode-map}"
1125   (interactive "P")
1126   (when (set (make-local-variable 'mml-mode)
1127              (if (null arg) (not mml-mode)
1128                (> (prefix-numeric-value arg) 0)))
1129     (add-minor-mode 'mml-mode " MML" mml-mode-map)
1130     (easy-menu-add mml-menu mml-mode-map)
1131     (when (boundp 'dnd-protocol-alist)
1132       (set (make-local-variable 'dnd-protocol-alist)
1133            (append mml-dnd-protocol-alist dnd-protocol-alist)))
1134     (run-hooks 'mml-mode-hook)))
1135
1136 ;;;
1137 ;;; Helper functions for reading MIME stuff from the minibuffer and
1138 ;;; inserting stuff to the buffer.
1139 ;;;
1140
1141 (defcustom mml-default-directory mm-default-directory
1142   "The default directory where mml will find files.
1143 If not set, `default-directory' will be used."
1144   :type '(choice directory (const :tag "Default" nil))
1145   :version "23.1" ;; No Gnus
1146   :group 'message)
1147
1148 (defun mml-minibuffer-read-file (prompt)
1149   (let* ((completion-ignored-extensions nil)
1150          (file (read-file-name prompt
1151                                (or mml-default-directory default-directory)
1152                                nil t)))
1153     ;; Prevent some common errors.  This is inspired by similar code in
1154     ;; VM.
1155     (when (file-directory-p file)
1156       (error "%s is a directory, cannot attach" file))
1157     (unless (file-exists-p file)
1158       (error "No such file: %s" file))
1159     (unless (file-readable-p file)
1160       (error "Permission denied: %s" file))
1161     file))
1162
1163 (defun mml-minibuffer-read-type (name &optional default)
1164   (mailcap-parse-mimetypes)
1165   (let* ((default (or default
1166                       (mm-default-file-encoding name)
1167                       ;; Perhaps here we should check what the file
1168                       ;; looks like, and offer text/plain if it looks
1169                       ;; like text/plain.
1170                       "application/octet-stream"))
1171          (string (completing-read
1172                   (format "Content type (default %s): " default)
1173                   (mapcar 'list (mailcap-mime-types)))))
1174     (if (not (equal string ""))
1175         string
1176       default)))
1177
1178 (defun mml-minibuffer-read-description ()
1179   (let ((description (read-string "One line description: ")))
1180     (when (string-match "\\`[ \t]*\\'" description)
1181       (setq description nil))
1182     description))
1183
1184 (defun mml-minibuffer-read-disposition (type &optional default filename)
1185   (unless default
1186     (setq default (mml-content-disposition type filename)))
1187   (let ((disposition (completing-read
1188                       (format "Disposition (default %s): " default)
1189                       '(("attachment") ("inline") (""))
1190                       nil t nil nil default)))
1191     (if (not (equal disposition ""))
1192         disposition
1193       default)))
1194
1195 (defun mml-quote-region (beg end)
1196   "Quote the MML tags in the region."
1197   (interactive "r")
1198   (save-excursion
1199     (save-restriction
1200       ;; Temporarily narrow the region to defend from changes
1201       ;; invalidating END.
1202       (narrow-to-region beg end)
1203       (goto-char (point-min))
1204       ;; Quote parts.
1205       (while (re-search-forward
1206               "<#!*/?\\(multipart\\|part\\|external\\|mml\\)" nil t)
1207         ;; Insert ! after the #.
1208         (goto-char (+ (match-beginning 0) 2))
1209         (insert "!")))))
1210
1211 (defun mml-insert-tag (name &rest plist)
1212   "Insert an MML tag described by NAME and PLIST."
1213   (when (symbolp name)
1214     (setq name (symbol-name name)))
1215   (insert "<#" name)
1216   (while plist
1217     (let ((key (pop plist))
1218           (value (pop plist)))
1219       (when value
1220         ;; Quote VALUE if it contains suspicious characters.
1221         (when (string-match "[\"'\\~/*;() \t\n]" value)
1222           (setq value (with-output-to-string
1223                         (let (print-escape-nonascii)
1224                           (prin1 value)))))
1225         (insert (format " %s=%s" key value)))))
1226   (insert ">\n"))
1227
1228 (defun mml-insert-empty-tag (name &rest plist)
1229   "Insert an empty MML tag described by NAME and PLIST."
1230   (when (symbolp name)
1231     (setq name (symbol-name name)))
1232   (apply #'mml-insert-tag name plist)
1233   (insert "<#/" name ">\n"))
1234
1235 ;;; Attachment functions.
1236
1237 (defcustom mml-dnd-protocol-alist
1238   '(("^file:///" . mml-dnd-attach-file)
1239     ("^file://"  . dnd-open-file)
1240     ("^file:"    . mml-dnd-attach-file))
1241   "The functions to call when a drop in `mml-mode' is made.
1242 See `dnd-protocol-alist' for more information.  When nil, behave
1243 as in other buffers."
1244   :type '(choice (repeat (cons (regexp) (function)))
1245                  (const :tag "Behave as in other buffers" nil))
1246   :version "22.1" ;; Gnus 5.10.9
1247   :group 'message)
1248
1249 (defcustom mml-dnd-attach-options nil
1250   "Which options should be queried when attaching a file via drag and drop.
1251
1252 If it is a list, valid members are `type', `description' and
1253 `disposition'.  `disposition' implies `type'.  If it is nil,
1254 don't ask for options.  If it is t, ask the user whether or not
1255 to specify options."
1256   :type '(choice
1257           (const :tag "None" nil)
1258           (const :tag "Query" t)
1259           (list :value (type description disposition)
1260            (set :inline t
1261                 (const type)
1262                 (const description)
1263                 (const disposition))))
1264   :version "22.1" ;; Gnus 5.10.9
1265   :group 'message)
1266
1267 (defun mml-attach-file (file &optional type description disposition)
1268   "Attach a file to the outgoing MIME message.
1269 The file is not inserted or encoded until you send the message with
1270 `\\[message-send-and-exit]' or `\\[message-send]'.
1271
1272 FILE is the name of the file to attach.  TYPE is its
1273 content-type, a string of the form \"type/subtype\".  DESCRIPTION
1274 is a one-line description of the attachment.  The DISPOSITION
1275 specifies how the attachment is intended to be displayed.  It can
1276 be either \"inline\" (displayed automatically within the message
1277 body) or \"attachment\" (separate from the body)."
1278   (interactive
1279    (let* ((file (mml-minibuffer-read-file "Attach file: "))
1280           (type (mml-minibuffer-read-type file))
1281           (description (mml-minibuffer-read-description))
1282           (disposition (mml-minibuffer-read-disposition type nil file)))
1283      (list file type description disposition)))
1284   (save-excursion
1285     (unless (message-in-body-p) (goto-char (point-max)))
1286     (mml-insert-empty-tag 'part
1287                           'type type
1288                           'filename file
1289                           'disposition (or disposition "attachment")
1290                           'description description)))
1291
1292 (defun mml-dnd-attach-file (uri action)
1293   "Attach a drag and drop file.
1294
1295 Ask for type, description or disposition according to
1296 `mml-dnd-attach-options'."
1297   (let ((file (dnd-get-local-file-name uri t)))
1298     (when (and file (file-regular-p file))
1299       (let ((mml-dnd-attach-options mml-dnd-attach-options)
1300             type description disposition)
1301         (setq mml-dnd-attach-options
1302               (when (and (eq mml-dnd-attach-options t)
1303                          (not
1304                           (y-or-n-p
1305                            "Use default type, disposition and description? ")))
1306                 '(type description disposition)))
1307         (when (or (memq 'type mml-dnd-attach-options)
1308                   (memq 'disposition mml-dnd-attach-options))
1309           (setq type (mml-minibuffer-read-type file)))
1310         (when (memq 'description mml-dnd-attach-options)
1311           (setq description (mml-minibuffer-read-description)))
1312         (when (memq 'disposition mml-dnd-attach-options)
1313           (setq disposition (mml-minibuffer-read-disposition type nil file)))
1314         (mml-attach-file file type description disposition)))))
1315
1316 (defun mml-attach-buffer (buffer &optional type description disposition)
1317   "Attach a buffer to the outgoing MIME message.
1318 BUFFER is the name of the buffer to attach.  See
1319 `mml-attach-file' for details of operation."
1320   (interactive
1321    (let* ((buffer (read-buffer "Attach buffer: "))
1322           (type (mml-minibuffer-read-type buffer "text/plain"))
1323           (description (mml-minibuffer-read-description))
1324           (disposition (mml-minibuffer-read-disposition type nil)))
1325      (list buffer type description disposition)))
1326   (save-excursion
1327     (unless (message-in-body-p) (goto-char (point-max)))
1328     (mml-insert-empty-tag 'part 'type type 'buffer buffer
1329                           'disposition disposition
1330                           'description description)))
1331
1332 (defun mml-attach-external (file &optional type description)
1333   "Attach an external file into the buffer.
1334 FILE is an ange-ftp/efs specification of the part location.
1335 TYPE is the MIME type to use."
1336   (interactive
1337    (let* ((file (mml-minibuffer-read-file "Attach external file: "))
1338           (type (mml-minibuffer-read-type file))
1339           (description (mml-minibuffer-read-description)))
1340      (list file type description)))
1341   (save-excursion
1342     (unless (message-in-body-p) (goto-char (point-max)))
1343     (mml-insert-empty-tag 'external 'type type 'name file
1344                           'disposition "attachment" 'description description)))
1345
1346 (defun mml-insert-multipart (&optional type)
1347   (interactive (list (completing-read "Multipart type (default mixed): "
1348                                       '(("mixed") ("alternative") ("digest") ("parallel")
1349                                         ("signed") ("encrypted"))
1350                                       nil nil "mixed")))
1351   (or type
1352       (setq type "mixed"))
1353   (mml-insert-empty-tag "multipart" 'type type)
1354   (forward-line -1))
1355
1356 (defun mml-insert-part (&optional type)
1357   (interactive
1358    (list (mml-minibuffer-read-type "")))
1359   (mml-insert-tag 'part 'type type 'disposition "inline")
1360   (forward-line -1))
1361
1362 (declare-function message-subscribed-p "message" ())
1363 (declare-function message-make-mail-followup-to "message"
1364                   (&optional only-show-subscribed))
1365 (declare-function message-position-on-field "message" (header &rest afters))
1366
1367 (defun mml-preview-insert-mail-followup-to ()
1368   "Insert a Mail-Followup-To header before previewing an article.
1369 Should be adopted if code in `message-send-mail' is changed."
1370   (when (and (message-mail-p)
1371              (message-subscribed-p)
1372              (not (mail-fetch-field "mail-followup-to"))
1373              (message-make-mail-followup-to))
1374     (message-position-on-field "Mail-Followup-To" "X-Draft-From")
1375     (insert (message-make-mail-followup-to))))
1376
1377 (defvar mml-preview-buffer nil)
1378
1379 (autoload 'gnus-make-hashtable "gnus-util")
1380 (autoload 'widget-button-press "wid-edit" nil t)
1381 (declare-function widget-event-point "wid-edit" (event))
1382 ;; If gnus-buffer-configuration is bound this is loaded.
1383 (declare-function gnus-configure-windows "gnus-win" (setting &optional force))
1384 ;; Called after message-mail-p, which autoloads message.
1385 (declare-function message-news-p                "message" ())
1386 (declare-function message-options-set-recipient "message" ())
1387 (declare-function message-generate-headers      "message" (headers))
1388 (declare-function message-sort-headers          "message" ())
1389
1390 (defun mml-preview (&optional raw)
1391   "Display current buffer with Gnus, in a new buffer.
1392 If RAW, display a raw encoded MIME message.
1393
1394 The window layout for the preview buffer is controled by the variables
1395 `special-display-buffer-names', `special-display-regexps', or
1396 `gnus-buffer-configuration' (the first match made will be used),
1397 or the `pop-to-buffer' function."
1398   (interactive "P")
1399   (setq mml-preview-buffer (generate-new-buffer
1400                             (concat (if raw "*Raw MIME preview of "
1401                                       "*MIME preview of ") (buffer-name))))
1402   (save-excursion
1403     (let* ((buf (current-buffer))
1404            (message-options message-options)
1405            (message-this-is-mail (message-mail-p))
1406            (message-this-is-news (message-news-p))
1407            (message-posting-charset (or (gnus-setup-posting-charset
1408                                          (save-restriction
1409                                            (message-narrow-to-headers-or-head)
1410                                            (message-fetch-field "Newsgroups")))
1411                                         message-posting-charset)))
1412       (message-options-set-recipient)
1413       (when (boundp 'gnus-buffers)
1414         (push mml-preview-buffer gnus-buffers))
1415       (save-restriction
1416         (widen)
1417         (set-buffer mml-preview-buffer)
1418         (erase-buffer)
1419         (insert-buffer-substring buf))
1420       (mml-preview-insert-mail-followup-to)
1421       (let ((message-deletable-headers (if (message-news-p)
1422                                            nil
1423                                          message-deletable-headers)))
1424         (message-generate-headers
1425          (copy-sequence (if (message-news-p)
1426                             message-required-news-headers
1427                           message-required-mail-headers))))
1428       (if (re-search-forward
1429            (concat "^" (regexp-quote mail-header-separator) "\n") nil t)
1430           (replace-match "\n"))
1431       (let ((mail-header-separator ""));; mail-header-separator is removed.
1432         (message-sort-headers)
1433         (mml-to-mime))
1434       (if raw
1435           (when (fboundp 'set-buffer-multibyte)
1436             (let ((s (buffer-string)))
1437               ;; Insert the content into unibyte buffer.
1438               (erase-buffer)
1439               (mm-disable-multibyte)
1440               (insert s)))
1441         (let ((gnus-newsgroup-charset (car message-posting-charset))
1442               gnus-article-prepare-hook gnus-original-article-buffer)
1443           (run-hooks 'gnus-article-decode-hook)
1444           (let ((gnus-newsgroup-name "dummy")
1445                 (gnus-newsrc-hashtb (or gnus-newsrc-hashtb
1446                                         (gnus-make-hashtable 5))))
1447             (gnus-article-prepare-display))))
1448       ;; Disable article-mode-map.
1449       (use-local-map nil)
1450       (gnus-make-local-hook 'kill-buffer-hook)
1451       (add-hook 'kill-buffer-hook
1452                 (lambda ()
1453                   (mm-destroy-parts gnus-article-mime-handles)) nil t)
1454       (setq buffer-read-only t)
1455       (local-set-key "q" (lambda () (interactive) (kill-buffer nil)))
1456       (local-set-key "=" (lambda () (interactive) (delete-other-windows)))
1457       (local-set-key "\r"
1458                      (lambda ()
1459                        (interactive)
1460                        (widget-button-press (point))))
1461       (local-set-key gnus-mouse-2
1462                      (lambda (event)
1463                        (interactive "@e")
1464                        (widget-button-press (widget-event-point event) event)))
1465       ;; FIXME: Buffer is in article mode, but most tool bar commands won't
1466       ;; work.  Maybe only keep the following icons: search, print, quit
1467       (goto-char (point-min))))
1468   (if (and (not (mm-special-display-p (buffer-name mml-preview-buffer)))
1469            (boundp 'gnus-buffer-configuration)
1470            (assq 'mml-preview gnus-buffer-configuration))
1471       (let ((gnus-message-buffer (current-buffer)))
1472         (gnus-configure-windows 'mml-preview))
1473     (pop-to-buffer mml-preview-buffer)))
1474
1475 (defun mml-validate ()
1476   "Validate the current MML document."
1477   (interactive)
1478   (mml-parse))
1479
1480 (defun mml-tweak-part (cont)
1481   "Tweak a MML part."
1482   (let ((tweak (cdr (assq 'tweak cont)))
1483         func)
1484     (cond
1485      (tweak
1486       (setq func
1487             (or (cdr (assoc tweak mml-tweak-function-alist))
1488                 (intern tweak))))
1489      (mml-tweak-type-alist
1490       (let ((alist mml-tweak-type-alist)
1491             (type (or (cdr (assq 'type cont)) "text/plain")))
1492         (while alist
1493           (if (string-match (caar alist) type)
1494               (setq func (cdar alist)
1495                     alist nil)
1496             (setq alist (cdr alist)))))))
1497     (if func
1498         (funcall func cont)
1499       cont)
1500     (let ((alist mml-tweak-sexp-alist))
1501       (while alist
1502         (if (eval (caar alist))
1503             (funcall (cdar alist) cont))
1504         (setq alist (cdr alist)))))
1505   cont)
1506
1507 (defun mml-tweak-externalize-attachments (cont)
1508   "Tweak attached files as external parts."
1509   (let (filename-cons)
1510     (when (and (eq (car cont) 'part)
1511                (not (cdr (assq 'buffer cont)))
1512                (and (setq filename-cons (assq 'filename cont))
1513                     (not (equal (cdr (assq 'nofile cont)) "yes"))))
1514       (setcar cont 'external)
1515       (setcar filename-cons 'name))))
1516
1517 (provide 'mml)
1518
1519 ;; arch-tag: 583c96cf-1ffe-451b-a5e5-4733ae9ddd12
1520 ;;; mml.el ends here