lisp/gnus/mml.el

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