mime-edit.el

   1 ;;; mime-edit.el --- Simple MIME Composer for GNU Emacs
   2
   3 ;; Copyright (C) 1993,94,95,96,97,98,99,2000 Free Software Foundation, Inc.
   4
   5 ;; Author: UMEDA Masanobu <umerin@mse.kyutech.ac.jp>
   6 ;;      MORIOKA Tomohiko <tomo@kanji.zinbun.kyoto-u.ac.jp>
   7 ;;      Daiki Ueno <ueno@unixuser.org>
   8 ;; Created: 1994/08/21 renamed from mime.el
   9 ;;      Renamed: 1997/2/21 from tm-edit.el
  10 ;; Keywords: MIME, multimedia, multilingual, mail, news
  11
  12 ;; This file is part of SEMI (Sophisticated Emacs MIME Interfaces).
  13
  14 ;; This program is free software; you can redistribute it and/or
  15 ;; modify it under the terms of the GNU General Public License as
  16 ;; published by the Free Software Foundation; either version 2, or (at
  17 ;; your option) any later version.
  18
  19 ;; This program is distributed in the hope that it will be useful, but
  20 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  22 ;; General Public License for more details.
  23
  24 ;; You should have received a copy of the GNU General Public License
  25 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  26 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  27 ;; Boston, MA 02110-1301, USA.
  28
  29 ;;; Commentary:
  30
  31 ;; This is an Emacs minor mode for editing Internet multimedia
  32 ;; messages formatted in MIME (RFC 2045, 2046, 2047, 2048 and 2049).
  33 ;; All messages in this mode are composed in the tagged MIME format,
  34 ;; that are described in the following examples.  The messages
  35 ;; composed in the tagged MIME format are automatically translated
  36 ;; into a MIME compliant message when exiting the mode.
  37
  38 ;; Mule (multilingual feature of Emacs 20 and multilingual extension
  39 ;; for XEmacs 20) has a capability of handling multilingual text in
  40 ;; limited ISO-2022 manner that is based on early experiences in
  41 ;; Japanese Internet community and resulted in RFC 1468 (ISO-2022-JP
  42 ;; charset for MIME).  In order to enable multilingual capability in
  43 ;; single text message in MIME, charset of multilingual text written
  44 ;; in Mule is declared as either `ISO-2022-JP-2' [RFC 1554].  Mule is
  45 ;; required for reading the such messages.
  46
  47 ;; This MIME composer can work with Mail mode, mh-e letter Mode, and
  48 ;; News mode.  First of all, you need the following autoload
  49 ;; definition to load mime-edit-mode automatically:
  50 ;;
  51 ;; (autoload 'turn-on-mime-edit "mime-edit"
  52 ;;           "Minor mode for editing MIME message." t)
  53 ;;
  54 ;; In case of Mail mode (includes VM mode), you need the following
  55 ;; hook definition:
  56 ;;
  57 ;; (add-hook 'mail-mode-hook 'turn-on-mime-edit)
  58 ;; (add-hook 'mail-send-hook 'mime-edit-maybe-translate)
  59 ;;
  60 ;; In case of MH-E, you need the following hook definition:
  61 ;;
  62 ;; (add-hook 'mh-letter-mode-hook
  63 ;;           (function
  64 ;;            (lambda ()
  65 ;;              (turn-on-mime-edit)
  66 ;;              (make-local-variable 'mail-header-separator)
  67 ;;              (setq mail-header-separator "--------")
  68 ;;              ))))
  69 ;; (add-hook 'mh-before-send-letter-hook 'mime-edit-maybe-translate)
  70 ;;
  71 ;; In case of News mode, you need the following hook definition:
  72 ;;
  73 ;; (add-hook 'news-reply-mode-hook 'turn-on-mime-edit)
  74 ;; (add-hook 'news-inews-hook 'mime-edit-maybe-translate)
  75 ;;
  76 ;; In case of Emacs 19, it is possible to emphasize the message tags
  77 ;; using font-lock mode as follows:
  78 ;;
  79 ;; (add-hook 'mime-edit-mode-hook
  80 ;;           (function
  81 ;;            (lambda ()
  82 ;;              (font-lock-mode 1)
  83 ;;              (setq font-lock-keywords (list mime-edit-tag-regexp))
  84 ;;              ))))
  85
  86 ;; The message tag looks like:
  87 ;;
  88 ;;      --[[TYPE/SUBTYPE;PARAMETERS][ENCODING]]
  89 ;;
  90 ;; The tagged MIME message examples:
  91 ;;
  92 ;; This is a conventional plain text.  It should be translated into
  93 ;; text/plain.
  94 ;;
  95 ;;--[[text/plain]]
  96 ;; This is also a plain text.  But, it is explicitly specified as is.
  97 ;;--[[text/plain; charset=ISO-8859-1]]
  98 ;; This is also a plain text.  But charset is specified as iso-8859-1.
  99 ;;
 100 ;; ¡Hola!  Buenos días.  ¿Cómo está usted?
 101 ;;--[[text/enriched]]
 102 ;; <center>This is a richtext.</center>
 103 ;;
 104 ;;--[[image/gif][base64]]^M...image encoded in base64 comes here...
 105 ;;
 106 ;;--[[audio/basic][base64]]^M...audio encoded in base64 comes here...
 107
 108 ;;; Code:
 109
 110 (require 'sendmail)
 111 (require 'mail-utils)
 112 (require 'mel)
 113 (require 'mime-view)
 114 (require 'signature)
 115 (require 'alist)
 116 (require 'epa)
 117
 118
 119 ;;; @ version
 120 ;;;
 121
 122 (eval-and-compile
 123   (defconst mime-edit-version
 124     (concat
 125      (mime-product-name mime-user-interface-product) " "
 126      (mapconcat #'number-to-string
 127                 (mime-product-version mime-user-interface-product) ".")
 128      " - \"" (mime-product-code-name mime-user-interface-product) "\"")))
 129
 130
 131 ;;; @ variables
 132 ;;;
 133
 134 (defgroup mime-edit nil
 135   "MIME edit mode"
 136   :group 'mime)
 137
 138 (defcustom mime-ignore-preceding-spaces nil
 139   "*Ignore preceding white spaces if non-nil."
 140   :group 'mime-edit
 141   :type 'boolean)
 142
 143 (defcustom mime-ignore-trailing-spaces nil
 144   "*Ignore trailing white spaces if non-nil."
 145   :group 'mime-edit
 146   :type 'boolean)
 147
 148 (defcustom mime-ignore-same-text-tag t
 149   "*Ignore preceding text content-type tag that is same with new one.
 150 If non-nil, the text tag is not inserted unless something different."
 151   :group 'mime-edit
 152   :type 'boolean)
 153
 154 (defcustom mime-auto-hide-body t
 155   "*Hide non-textual body encoded in base64 after insertion if non-nil."
 156   :group 'mime-edit
 157   :type 'boolean)
 158
 159 (defcustom mime-edit-voice-recorder
 160   (function mime-edit-voice-recorder-for-sun)
 161   "*Function to record a voice message and encode it."
 162   :group 'mime-edit
 163   :type 'function)
 164
 165 (defcustom mime-edit-mode-hook nil
 166   "*Hook called when enter MIME mode."
 167   :group 'mime-edit
 168   :type 'hook)
 169
 170 (defcustom mime-edit-translate-hook nil
 171   "*Hook called before translating into a MIME compliant message.
 172 To insert a signature file automatically, call the function
 173 `mime-edit-insert-signature' from this hook."
 174   :group 'mime-edit
 175   :type 'hook)
 176
 177 (defcustom mime-edit-exit-hook nil
 178   "*Hook called when exit MIME mode."
 179   :group 'mime-edit
 180   :type 'hook)
 181
 182 (defvar mime-content-types
 183   '(("text"
 184      ;; Charset parameter need not to be specified, since it is
 185      ;; defined automatically while translation.
 186      ("plain"
 187       ;;("charset" "" "ISO-2022-JP" "US-ASCII" "ISO-8859-1" "ISO-8859-8")
 188       )
 189      ("enriched")
 190      ("html")
 191      ("css") ; rfc2318
 192      ("xml") ; rfc2376
 193      ("x-latex")
 194      ;; ("x-rot13-47-48")
 195      )
 196     ("message"
 197      ("external-body"
 198       ("access-type"
 199        ("anon-ftp"
 200         ("site" "ftp.jaist.ac.jp" "wnoc-fuk.wide.ad.jp" "nic.karrn.ad.jp")
 201         ("directory" "/pub/GNU/elisp/mime")
 202         ("name")
 203         ("mode" "image" "ascii" "local8"))
 204        ("ftp"
 205         ("site")
 206         ("directory")
 207         ("name")
 208         ("mode" "image" "ascii" "local8"))
 209        ("tftp"        ("site") ("name"))
 210        ("afs"         ("site") ("name"))
 211        ("local-file"  ("site") ("name"))
 212        ("mail-server"
 213         ("server" "ftpmail@nic.karrn.ad.jp")
 214         ("subject"))
 215        ("url"         ("url"))))
 216      ("rfc822")
 217      ("news"))
 218     ("application"
 219      ("octet-stream" ("type" "" "tar" "shar"))
 220      ("postscript")
 221      ("pdf")
 222      ("msword")
 223      ("vnd.ms-excel")
 224      ("vnd.ms-powerpoint")
 225      ("x-kiss" ("x-cnf")))
 226     ("image"
 227      ("gif")
 228      ("jpeg")
 229      ("png")
 230      ("tiff")
 231      ("x-pic")
 232      ("x-mag")
 233      ("x-xwd")
 234      ("x-xbm"))
 235     ("audio" ("basic"))
 236     ("video" ("mpeg")))
 237   "*Alist of content-type, subtype, parameters and its values.")
 238
 239 (defcustom mime-file-types
 240   '(
 241
 242     ;; Programming languages
 243
 244     ("\\.cc$"
 245      "application" "octet-stream" (("type" . "C++"))
 246      "7bit"
 247      "attachment"       (("filename" . file)))
 248
 249     ("\\.el$"
 250      "application" "octet-stream" (("type" . "emacs-lisp"))
 251      "7bit"
 252      "attachment"       (("filename" . file)))
 253
 254     ("\\.lsp$"
 255      "application" "octet-stream" (("type" . "common-lisp"))
 256      "7bit"
 257      "attachment"       (("filename" . file)))
 258
 259     ("\\.pl$"
 260      "application" "octet-stream" (("type" . "perl"))
 261      "7bit"
 262      "attachment"       (("filename" . file)))
 263
 264     ;; Text or translated text
 265
 266     ("\\.txt$"
 267      "text"     "plain"         nil
 268      nil
 269      "inline"           (("filename" . file)))
 270
 271      ;; .rc : procmail modules pm-xxxx.rc
 272      ;; *rc : other resource files
 273
 274     ("\\.\\(rc\\|lst\\|log\\|sql\\|mak\\)$\\|\\..*rc$"
 275      "text"     "plain"         nil
 276      nil
 277      "attachment"       (("filename" . file)))
 278
 279     ("\\.html$"
 280      "text"     "html"          nil
 281      nil
 282      nil                nil)
 283
 284     ("\\.diff$\\|\\.patch$"
 285      "application" "octet-stream" (("type" . "patch"))
 286      nil
 287      "attachment"       (("filename" . file)))
 288
 289     ("\\.signature"
 290      "text"     "plain"         nil     nil     nil     nil)
 291
 292
 293     ;;  Octect binary text
 294
 295     ("\\.doc$"                          ;MS Word
 296      "application" "msword" nil
 297      "base64"
 298      "attachment" (("filename" . file)))
 299     ("\\.xls$"                          ; MS Excel
 300      "application" "vnd.ms-excel" nil
 301      "base64"
 302      "attachment" (("filename" . file)))
 303     ("\\.ppt$"                          ; MS Power Point
 304      "application" "vnd.ms-powerpoint" nil
 305      "base64"
 306      "attachment" (("filename" . file)))
 307
 308     ("\\.pln$"
 309      "text"     "plain"         nil
 310      nil
 311      "inline"           (("filename" . file)))
 312     ("\\.ps$"
 313      "application" "postscript" nil
 314      "base64"
 315      "attachment"       (("filename" . file)))
 316     ("\\.pdf$"
 317      "application" "pdf"        nil
 318      "base64"
 319      "attachment"       (("filename" . file)))
 320
 321     ;;  Pure binary
 322
 323     ("\\.jpg$\\|\\.jpeg$"
 324      "image"    "jpeg"          nil
 325      "base64"
 326      "inline"           (("filename" . file)))
 327     ("\\.gif$"
 328      "image"    "gif"           nil
 329      "base64"
 330      "inline"           (("filename" . file)))
 331     ("\\.png$"
 332      "image"    "png"           nil
 333      "base64"
 334      "inline"           (("filename" . file)))
 335     ("\\.tiff$"
 336      "image"    "tiff"          nil
 337      "base64"
 338      "inline"           (("filename" . file)))
 339     ("\\.pic$"
 340      "image"    "x-pic"         nil
 341      "base64"
 342      "inline"           (("filename" . file)))
 343     ("\\.mag$"
 344      "image"    "x-mag"         nil
 345      "base64"
 346      "inline"           (("filename" . file)))
 347     ("\\.xbm$"
 348      "image"    "x-xbm"         nil
 349      "base64"
 350      "inline"           (("filename" . file)))
 351     ("\\.xwd$"
 352      "image"    "x-xwd"         nil
 353      "base64"
 354      "inline"           (("filename" . file)))
 355     ("\\.au$"
 356      "audio"    "basic"         nil
 357      "base64"
 358      "attachment"               (("filename" . file)))
 359     ("\\.mpg$"
 360      "video"    "mpeg"          nil
 361      "base64"
 362      "attachment"       (("filename" . file)))
 363     ("\\.tar\\.gz$"
 364      "application" "octet-stream" (("type" . "tar+gzip"))
 365      "base64"
 366      "attachment"       (("filename" . file)))
 367     ("\\.tgz$"
 368      "application" "octet-stream" (("type" . "tar+gzip"))
 369      "base64"
 370      "attachment"       (("filename" . file)))
 371     ("\\.tar\\.Z$"
 372      "application" "octet-stream" (("type" . "tar+compress"))
 373      "base64"
 374      "attachment"       (("filename" . file)))
 375     ("\\.taz$"
 376      "application" "octet-stream" (("type" . "tar+compress"))
 377      "base64"
 378      "attachment"       (("filename" . file)))
 379     ("\\.gz$"
 380      "application" "octet-stream" (("type" . "gzip"))
 381      "base64"
 382      "attachment"       (("filename" . file)))
 383     ("\\.Z$"
 384      "application" "octet-stream" (("type" . "compress"))
 385      "base64"
 386      "attachment"       (("filename" . file)))
 387     ("\\.lzh$"
 388      "application" "octet-stream" (("type" . "lha"))
 389      "base64"
 390      "attachment"       (("filename" . file)))
 391     ("\\.zip$"
 392      "application" "zip" nil
 393      "base64"
 394      "attachment"       (("filename" . file)))
 395
 396     ;; Rest
 397
 398     (".*"
 399      "application" "octet-stream" nil
 400      nil
 401      "attachment"       (("filename" . file))))
 402   "*Alist of file name, types, parameters, and default encoding.
 403 If encoding is nil, it is determined from its contents."
 404   :type `(repeat
 405           (list regexp
 406                 ;; primary-type
 407                 (choice :tag "Primary-Type"
 408                         ,@(nconc (mapcar (lambda (cell)
 409                                            (list 'item (car cell)))
 410                                          mime-content-types)
 411                                  '(string)))
 412                 ;; subtype
 413                 (choice :tag "Sub-Type"
 414                         ,@(nconc
 415                            (apply #'nconc
 416                                   (mapcar (lambda (cell)
 417                                             (mapcar (lambda (cell)
 418                                                       (list 'item (car cell)))
 419                                                     (cdr cell)))
 420                                           mime-content-types))
 421                            '(string)))
 422                 ;; parameters
 423                 (repeat :tag "Parameters of Content-Type field"
 424                         (cons string (choice string symbol)))
 425                 ;; content-transfer-encoding
 426                 (choice :tag "Encoding"
 427                         ,@(cons
 428                            '(const nil)
 429                            (mapcar (lambda (cell)
 430                                      (list 'item cell))
 431                                    (mime-encoding-list))))
 432                 ;; disposition-type
 433                 (choice :tag "Disposition-Type"
 434                         (item nil)
 435                         (item "inline")
 436                         (item "attachment")
 437                         string)
 438                 ;; parameters
 439                 (repeat :tag "Parameters of Content-Disposition field"
 440                         (cons string (choice string symbol)))))
 441   :group 'mime-edit)
 442
 443
 444 ;;; @@ about charset, encoding and transfer-level
 445 ;;;
 446
 447 (defvar mime-charset-type-list
 448   '((us-ascii           7 nil)
 449     (iso-8859-1         8 "quoted-printable")
 450     (iso-8859-2         8 "quoted-printable")
 451     (iso-8859-3         8 "quoted-printable")
 452     (iso-8859-4         8 "quoted-printable")
 453     (iso-8859-5         8 "quoted-printable")
 454     (koi8-r             8 "quoted-printable")
 455     (iso-8859-7         8 "quoted-printable")
 456     (iso-8859-8         8 "quoted-printable")
 457     (iso-8859-9         8 "quoted-printable")
 458     (iso-8859-14        8 "quoted-printable")
 459     (iso-8859-15        8 "quoted-printable")
 460     (iso-2022-jp        7 "base64")
 461     (iso-2022-jp-3      7 "base64")
 462     (iso-2022-kr        7 "base64")
 463     (euc-kr             8 "base64")
 464     (cn-gb              8 "base64")
 465     (gb2312             8 "base64")
 466     (cn-big5            8 "base64")
 467     (big5               8 "base64")
 468     (shift_jis          8 "base64")
 469     (tis-620            8 "base64")
 470     (iso-2022-jp-2      7 "base64")
 471     (iso-2022-int-1     7 "base64")))
 472
 473 (defvar mime-transfer-level 7
 474   "*A number of network transfer level.  It should be bigger than 7.")
 475 (make-variable-buffer-local 'mime-transfer-level)
 476
 477 (defsubst mime-encoding-name (transfer-level &optional not-omit)
 478   (cond ((> transfer-level 8) "binary")
 479         ((= transfer-level 8) "8bit")
 480         (not-omit "7bit")))
 481
 482 (defvar mime-transfer-level-string
 483   (mime-encoding-name mime-transfer-level 'not-omit)
 484   "A string formatted version of mime-transfer-level")
 485 (make-variable-buffer-local 'mime-transfer-level-string)
 486
 487 ;;; @@ about content transfer encoding
 488
 489 (defvar mime-content-transfer-encoding-priority-list
 490   '(nil "8bit" "binary"))
 491
 492 ;;; @@ about message inserting
 493 ;;;
 494
 495 (defvar mime-edit-yank-ignored-field-list
 496   '("Received" "Approved" "Path" "Replied" "Status"
 497     "Xref" "X-UIDL" "X-Filter" "X-Gnus-.*" "X-VM-.*")
 498   "Delete these fields from original message when it is inserted
 499 as message/rfc822 part.
 500 Each elements are regexp of field-name.")
 501
 502 (defvar mime-edit-yank-ignored-field-regexp
 503   (concat "^"
 504           (apply (function regexp-or) mime-edit-yank-ignored-field-list)
 505           ":"))
 506
 507 (defvar mime-edit-message-inserter-alist nil)
 508 (defvar mime-edit-mail-inserter-alist nil)
 509
 510
 511 ;;; @@ about message splitting
 512 ;;;
 513
 514 (defcustom mime-edit-split-message t
 515   "*Split large message if it is non-nil."
 516   :group 'mime-edit
 517   :type 'boolean)
 518
 519 (defcustom mime-edit-message-default-max-lines 1000
 520   "*Default maximum lines of a message."
 521   :group 'mime-edit
 522   :type 'integer)
 523
 524 (defcustom mime-edit-message-max-lines-alist
 525   '((news-reply-mode . 500))
 526   "Alist of major-mode vs maximum lines of a message.
 527 If it is not specified for a major-mode,
 528 `mime-edit-message-default-max-lines' is used."
 529   :group 'mime-edit
 530   :type 'list)
 531
 532 (defconst mime-edit-split-ignored-field-regexp
 533   "\\(^Content-\\|^Subject:\\|^Mime-Version:\\|^Message-Id:\\)")
 534
 535 (defcustom mime-edit-split-blind-field-regexp
 536   "\\(^[BDFbdf]cc:\\|^cc:[ \t]*$\\)"
 537   "*Regular expression to match field-name to be ignored when split sending."
 538   :group 'mime-edit
 539   :type 'regexp)
 540
 541 (defvar mime-edit-split-message-sender-alist nil)
 542
 543 (defvar mime-edit-news-reply-mode-server-running nil)
 544
 545
 546 ;;; @@ about PGP/MIME
 547 ;;;
 548
 549 (defgroup mime-edit-pgp nil
 550   "MIME edit mode (PGP/MIME)"
 551   :group 'mime-edit)
 552
 553 (defcustom mime-edit-pgp-verbose nil
 554   "If non-nil, ask the user about the current operation more verbosely."
 555   :group 'mime-edit-pgp
 556   :type 'boolean)
 557
 558 (defcustom mime-edit-pgp-signers nil
 559   "A list of your own key ID which will be used to sign a message."
 560   :group 'mime-edit-pgp
 561   :type '(repeat (string :tag "Key ID")))
 562
 563 (defcustom mime-edit-pgp-encrypt-to-self nil
 564   "If t, add your own key ID to recipient list when encryption."
 565   :group 'mime-edit-pgp
 566   :type 'boolean)
 567
 568 ;;; @@ about tag
 569 ;;;
 570
 571 (defconst mime-edit-single-part-tag-regexp
 572   "--[[][[]\\([^]]*\\)]\\([[]\\([^]]*\\)]\\|\\)]"
 573   "*Regexp of MIME tag in the form of [[CONTENT-TYPE][ENCODING]].")
 574
 575 (defconst mime-edit-quoted-single-part-tag-regexp
 576   (concat "- " (substring mime-edit-single-part-tag-regexp 1)))
 577
 578 (defconst mime-edit-multipart-beginning-regexp "--<<\\([^<>]+\\)>>-{\n")
 579
 580 (defconst mime-edit-multipart-end-regexp "--}-<<\\([^<>]+\\)>>\n")
 581
 582 (defconst mime-edit-beginning-tag-regexp
 583   (regexp-or mime-edit-single-part-tag-regexp
 584              mime-edit-multipart-beginning-regexp))
 585
 586 (defconst mime-edit-end-tag-regexp
 587   (regexp-or mime-edit-single-part-tag-regexp
 588              mime-edit-multipart-end-regexp))
 589
 590 (defconst mime-edit-tag-regexp
 591   (regexp-or mime-edit-single-part-tag-regexp
 592              mime-edit-multipart-beginning-regexp
 593              mime-edit-multipart-end-regexp))
 594
 595 (defvar mime-tag-format "--[[%s]]"
 596   "*Control-string making a MIME tag.")
 597
 598 (defvar mime-tag-format-with-encoding "--[[%s][%s]]"
 599   "*Control-string making a MIME tag with encoding.")
 600
 601
 602 ;;; @@ multipart boundary
 603 ;;;
 604
 605 (defvar mime-multipart-boundary "Multipart"
 606   "*Boundary of a multipart message.")
 607
 608
 609 ;;; @@ optional header fields
 610 ;;;
 611
 612 (defvar mime-edit-insert-user-agent-field t
 613   "*If non-nil, insert User-Agent header field.")
 614
 615 (defvar mime-edit-user-agent-value
 616   (concat (mime-product-name mime-user-interface-product)
 617           "/"
 618           (mapconcat #'number-to-string
 619                      (mime-product-version mime-user-interface-product) ".")
 620           " ("
 621           (mime-product-code-name mime-user-interface-product)
 622           ") "
 623           (mime-product-name mime-library-product)
 624           "/"
 625           (mapconcat #'number-to-string
 626                      (mime-product-version mime-library-product) ".")
 627           " ("
 628           (mime-product-code-name mime-library-product)
 629           ") "
 630           (if (fboundp 'apel-version)
 631               (concat (apel-version) " "))
 632           "EasyPG/" epg-version-number " "
 633           (if (featurep 'xemacs)
 634               (concat (cond ((and (featurep 'chise)
 635                                   (boundp 'xemacs-chise-version))
 636                              (concat "CHISE-MULE/" xemacs-chise-version))
 637                             ((featurep 'utf-2000)
 638                              (concat "UTF-2000-MULE/" utf-2000-version))
 639                             ((featurep 'mule) "MULE"))
 640                       " XEmacs"
 641                       (if (string-match "^[0-9]+\\(\\.[0-9]+\\)" emacs-version)
 642                           (concat
 643                            "/"
 644                            (substring emacs-version 0 (match-end 0))
 645                            (cond ((and (boundp 'xemacs-betaname)
 646                                        xemacs-betaname)
 647                                   ;; It does not exist in XEmacs
 648                                   ;; versions prior to 20.3.
 649                                   (concat " " xemacs-betaname))
 650                                  ((and (boundp 'emacs-patch-level)
 651                                        emacs-patch-level)
 652                                   ;; It does not exist in FSF Emacs or in
 653                                   ;; XEmacs versions earlier than 21.1.1.
 654                                   (format " (patch %d)" emacs-patch-level))
 655                                  (t ""))
 656                            " (" xemacs-codename ")"
 657                            ;; `xemacs-extra-name' has appeared in the
 658                            ;; development version of XEmacs 21.5-b8.
 659                            (if (and (boundp 'xemacs-extra-name)
 660                                     (symbol-value 'xemacs-extra-name))
 661                                (concat " " (symbol-value 'xemacs-extra-name))
 662                              "")
 663                            " ("
 664                            system-configuration ")")
 665                         " (" emacs-version ")"))
 666             (let ((ver (if (string-match "\\.[0-9]+$" emacs-version)
 667                            (substring emacs-version 0 (match-beginning 0))
 668                          emacs-version)))
 669               (if (featurep 'mule)
 670                   (if (boundp 'enable-multibyte-characters)
 671                       (concat "Emacs/" ver
 672                               " (" system-configuration ")"
 673                               (if enable-multibyte-characters
 674                                   (concat " MULE/" mule-version)
 675                                 " (with unibyte mode)")
 676                               (if (featurep 'meadow)
 677                                   (let ((mver (Meadow-version)))
 678                                     (if (string-match "^Meadow-" mver)
 679                                         (concat " Meadow/"
 680                                                 (substring mver
 681                                                            (match-end 0)))))))
 682                     (concat "MULE/" mule-version
 683                             " (based on Emacs " ver ")"))
 684                 (concat "Emacs/" ver " (" system-configuration ")")))))
 685   "Body of User-Agent field.
 686 If variable `mime-edit-insert-user-agent-field' is not nil, it is
 687 inserted into message header.")
 688
 689 \f
 690 ;;; @ constants
 691 ;;;
 692
 693 (defconst mime-tspecials-regexp "[][()<>@,;:\\\"/?.= \t]"
 694   "*Specify MIME tspecials.
 695 Tspecials means any character that matches with it in header must be quoted.")
 696
 697 (defconst mime-edit-mime-version-value
 698   (concat "1.0 (generated by " mime-edit-version ")")
 699   "MIME version number.")
 700
 701 (defconst mime-edit-mime-version-field-for-message/partial
 702   (concat "MIME-Version:"
 703           (mime-encode-field-body
 704            (concat " 1.0 (split by " mime-edit-version ")\n")
 705            "MIME-Version"))
 706   "MIME version field for message/partial.")
 707
 708
 709 ;;; @ keymap and menu
 710 ;;;
 711
 712 (defvar mime-edit-mode-flag nil)
 713 (make-variable-buffer-local 'mime-edit-mode-flag)
 714
 715 (defvar mime-edit-mode-entity-prefix "\C-c\C-x"
 716   "Keymap prefix for MIME-Edit mode commands to insert entity or set status.")
 717 (defvar mime-edit-mode-entity-map (make-sparse-keymap)
 718   "Keymap for MIME-Edit mode commands to insert entity or set status.")
 719
 720 (define-key mime-edit-mode-entity-map "\C-t" 'mime-edit-insert-text)
 721 (define-key mime-edit-mode-entity-map "\C-i" 'mime-edit-insert-file)
 722 (define-key mime-edit-mode-entity-map "\C-e" 'mime-edit-insert-external)
 723 (define-key mime-edit-mode-entity-map "\C-v" 'mime-edit-insert-voice)
 724 (define-key mime-edit-mode-entity-map "\C-y" 'mime-edit-insert-message)
 725 (define-key mime-edit-mode-entity-map "\C-m" 'mime-edit-insert-mail)
 726 (define-key mime-edit-mode-entity-map "\C-w" 'mime-edit-insert-signature)
 727 (define-key mime-edit-mode-entity-map "\C-s" 'mime-edit-insert-signature)
 728 (define-key mime-edit-mode-entity-map "\C-k" 'mime-edit-insert-key)
 729 (define-key mime-edit-mode-entity-map "t"    'mime-edit-insert-tag)
 730
 731 (define-key mime-edit-mode-entity-map "7" 'mime-edit-set-transfer-level-7bit)
 732 (define-key mime-edit-mode-entity-map "8" 'mime-edit-set-transfer-level-8bit)
 733 (define-key mime-edit-mode-entity-map "/" 'mime-edit-set-split)
 734 (define-key mime-edit-mode-entity-map "s" 'mime-edit-set-sign)
 735 (define-key mime-edit-mode-entity-map "v" 'mime-edit-set-sign)
 736 (define-key mime-edit-mode-entity-map "e" 'mime-edit-set-encrypt)
 737 (define-key mime-edit-mode-entity-map "h" 'mime-edit-set-encrypt)
 738 (define-key mime-edit-mode-entity-map "p" 'mime-edit-preview-message)
 739 (define-key mime-edit-mode-entity-map "\C-z" 'mime-edit-exit)
 740 (define-key mime-edit-mode-entity-map "?" 'mime-edit-help)
 741
 742 (defvar mime-edit-mode-enclosure-prefix "\C-c\C-m"
 743   "Keymap prefix for MIME-Edit mode commands about enclosure.")
 744 (defvar mime-edit-mode-enclosure-map (make-sparse-keymap)
 745   "Keymap for MIME-Edit mode commands about enclosure.")
 746
 747 (define-key mime-edit-mode-enclosure-map
 748   "\C-a" 'mime-edit-enclose-alternative-region)
 749 (define-key mime-edit-mode-enclosure-map
 750   "\C-p" 'mime-edit-enclose-parallel-region)
 751 (define-key mime-edit-mode-enclosure-map
 752   "\C-m" 'mime-edit-enclose-mixed-region)
 753 (define-key mime-edit-mode-enclosure-map
 754   "\C-d" 'mime-edit-enclose-digest-region)
 755 (define-key mime-edit-mode-enclosure-map
 756   "\C-s" 'mime-edit-enclose-pgp-signed-region)
 757 (define-key mime-edit-mode-enclosure-map
 758   "\C-e" 'mime-edit-enclose-pgp-encrypted-region)
 759 (define-key mime-edit-mode-enclosure-map
 760   "s" 'mime-edit-enclose-smime-signed-region)
 761 (define-key mime-edit-mode-enclosure-map
 762   "e" 'mime-edit-enclose-smime-encrypted-region)
 763 (define-key mime-edit-mode-enclosure-map
 764   "\C-q" 'mime-edit-enclose-quote-region)
 765
 766 (defvar mime-edit-mode-map (make-sparse-keymap)
 767   "Keymap for MIME-Edit mode commands.")
 768 (define-key mime-edit-mode-map
 769   mime-edit-mode-entity-prefix mime-edit-mode-entity-map)
 770 (define-key mime-edit-mode-map
 771   mime-edit-mode-enclosure-prefix mime-edit-mode-enclosure-map)
 772
 773 (defconst mime-edit-menu-title "MIME-Edit")
 774
 775 (defconst mime-edit-menu-list
 776   '((mime-help  "Describe MIME editor mode" mime-edit-help)
 777     (file       "Insert File"           mime-edit-insert-file)
 778     (external   "Insert External"       mime-edit-insert-external)
 779     (voice      "Insert Voice"          mime-edit-insert-voice)
 780     (message    "Insert Message"        mime-edit-insert-message)
 781     (mail       "Insert Mail"           mime-edit-insert-mail)
 782     (signature  "Insert Signature"      mime-edit-insert-signature)
 783     (text       "Insert Text"           mime-edit-insert-text)
 784     (tag        "Insert Tag"            mime-edit-insert-tag)
 785     (alternative "Enclose as alternative"
 786                  mime-edit-enclose-alternative-region)
 787     (parallel   "Enclose as parallel"   mime-edit-enclose-parallel-region)
 788     (mixed      "Enclose as serial"     mime-edit-enclose-mixed-region)
 789     (digest     "Enclose as digest"     mime-edit-enclose-digest-region)
 790     (signed     "Enclose as signed"     mime-edit-enclose-pgp-signed-region)
 791     (encrypted  "Enclose as encrypted"  mime-edit-enclose-pgp-encrypted-region)
 792     (quote      "Verbatim region"       mime-edit-enclose-quote-region)
 793     (key        "Insert Public Key"     mime-edit-insert-key)
 794     (split      "Set splitting"         mime-edit-set-split)
 795     (sign       "PGP sign"              mime-edit-set-sign)
 796     (encrypt    "PGP encrypt"           mime-edit-set-encrypt)
 797     (preview    "Preview Message"       mime-edit-preview-message)
 798     (level      "Toggle transfer-level" mime-edit-toggle-transfer-level))
 799   "MIME-edit menubar entry.")
 800
 801 (cond ((featurep 'xemacs)
 802        ;; modified by Pekka Marjola <pema@iki.fi>
 803        ;;       1995/9/5 (c.f. [tm-en:69])
 804        (defun mime-edit-define-menu-for-xemacs ()
 805          "Define menu for XEmacs."
 806          (cond ((featurep 'menubar)
 807                 (make-local-variable 'current-menubar)
 808                 (set-buffer-menubar current-menubar)
 809                 (add-submenu
 810                  nil
 811                  (cons mime-edit-menu-title
 812                        (mapcar (function
 813                                 (lambda (item)
 814                                   (vector (nth 1 item)(nth 2 item)
 815                                           mime-edit-mode-flag)))
 816                                mime-edit-menu-list))))))
 817
 818        ;; modified by Steven L. Baur <steve@miranova.com>
 819        ;;       1995/12/6 (c.f. [tm-en:209])
 820        (or (boundp 'mime-edit-popup-menu-for-xemacs)
 821            (setq mime-edit-popup-menu-for-xemacs
 822                  (append '("MIME Commands" "---")
 823                          (mapcar (function (lambda (item)
 824                                              (vector (nth 1 item)
 825                                                      (nth 2 item)
 826                                                      t)))
 827                                  mime-edit-menu-list)))))
 828       ((>= emacs-major-version 19)
 829        (define-key mime-edit-mode-map [menu-bar mime-edit]
 830          (cons mime-edit-menu-title
 831                (make-sparse-keymap mime-edit-menu-title)))
 832        (mapcar (function
 833                 (lambda (item)
 834                   (define-key mime-edit-mode-map
 835                     (vector 'menu-bar 'mime-edit (car item))
 836                     (cons (nth 1 item)(nth 2 item)))))
 837                (reverse mime-edit-menu-list))))
 838
 839
 840 ;;; @ functions
 841 ;;;
 842
 843 (defvar mime-edit-touched-flag nil)
 844
 845 ;;;###autoload
 846 (defun mime-edit-mode ()
 847   "MIME minor mode for editing the tagged MIME message.
 848
 849 In this mode, basically, the message is composed in the tagged MIME
 850 format. The message tag looks like:
 851
 852         --[[text/plain; charset=ISO-2022-JP][7bit]]
 853
 854 The tag specifies the MIME content type, subtype, optional parameters
 855 and transfer encoding of the message following the tag.  Messages
 856 without any tag are treated as `text/plain' by default.  Charset and
 857 transfer encoding are automatically defined unless explicitly
 858 specified.  Binary messages such as audio and image are usually
 859 hidden.  The messages in the tagged MIME format are automatically
 860 translated into a MIME compliant message when exiting this mode.
 861
 862 Available charsets depend on Emacs version being used.  The following
 863 lists the available charsets of each emacs.
 864
 865 Without mule:   US-ASCII and ISO-8859-1 (or other charset) are available.
 866 With mule:      US-ASCII, ISO-8859-* (except for ISO-8859-5), KOI8-R,
 867                 ISO-2022-JP, ISO-2022-JP-2, EUC-KR, CN-GB-2312,
 868                 CN-BIG5 and ISO-2022-INT-1 are available.
 869
 870 ISO-2022-JP-2 and ISO-2022-INT-1 charsets used in mule is expected to
 871 be used to represent multilingual text in intermixed manner.  Any
 872 languages that has no registered charset are represented as either
 873 ISO-2022-JP-2 or ISO-2022-INT-1 in mule.
 874
 875 If you want to use non-ISO-8859-1 charset in Emacs 19 or XEmacs
 876 without mule, please set variable `default-mime-charset'.  This
 877 variable must be symbol of which name is a MIME charset.
 878
 879 If you want to add more charsets in mule, please set variable
 880 `charsets-mime-charset-alist'.  This variable must be alist of which
 881 key is list of charset and value is symbol of MIME charset.  If name
 882 of coding-system is different as MIME charset, please set variable
 883 `mime-charset-coding-system-alist'.  This variable must be alist of
 884 which key is MIME charset and value is coding-system.
 885
 886 Following commands are available in addition to major mode commands:
 887
 888 \[make single part\]
 889 \\[mime-edit-insert-text]       insert a text message.
 890 \\[mime-edit-insert-file]       insert a (binary) file.
 891 \\[mime-edit-insert-external]   insert a reference to external body.
 892 \\[mime-edit-insert-voice]      insert a voice message.
 893 \\[mime-edit-insert-message]    insert a mail or news message.
 894 \\[mime-edit-insert-mail]       insert a mail message.
 895 \\[mime-edit-insert-signature]  insert a signature file at end.
 896 \\[mime-edit-insert-key]        insert PGP public key.
 897 \\[mime-edit-insert-tag]        insert a new MIME tag.
 898
 899 \[make enclosure (maybe multipart)\]
 900 \\[mime-edit-enclose-alternative-region]   enclose as multipart/alternative.
 901 \\[mime-edit-enclose-parallel-region]      enclose as multipart/parallel.
 902 \\[mime-edit-enclose-mixed-region]         enclose as multipart/mixed.
 903 \\[mime-edit-enclose-digest-region]        enclose as multipart/digest.
 904 \\[mime-edit-enclose-pgp-signed-region]    enclose as PGP signed.
 905 \\[mime-edit-enclose-pgp-encrypted-region] enclose as PGP encrypted.
 906 \\[mime-edit-enclose-quote-region]         enclose as verbose mode
 907                                            (to avoid to expand tags)
 908
 909 \[other commands\]
 910 \\[mime-edit-set-transfer-level-7bit]   set transfer-level as 7.
 911 \\[mime-edit-set-transfer-level-8bit]   set transfer-level as 8.
 912 \\[mime-edit-set-split]                 set message splitting mode.
 913 \\[mime-edit-set-sign]                  set PGP-sign mode.
 914 \\[mime-edit-set-encrypt]               set PGP-encryption mode.
 915 \\[mime-edit-preview-message]           preview editing MIME message.
 916 \\[mime-edit-exit]                      exit and translate into a MIME
 917                                         compliant message.
 918 \\[mime-edit-help]                      show this help.
 919 \\[mime-edit-maybe-translate]           exit and translate if in MIME mode,
 920                                         then split.
 921
 922 Additional commands are available in some major modes:
 923 C-c C-c         exit, translate and run the original command.
 924 C-c C-s         exit, translate and run the original command.
 925
 926 The following is a message example written in the tagged MIME format.
 927 TABs at the beginning of the line are not a part of the message:
 928
 929         This is a conventional plain text.  It should be translated
 930         into text/plain.
 931         --[[text/plain]]
 932         This is also a plain text.  But, it is explicitly specified as
 933         is.
 934         --[[text/plain; charset=ISO-8859-1]]
 935         This is also a plain text.  But charset is specified as
 936         iso-8859-1.
 937
 938         ¡Hola!  Buenos días.  ¿Cómo está usted?
 939         --[[text/enriched]]
 940         This is a <bold>enriched text</bold>.
 941         --[[image/gif][base64]]...image encoded in base64 here...
 942         --[[audio/basic][base64]]...audio encoded in base64 here...
 943
 944 User customizable variables (not documented all of them):
 945  mime-edit-prefix
 946     Specifies a key prefix for MIME minor mode commands.
 947
 948  mime-ignore-preceding-spaces
 949     Preceding white spaces in a message body are ignored if non-nil.
 950
 951  mime-ignore-trailing-spaces
 952     Trailing white spaces in a message body are ignored if non-nil.
 953
 954  mime-auto-hide-body
 955     Hide a non-textual body message encoded in base64 after insertion
 956     if non-nil.
 957
 958  mime-transfer-level
 959     A number of network transfer level.  It should be bigger than 7.
 960     If you are in 8bit-through environment, please set 8.
 961
 962  mime-edit-voice-recorder
 963     Specifies a function to record a voice message and encode it.
 964     The function `mime-edit-voice-recorder-for-sun' is for Sun
 965     SparcStations.
 966
 967  mime-edit-mode-hook
 968     Turning on MIME mode calls the value of mime-edit-mode-hook, if
 969     it is non-nil.
 970
 971  mime-edit-translate-hook
 972     The value of mime-edit-translate-hook is called just before translating
 973     the tagged MIME format into a MIME compliant message if it is
 974     non-nil.  If the hook call the function mime-edit-insert-signature,
 975     the signature file will be inserted automatically.
 976
 977  mime-edit-exit-hook
 978     Turning off MIME mode calls the value of mime-edit-exit-hook, if it is
 979     non-nil."
 980   (interactive)
 981   (if mime-edit-mode-flag
 982       (mime-edit-exit)
 983     (if mime-edit-touched-flag
 984         (mime-edit-again)
 985       (make-local-variable 'mime-edit-touched-flag)
 986       (setq mime-edit-touched-flag t)
 987       (turn-on-mime-edit))))
 988
 989
 990 (cond ((featurep 'xemacs)
 991        (add-minor-mode 'mime-edit-mode-flag
 992                        '((" MIME-Edit "  mime-transfer-level-string))
 993                        mime-edit-mode-map
 994                        nil
 995                        'mime-edit-mode))
 996       (t
 997        (set-alist 'minor-mode-alist
 998                   'mime-edit-mode-flag
 999                   '((" MIME-Edit "  mime-transfer-level-string)))
1000        (set-alist 'minor-mode-map-alist
1001                   'mime-edit-mode-flag
1002                   mime-edit-mode-map)))
1003
1004
1005 ;;;###autoload
1006 (defun turn-on-mime-edit ()
1007   "Unconditionally turn on MIME-Edit mode."
1008   (interactive)
1009   (if mime-edit-mode-flag
1010       (error "You are already editing a MIME message.")
1011     (setq mime-edit-mode-flag t)
1012
1013     ;; Set transfer level into mode line
1014     ;;
1015     (setq mime-transfer-level-string
1016           (mime-encoding-name mime-transfer-level 'not-omit))
1017     (force-mode-line-update)
1018
1019     ;; Define menu for XEmacs.
1020     (if (featurep 'xemacs)
1021         (mime-edit-define-menu-for-xemacs))
1022
1023     ;; I don't care about saving these.
1024     (setq paragraph-start
1025           (regexp-or mime-edit-single-part-tag-regexp
1026                      paragraph-start))
1027     (setq paragraph-separate
1028           (regexp-or mime-edit-single-part-tag-regexp
1029                      paragraph-separate))
1030     (run-hooks 'mime-edit-mode-hook)
1031     (message
1032      "%s"
1033      (substitute-command-keys
1034       "Type \\[mime-edit-exit] to exit MIME mode, and type \\[mime-edit-help] to get help."))))
1035
1036 ;;;###autoload
1037 (defalias 'edit-mime 'turn-on-mime-edit) ; for convenience
1038
1039
1040 (defun mime-edit-exit (&optional nomime no-error)
1041   "Translate the tagged MIME message into a MIME compliant message.
1042 With no argument encode a message in the buffer into MIME, otherwise
1043 just return to previous mode."
1044   (interactive "P")
1045   (if (not mime-edit-mode-flag)
1046       (if (null no-error)
1047           (error "You aren't editing a MIME message."))
1048     (if (not nomime)
1049         (progn
1050           (run-hooks 'mime-edit-translate-hook)
1051           (mime-edit-translate-buffer)))
1052     ;; Restore previous state.
1053     (setq mime-edit-mode-flag nil)
1054     (if (and (featurep 'xemacs)
1055              (featurep 'menubar))
1056         (delete-menu-item (list mime-edit-menu-title)))
1057     (set-buffer-modified-p (buffer-modified-p))
1058     (run-hooks 'mime-edit-exit-hook)
1059     (message "Exit MIME editor mode.")))
1060
1061 (defun mime-edit-maybe-translate ()
1062   (interactive)
1063   (mime-edit-exit nil t)
1064   (call-interactively 'mime-edit-maybe-split-and-send))
1065
1066 (defun mime-edit-help ()
1067   "Show help message about MIME mode."
1068   (interactive)
1069   (with-output-to-temp-buffer "*Help*"
1070     (princ "MIME editor mode:\n")
1071     (princ (documentation 'mime-edit-mode))
1072     (print-help-return-message)))
1073
1074 (defun mime-edit-insert-text (&optional subtype)
1075   "Insert a text message.
1076 Charset is automatically obtained from the `charsets-mime-charset-alist'.
1077 If optional argument SUBTYPE is not nil, text/SUBTYPE tag is inserted."
1078   (interactive)
1079   (let ((ret (mime-edit-insert-tag "text" subtype nil)))
1080     (when ret
1081       (if (looking-at mime-edit-single-part-tag-regexp)
1082           (progn
1083             ;; Make a space between the following message.
1084             (insert "\n")
1085             (forward-char -1)))
1086       (if (and (member (cadr ret) '("enriched"))
1087                (fboundp 'enriched-mode))
1088           (enriched-mode t)
1089         (if (boundp 'enriched-mode)
1090             (enriched-mode -1))))))
1091
1092 (defun mime-edit-insert-file (file &optional verbose)
1093   "Insert a message from a file."
1094   (interactive "fInsert file as MIME message: \nP")
1095   (let*  ((guess (mime-find-file-type file))
1096           (type (nth 0 guess))
1097           (subtype (nth 1 guess))
1098           (parameters (nth 2 guess))
1099           (encoding (nth 3 guess))
1100           (disposition-type (nth 4 guess))
1101           (disposition-params (nth 5 guess)))
1102     (if verbose
1103         (setq type    (mime-prompt-for-type type)
1104               subtype (mime-prompt-for-subtype type subtype)))
1105     (if (or (interactive-p) verbose)
1106         (setq encoding (mime-prompt-for-encoding encoding)))
1107     (if (or (consp parameters) (stringp disposition-type))
1108         (let ((rest parameters) cell attribute value)
1109           (setq parameters "")
1110           (while rest
1111             (setq cell (car rest))
1112             (setq attribute (car cell))
1113             (setq value (cdr cell))
1114             (if (eq value 'file)
1115                 (setq value (std11-wrap-as-quoted-string
1116                              (file-name-nondirectory file))))
1117             (setq parameters (concat parameters "; " attribute "=" value))
1118             (setq rest (cdr rest)))
1119           (if disposition-type
1120               (progn
1121                 (setq parameters
1122                       (concat parameters "\n"
1123                               "Content-Disposition: " disposition-type))
1124                 (setq rest disposition-params)
1125                 (while rest
1126                   (setq cell (car rest))
1127                   (setq attribute (car cell))
1128                   (setq value (cdr cell))
1129                   (if (eq value 'file)
1130                       (setq value (std11-wrap-as-quoted-string
1131                                    (file-name-nondirectory file))))
1132                   (setq parameters
1133                         (concat parameters "; " attribute "=" value))
1134                   (setq rest (cdr rest)))))))
1135     (mime-edit-insert-tag type subtype parameters)
1136     (mime-edit-insert-binary-file file encoding)))
1137
1138 (defun mime-edit-insert-external ()
1139   "Insert a reference to external body."
1140   (interactive)
1141   (mime-edit-insert-tag "message" "external-body" nil ";\n\t")
1142   ;;(forward-char -1)
1143   ;;(insert "Content-Description: " (read-string "Content-Description: ") "\n")
1144   ;;(forward-line 1)
1145   (let* ((pritype (mime-prompt-for-type))
1146          (subtype (mime-prompt-for-subtype pritype))
1147          (parameters (mime-prompt-for-parameters pritype subtype ";\n\t")))
1148     (and pritype
1149          subtype
1150          (insert "Content-Type: "
1151                  pritype "/" subtype (or parameters "") "\n")))
1152   (if (and (not (eobp))
1153            (not (looking-at mime-edit-single-part-tag-regexp)))
1154       (insert (mime-make-text-tag) "\n")))
1155
1156 (defun mime-edit-insert-voice ()
1157   "Insert a voice message."
1158   (interactive)
1159   (let ((encoding
1160          (completing-read
1161           "What transfer encoding: "
1162           (mime-encoding-alist) nil t nil)))
1163     (mime-edit-insert-tag "audio" "basic" nil)
1164     (mime-edit-define-encoding encoding)
1165     (save-restriction
1166       (narrow-to-region (point)(point))
1167       (unwind-protect
1168           (funcall mime-edit-voice-recorder encoding)
1169         (progn
1170           (insert "\n")
1171           (add-text-properties
1172            (point-min)(point-max) '(invisible t mime-edit-invisible t))
1173           (goto-char (point-max)))))))
1174
1175 (defun mime-edit-insert-signature (&optional arg)
1176   "Insert a signature file."
1177   (interactive "P")
1178   (let ((signature-insert-hook
1179          (function
1180           (lambda ()
1181             (let ((items (mime-find-file-type signature-file-name)))
1182               (apply (function mime-edit-insert-tag)
1183                      (car items) (cadr items) (list (caddr items))))))))
1184     (insert-signature arg)))
1185
1186 \f
1187 ;; Insert a new tag around a point.
1188
1189 (defun mime-edit-insert-tag (&optional pritype subtype parameters delimiter)
1190   "Insert new MIME tag and return a list of PRITYPE, SUBTYPE, and PARAMETERS.
1191 If nothing is inserted, return nil."
1192   (interactive)
1193   (let ((p (point)))
1194     (mime-edit-goto-tag)
1195     (if (and (re-search-forward mime-edit-tag-regexp nil t)
1196              (< (match-beginning 0) p)
1197              (< p (match-end 0)))
1198         (goto-char (match-beginning 0))
1199       (goto-char p)))
1200   (let ((oldtag nil)
1201         (newtag nil)
1202         (current (point)))
1203     (setq pritype
1204           (or pritype
1205               (mime-prompt-for-type)))
1206     (setq subtype
1207           (or subtype
1208               (mime-prompt-for-subtype pritype)))
1209     (setq parameters
1210           (or parameters
1211               (mime-prompt-for-parameters pritype subtype delimiter)))
1212     ;; Make a new MIME tag.
1213     (setq newtag (mime-make-tag pritype subtype parameters))
1214     ;; Find an current MIME tag.
1215     (setq oldtag
1216           (save-excursion
1217             (if (mime-edit-goto-tag)
1218                 (buffer-substring (match-beginning 0) (match-end 0))
1219               ;; Assume content type is 'text/plan'.
1220               (mime-make-tag "text" "plain"))))
1221     ;; We are only interested in TEXT.
1222     (if (and oldtag
1223              (not (mime-test-content-type
1224                    (mime-edit-get-contype oldtag) "text")))
1225         (setq oldtag nil))
1226     ;; Make a new tag.
1227     (if (or (not oldtag)                ;Not text
1228             (or mime-ignore-same-text-tag
1229                 (not (string-equal oldtag newtag))))
1230         (progn
1231           ;; Mark the beginning of the tag for convenience.
1232           (push-mark (point) 'nomsg)
1233           (insert newtag "\n")
1234           (list pritype subtype parameters) ;New tag is created.
1235           )
1236       ;; Restore previous point.
1237       (goto-char current)
1238       nil                               ;Nothing is created.
1239       )))
1240
1241 (defun mime-edit-insert-binary-file (file &optional encoding)
1242   "Insert binary FILE at point.
1243 Optional argument ENCODING specifies an encoding method such as base64."
1244   (let* ((tagend (1- (point)))          ;End of the tag
1245          (hide-p (and mime-auto-hide-body
1246                       (stringp encoding)
1247                       (not
1248                        (let ((en (downcase encoding)))
1249                          (or (string-equal en "7bit")
1250                              (string-equal en "8bit")
1251                              (string-equal en "binary")))))))
1252     (save-restriction
1253       (narrow-to-region (point)(point))
1254       (mime-insert-encoded-file file encoding)
1255       (if hide-p
1256           (add-text-properties
1257            (point-min)(point-max) '(invisible t mime-edit-invisible t)))
1258       (goto-char (point-max)))
1259     (or hide-p
1260         (looking-at mime-edit-tag-regexp)
1261         (= (point)(point-max))
1262         (mime-edit-insert-tag "text" "plain"))
1263     ;; Define encoding even if it is 7bit.
1264     (if (stringp encoding)
1265         (save-excursion
1266           (goto-char tagend) ; Make sure which line the tag is on.
1267           (mime-edit-define-encoding encoding)))))
1268
1269 \f
1270 ;; Commands work on a current message flagment.
1271
1272 (defun mime-edit-goto-tag ()
1273   "Search for the beginning of the tagged MIME message."
1274   (let ((current (point)))
1275     (if (looking-at mime-edit-tag-regexp)
1276         t
1277       ;; At first, go to the end.
1278       (cond ((re-search-forward mime-edit-beginning-tag-regexp nil t)
1279              (goto-char (1- (match-beginning 0))) ;For multiline tag
1280              )
1281             (t
1282              (goto-char (point-max))))
1283       ;; Then search for the beginning.
1284       (re-search-backward mime-edit-end-tag-regexp nil t)
1285       (or (looking-at mime-edit-beginning-tag-regexp)
1286           ;; Restore previous point.
1287           (progn
1288             (goto-char current)
1289             nil)))))
1290
1291 (defun mime-edit-content-beginning ()
1292   "Return the point of the beginning of content."
1293   (save-excursion
1294     (let ((beg (save-excursion
1295                  (beginning-of-line) (point))))
1296       (if (mime-edit-goto-tag)
1297           (let ((top (point)))
1298             (goto-char (match-end 0))
1299             (if (and (= beg top)
1300                      (= (following-char) ?\^M))
1301                 (point)
1302               (forward-line 1)
1303               (point)))
1304         ;; Default text/plain tag.
1305         (goto-char (point-min))
1306         (re-search-forward
1307          (concat "\n" (regexp-quote mail-header-separator)
1308                  (if mime-ignore-preceding-spaces
1309                      "[ \t\n]*\n" "\n")) nil 'move)
1310         (point)))))
1311
1312 (defun mime-edit-content-end ()
1313   "Return the point of the end of content."
1314   (save-excursion
1315     (if (mime-edit-goto-tag)
1316         (progn
1317           (goto-char (1+ (match-end 0)))
1318           (if (get-text-property (point) 'mime-edit-invisible)
1319               (or (next-single-property-change (point) 'mime-edit-invisible)
1320                   (point-max))
1321             ;; Move to the end of this text.
1322             (if (re-search-forward mime-edit-tag-regexp nil 'move)
1323                 ;; Don't forget a multiline tag.
1324                 (goto-char (match-beginning 0)))
1325             (point)))
1326       ;; Assume the message begins with text/plain.
1327       (goto-char (mime-edit-content-beginning))
1328       (if (re-search-forward mime-edit-tag-regexp nil 'move)
1329           ;; Don't forget a multiline tag.
1330           (goto-char (match-beginning 0)))
1331       (point))))
1332
1333 (defun mime-edit-define-charset (charset)
1334   "Set charset of current tag to CHARSET."
1335   (save-excursion
1336     (if (mime-edit-goto-tag)
1337         (let ((tag (buffer-substring (match-beginning 0) (match-end 0))))
1338           (delete-region (match-beginning 0) (match-end 0))
1339           (insert
1340            (mime-create-tag
1341             (mime-edit-set-parameter
1342              (mime-edit-get-contype tag)
1343              "charset"
1344              (let ((comment (get charset 'mime-charset-comment)))
1345                (if comment
1346                    (concat (upcase (symbol-name charset)) " (" comment ")")
1347                  (upcase (symbol-name charset)))))
1348             (mime-edit-get-encoding tag)))))))
1349
1350 (defun mime-edit-define-encoding (encoding)
1351   "Set encoding of current tag to ENCODING."
1352   (save-excursion
1353     (if (mime-edit-goto-tag)
1354         (let ((tag (buffer-substring (match-beginning 0) (match-end 0))))
1355           (delete-region (match-beginning 0) (match-end 0))
1356           (insert (mime-create-tag (mime-edit-get-contype tag) encoding))))))
1357
1358 (defun mime-edit-choose-charset ()
1359   "Choose charset of a text following current point."
1360   (detect-mime-charset-region (point) (mime-edit-content-end)))
1361
1362 (defun mime-make-text-tag (&optional subtype)
1363   "Make a tag for a text after current point.
1364 Subtype of text type can be specified by an optional argument SUBTYPE.
1365 Otherwise, it is obtained from mime-content-types."
1366   (let* ((pritype "text")
1367          (subtype (or subtype
1368                       (car (car (cdr (assoc pritype mime-content-types)))))))
1369     ;; Charset should be defined later.
1370     (mime-make-tag pritype subtype)))
1371
1372 \f
1373 ;; Tag handling functions
1374
1375 (defun mime-make-tag (pritype subtype &optional parameters encoding)
1376   "Make a tag of MIME message of PRITYPE, SUBTYPE and optional PARAMETERS."
1377   (mime-create-tag (concat (or pritype "") "/" (or subtype "")
1378                            (or parameters ""))
1379                    encoding))
1380
1381 (defun mime-create-tag (contype &optional encoding)
1382   "Make a tag with CONTENT-TYPE and optional ENCODING."
1383   (format (if encoding mime-tag-format-with-encoding mime-tag-format)
1384           contype encoding))
1385
1386 (defun mime-edit-get-contype (tag)
1387   "Return Content-Type (including parameters) of TAG."
1388   (and (stringp tag)
1389        (or (string-match mime-edit-single-part-tag-regexp tag)
1390            (string-match mime-edit-multipart-beginning-regexp tag)
1391            (string-match mime-edit-multipart-end-regexp tag))
1392        (substring tag (match-beginning 1) (match-end 1))))
1393
1394 (defun mime-edit-get-encoding (tag)
1395   "Return encoding of TAG."
1396   (and (stringp tag)
1397        (string-match mime-edit-single-part-tag-regexp tag)
1398        (match-beginning 3)
1399        (not (= (match-beginning 3) (match-end 3)))
1400        (substring tag (match-beginning 3) (match-end 3))))
1401
1402 (defun mime-get-parameter (contype parameter)
1403   "For given CONTYPE return value for PARAMETER.
1404 Nil if no such parameter."
1405   (if (string-match
1406        (concat
1407         ";[ \t\n]*"
1408         (regexp-quote parameter)
1409         "[ \t\n]*=[ \t\n]*\\([^\" \t\n;]*\\|\"[^\"]*\"\\)\\([ \t\n]*;\\|$\\)")
1410        contype)
1411       (substring contype (match-beginning 1) (match-end 1))
1412     nil                                 ;No such parameter
1413     ))
1414
1415 (defun mime-edit-set-parameter (contype parameter value)
1416   "For given CONTYPE set PARAMETER to VALUE."
1417   (let (ctype opt-fields)
1418     (if (string-match "\n[^ \t\n\r]+:" contype)
1419         (setq ctype (substring contype 0 (match-beginning 0))
1420               opt-fields (substring contype (match-beginning 0)))
1421       (setq ctype contype))
1422     (if (string-match
1423          (concat
1424           ";[ \t\n]*\\("
1425           (regexp-quote parameter)
1426           "[ \t\n]*=[ \t\n]*\\([^\" \t\n;]*\\|\"[^\"]*\"\\)\\)[ \t\n]*\\(;\\|$\\)")
1427          ctype)
1428         ;; Change value
1429         (concat (substring ctype 0 (match-beginning 1))
1430                 parameter "=" value
1431                 (substring ctype (match-end 1))
1432                 opt-fields)
1433       (concat ctype "; " parameter "=" value opt-fields)
1434       )))
1435
1436 (defun mime-strip-parameters (contype)
1437   "Return primary content-type and subtype without parameters for CONTYPE."
1438   (if (string-match "^[ \t]*\\([^; \t\n]*\\)" contype)
1439       (substring contype (match-beginning 1) (match-end 1)) nil))
1440
1441 (defun mime-test-content-type (contype type &optional subtype)
1442   "Test if CONTYPE is a TYPE and an optional SUBTYPE."
1443   (and (stringp contype)
1444        (stringp type)
1445        (string-match
1446         (concat "^[ \t]*" (downcase type) "/" (downcase (or subtype "")))
1447         (downcase contype))))
1448
1449 \f
1450 ;; Basic functions
1451
1452 (defun mime-find-file-type (file)
1453   "Guess Content-Type, subtype, and parameters from FILE."
1454   (let ((guess nil)
1455         (guesses mime-file-types))
1456     (while (and (not guess) guesses)
1457       (if (string-match (car (car guesses)) file)
1458           (setq guess (cdr (car guesses))))
1459       (setq guesses (cdr guesses)))
1460     guess))
1461
1462 (defun mime-prompt-for-type (&optional default)
1463   "Ask for Content-type."
1464   (let ((type ""))
1465     ;; Repeat until primary content type is specified.
1466     (while (string-equal type "")
1467       (setq type
1468             (completing-read "What content type: "
1469                              mime-content-types
1470                              nil
1471                              'require-match ;Type must be specified.
1472                              default))
1473       (if (string-equal type "")
1474           (progn
1475             (message "Content type is required.")
1476             (beep)
1477             (sit-for 1))))
1478     type))
1479
1480 (defun mime-prompt-for-subtype (type &optional default)
1481   "Ask for subtype of media-type TYPE."
1482   (let ((subtypes (cdr (assoc type mime-content-types))))
1483     (or (and default
1484              (assoc default subtypes))
1485         (setq default (car (car subtypes)))))
1486   (let* ((answer
1487           (completing-read
1488            (if default
1489                (concat
1490                 "What content subtype: (default " default ") ")
1491              "What content subtype: ")
1492            (cdr (assoc type mime-content-types))
1493            nil
1494            'require-match               ;Subtype must be specified.
1495            nil)))
1496     (if (string-equal answer "") default answer)))
1497
1498 (defun mime-prompt-for-parameters (pritype subtype &optional delimiter)
1499   "Ask for Content-type parameters of Content-Type PRITYPE and SUBTYPE.
1500 Optional DELIMITER specifies parameter delimiter (';' by default)."
1501   (let* ((delimiter (or delimiter "; "))
1502          (parameters
1503           (mapconcat
1504            (function identity)
1505            (delq nil
1506                  (mime-prompt-for-parameters-1
1507                   (cdr (assoc subtype
1508                               (cdr (assoc pritype mime-content-types))))))
1509            delimiter)))
1510     (if (and (stringp parameters)
1511              (not (string-equal parameters "")))
1512         (concat delimiter parameters)
1513       ""                                ;"" if no parameters
1514       )))
1515
1516 (defun mime-prompt-for-parameters-1 (optlist)
1517   (apply (function append)
1518          (mapcar (function mime-prompt-for-parameter) optlist)))
1519
1520 (defun mime-prompt-for-parameter (parameter)
1521   "Ask for PARAMETER.
1522 Parameter must be '(PROMPT CHOICE1 (CHOICE2...))."
1523   (let* ((prompt (car parameter))
1524          (choices (mapcar (function
1525                            (lambda (e)
1526                              (if (consp e) e (list e))))
1527                           (cdr parameter)))
1528          (default (car (car choices)))
1529          (answer nil))
1530     (if choices
1531         (progn
1532           (setq answer
1533                 (completing-read
1534                  (concat "What " prompt
1535                          ": (default "
1536                          (if (string-equal default "") "\"\"" default)
1537                          ") ")
1538                  choices nil nil ""))
1539           ;; If nothing is selected, use default.
1540           (if (string-equal answer "")
1541               (setq answer default)))
1542       (setq answer
1543             (read-string (concat "What " prompt ": "))))
1544     (cons (if (and answer
1545                    (not (string-equal answer "")))
1546               (concat prompt "="
1547                       ;; Note: control characters ignored!
1548                       (if (string-match mime-tspecials-regexp answer)
1549                           (concat "\"" answer "\"") answer)))
1550           (mime-prompt-for-parameters-1 (cdr (assoc answer (cdr parameter)))))))
1551
1552 (defun mime-prompt-for-encoding (default)
1553   "Ask for Content-Transfer-Encoding."
1554   (let (encoding)
1555     (while (string=
1556             (setq encoding
1557                   (completing-read
1558                    "What transfer encoding: "
1559                    (mime-encoding-alist) nil t default))
1560             ""))
1561     encoding))
1562
1563 \f
1564 ;;; @ Translate the tagged MIME messages into a MIME compliant message.
1565 ;;;
1566
1567 (defvar mime-edit-translate-buffer-hook
1568   '(mime-edit-pgp-enclose-buffer
1569     mime-edit-translate-body
1570     mime-edit-translate-header))
1571
1572 (defun mime-edit-translate-header ()
1573   "Encode the message header into network representation."
1574   (mime-encode-header-in-buffer 'code-conversion)
1575   (run-hooks 'mime-edit-translate-header-hook))
1576
1577 (defun mime-edit-translate-buffer ()
1578   "Encode the tagged MIME message in current buffer in MIME compliant message."
1579   (interactive)
1580   (undo-boundary)
1581   (if (catch 'mime-edit-error
1582         (save-excursion
1583           (run-hooks 'mime-edit-translate-buffer-hook)))
1584       (progn
1585         (undo)
1586         (error "Translation error!"))))
1587
1588 (defun mime-edit-find-inmost ()
1589   (goto-char (point-min))
1590   (if (re-search-forward mime-edit-multipart-beginning-regexp nil t)
1591       (let ((bb (match-beginning 0))
1592             (be (match-end 0))
1593             (type (buffer-substring (match-beginning 1)(match-end 1)))
1594             end-exp eb)
1595         (setq end-exp (format "--}-<<%s>>\n" type))
1596         (widen)
1597         (if (re-search-forward end-exp nil t)
1598             (setq eb (match-beginning 0))
1599           (setq eb (point-max)))
1600         (narrow-to-region be eb)
1601         (goto-char be)
1602         (if (re-search-forward mime-edit-multipart-beginning-regexp nil t)
1603             (progn
1604               (narrow-to-region (match-beginning 0)(point-max))
1605               (mime-edit-find-inmost))
1606           (widen)
1607           (list type bb be eb)))))
1608
1609 (defun mime-edit-process-multipart-1 (boundary)
1610   (let ((ret (mime-edit-find-inmost)))
1611     (if ret
1612         (let ((type (car ret))
1613               (bb (nth 1 ret))(be (nth 2 ret))
1614               (eb (nth 3 ret)))
1615           (narrow-to-region bb eb)
1616           (delete-region bb be)
1617           (setq bb (point-min))
1618           (setq eb (point-max))
1619           (widen)
1620           (goto-char eb)
1621           (if (looking-at mime-edit-multipart-end-regexp)
1622               (let ((beg (match-beginning 0))
1623                     (end (match-end 0)))
1624                 (delete-region beg end)
1625                 (or (looking-at mime-edit-beginning-tag-regexp)
1626                     (looking-at mime-edit-multipart-end-regexp)
1627                     (eobp)
1628                     (insert (concat (mime-make-text-tag) "\n")))))
1629           (cond ((string-equal type "quote")
1630                  (mime-edit-enquote-region bb eb))
1631                 ((string-equal type "pgp-signed")
1632                  (mime-edit-sign-pgp-mime bb eb boundary))
1633                 ((string-equal type "pgp-encrypted")
1634                  (mime-edit-encrypt-pgp-mime bb eb boundary))
1635                 ((string-equal type "smime-signed")
1636                  (mime-edit-sign-smime bb eb boundary))
1637                 ((string-equal type "smime-encrypted")
1638                  (mime-edit-encrypt-smime bb eb boundary))
1639                 (t
1640                  (setq boundary
1641                        (nth 2 (mime-edit-translate-region bb eb
1642                                                             boundary t)))
1643                  (goto-char bb)
1644                  (insert
1645                   (format "--[[multipart/%s;
1646  boundary=\"%s\"][7bit]]\n"
1647                           type boundary))))
1648           boundary))))
1649
1650 (defun mime-edit-enquote-region (beg end)
1651   (save-excursion
1652     (save-restriction
1653       (narrow-to-region beg end)
1654       (goto-char beg)
1655       (while (re-search-forward mime-edit-single-part-tag-regexp nil t)
1656         (let ((tag (buffer-substring (match-beginning 0)(match-end 0))))
1657           (replace-match (concat "- " (substring tag 1))))))))
1658
1659 (defun mime-edit-dequote-region (beg end)
1660   (save-excursion
1661     (save-restriction
1662       (narrow-to-region beg end)
1663       (goto-char beg)
1664       (while (re-search-forward
1665               mime-edit-quoted-single-part-tag-regexp nil t)
1666         (let ((tag (buffer-substring (match-beginning 0)(match-end 0))))
1667           (replace-match (concat "-" (substring tag 2))))))))
1668
1669 (defvar mime-edit-pgp-user-id nil)
1670
1671 (defun mime-edit-delete-trailing-whitespace ()
1672   (save-match-data
1673     (save-excursion
1674       (goto-char (point-min))
1675       (while (re-search-forward "[ \t]+$" nil t)
1676         (delete-region (match-beginning 0) (match-end 0))))))
1677
1678 (defun mime-edit-sign-pgp-mime (beg end boundary)
1679   (save-excursion
1680     (save-restriction
1681       (let* ((from (std11-field-body "From" mail-header-separator))
1682              (ret (progn
1683                     (narrow-to-region beg end)
1684                     (mime-edit-translate-region beg end boundary)))
1685              (ctype    (car ret))
1686              (encoding (nth 1 ret))
1687              (pgp-boundary (concat "pgp-sign-" boundary))
1688              (context (epg-make-context))
1689              (index 0)
1690              plain signature micalg)
1691         (mime-edit-delete-trailing-whitespace) ; RFC3156
1692         (goto-char beg)
1693         (insert (format "Content-Type: %s\n" ctype))
1694         (if encoding
1695             (insert (format "Content-Transfer-Encoding: %s\n" encoding)))
1696         (insert "\n")
1697         (epg-context-set-armor context t)
1698         (epg-context-set-textmode context nil)
1699         (if mime-edit-pgp-verbose
1700             (epg-context-set-signers
1701              context
1702              (epa-select-keys
1703               context
1704               "\
1705 Select keys for signing.
1706 If no one is selected, default secret key is used.  "
1707               (if from
1708                   (cons (nth 1 (std11-extract-address-components from))
1709                         mime-edit-pgp-signers))
1710               t))
1711           (if mime-edit-pgp-signers
1712               (epg-context-set-signers
1713                context
1714                (mapcar (lambda (name)
1715                          (car (epg-list-keys context name t)))
1716                        mime-edit-pgp-signers))))
1717         (setq plain (buffer-substring (point-min) (point-max)))
1718         (while (string-match "\r?\n" plain index)
1719           (if (eq (aref plain (match-beginning 0)) ?\r)
1720               (setq index (match-end 0))
1721             (setq plain (replace-match "\r\n" t t plain)
1722                   index (1+ (match-end 0)))))
1723         (condition-case error
1724             (setq signature
1725                   (epg-sign-string context plain 'detached))
1726           (error (signal 'mime-edit-error (cdr error))))
1727         (setq micalg (epg-new-signature-digest-algorithm
1728                       (car (epg-context-result-for context 'sign))))
1729         (goto-char beg)
1730         (insert (format "--[[multipart/signed;
1731  boundary=\"%s\"%s;
1732  protocol=\"application/pgp-signature\"][7bit]]
1733 --%s
1734 "
1735                         pgp-boundary
1736                         (if micalg
1737                             (concat "; micalg=pgp-"
1738                                     (downcase
1739                                      (cdr (assq micalg
1740                                                 epg-digest-algorithm-alist))))
1741                           "")
1742                         pgp-boundary))
1743         (goto-char (point-max))
1744         (insert (format "\n--%s
1745 Content-Type: application/pgp-signature
1746 Content-Transfer-Encoding: 7bit
1747 Content-Description: OpenPGP Digital Signature
1748
1749 " pgp-boundary))
1750         (insert signature)
1751         (goto-char (point-max))
1752         (insert (format "\n--%s--\n" pgp-boundary))))))
1753
1754 (defvar mime-edit-encrypt-recipient-fields-list '("To" "cc"))
1755
1756 (defun mime-edit-make-encrypt-recipient-header ()
1757   (let* ((names mime-edit-encrypt-recipient-fields-list)
1758          (values
1759           (std11-field-bodies (cons "From" names)
1760                               nil mail-header-separator))
1761          (from (prog1
1762                    (car values)
1763                  (setq values (cdr values))))
1764          (header (and (stringp from)
1765                       (if (string-equal from "")
1766                           ""
1767                         (format "From: %s\n" from))))
1768          recipients)
1769     (while (and names values)
1770       (let ((name (car names))
1771             (value (car values)))
1772         (and (stringp value)
1773              (or (string-equal value "")
1774                  (progn
1775                    (setq header (concat header name ": " value "\n")
1776                          recipients (if recipients
1777                                         (concat recipients " ," value)
1778                                       value))))))
1779       (setq names (cdr names)
1780             values (cdr values)))
1781     (vector from recipients header)))
1782
1783 (defun mime-edit-encrypt-pgp-mime (beg end boundary)
1784   (save-excursion
1785     (save-restriction
1786       (let* ((config (epg-configuration))
1787              (ret (mime-edit-make-encrypt-recipient-header))
1788              (recipients (aref ret 1))
1789              (header (aref ret 2)))
1790         (setq recipients
1791               (apply #'nconc
1792                      (mapcar (lambda (recipient)
1793                                (setq recipient
1794                                      (nth 1 (std11-extract-address-components
1795                                              recipient)))
1796                                (or (epg-expand-group config recipient)
1797                                    (list recipient)))
1798                              (delete "" (split-string recipients
1799                                                       "[ \f\t\n\r\v,]+")))))
1800         (narrow-to-region beg end)
1801         (let* ((ret
1802                 (mime-edit-translate-region beg end boundary))
1803                (ctype    (car ret))
1804                (encoding (nth 1 ret))
1805                (pgp-boundary (concat "pgp-" boundary))
1806                (context (epg-make-context))
1807                cipher)
1808           (goto-char beg)
1809           (insert header)
1810           (insert (format "Content-Type: %s\n" ctype))
1811           (if encoding
1812               (insert (format "Content-Transfer-Encoding: %s\n" encoding)))
1813           (insert "\n")
1814           (mime-encode-header-in-buffer)
1815           (epg-context-set-armor context t)
1816           (if mime-edit-pgp-verbose
1817               (setq recipients
1818                     (epa-select-keys context "\
1819 Select recipients for encryption.
1820 If no one is selected, symmetric encryption will be performed.  "
1821                                      recipients))
1822             (setq recipients
1823                   (delq nil (mapcar (lambda (name)
1824                                       (car (epg-list-keys context name)))
1825                                     recipients))))
1826           (condition-case error
1827               (setq cipher
1828                     (epg-encrypt-string
1829                      context
1830                      (buffer-substring (point-min) (point-max))
1831                      recipients))
1832             (error (signal 'mime-edit-error (cdr error))))
1833           (delete-region (point-min)(point-max))
1834           (goto-char beg)
1835           (insert (format "--[[multipart/encrypted;
1836  boundary=\"%s\";
1837  protocol=\"application/pgp-encrypted\"][7bit]]
1838 --%s
1839 Content-Type: application/pgp-encrypted
1840
1841 --%s
1842 Content-Type: application/octet-stream
1843 Content-Transfer-Encoding: 7bit
1844
1845 " pgp-boundary pgp-boundary pgp-boundary))
1846           (insert cipher)
1847           (goto-char (point-max))
1848           (insert (format "\n--%s--\n" pgp-boundary)))))))
1849
1850 (defun mime-edit-convert-lbt-string (string)
1851   (let ((index 0))
1852     (while (setq index (string-match "\n" string index))
1853       (setq string (replace-match "\r\n" nil nil string)
1854             index (+ index 2)))         ;(length "\r\n")
1855     string))
1856
1857 (defun mime-edit-sign-smime (beg end boundary)
1858   (save-excursion
1859     (save-restriction
1860       (let* ((from (std11-field-body "From" mail-header-separator))
1861              (ret (progn
1862                     (narrow-to-region beg end)
1863                     (mime-edit-translate-region beg end boundary)))
1864              (ctype    (car ret))
1865              (encoding (nth 1 ret))
1866              (smime-boundary (concat "smime-sign-" boundary))
1867              (context (epg-make-context 'CMS))
1868              signature micalg)
1869         (goto-char beg)
1870         (insert (format "Content-Type: %s\n" ctype))
1871         (if encoding
1872             (insert (format "Content-Transfer-Encoding: %s\n" encoding)))
1873         (insert "\n")
1874         (epg-context-set-signers
1875          context
1876          (epa-select-keys
1877           context
1878           "\
1879 Select keys for signing.
1880 If no one is selected, default secret key is used.  "
1881           (if from
1882               (list (nth 1 (std11-extract-address-components from))))
1883           t))
1884         (condition-case error
1885             (setq signature
1886                   (epg-sign-string context
1887                                    (mime-edit-convert-lbt-string
1888                                     (buffer-substring (point-min) (point-max)))
1889                                    'detached))
1890           (error (signal 'mime-edit-error (cdr error))))
1891         (setq micalg (epg-new-signature-digest-algorithm
1892                       (car (epg-context-result-for context 'sign))))
1893         (goto-char beg)
1894         (insert (format "--[[multipart/signed;
1895  boundary=\"%s\"%s;
1896  protocol=\"application/pkcs7-signature\"][7bit]]
1897 --%s
1898 "
1899                         smime-boundary
1900                         (if micalg
1901                             (concat "; micalg="
1902                                     (downcase
1903                                      (cdr (assq micalg
1904                                                 epg-digest-algorithm-alist))))
1905                           "")
1906                         smime-boundary))
1907         (goto-char (point-max))
1908         (insert (format "\n--%s
1909 Content-Type: application/pkcs7-signature; name=smime.p7s
1910 Content-Transfer-Encoding: base64
1911 Content-Disposition: attachment; filename=smime.p7s
1912 Content-Description: S/MIME Digital Signature
1913
1914 " smime-boundary)
1915                 (base64-encode-string signature))))))
1916
1917 (defun mime-edit-encrypt-smime (beg end boundary)
1918   (save-excursion
1919     (save-restriction
1920       (let* ((ret (mime-edit-make-encrypt-recipient-header))
1921              (recipients (aref ret 1))
1922              (header (aref ret 2)))
1923         (narrow-to-region beg end)
1924         (let* ((ret
1925                 (mime-edit-translate-region beg end boundary))
1926                (ctype    (car ret))
1927                (encoding (nth 1 ret))
1928                (context (epg-make-context 'CMS))
1929                cipher)
1930           (goto-char beg)
1931           (insert header)
1932           (insert (format "Content-Type: %s\n" ctype))
1933           (if encoding
1934               (insert (format "Content-Transfer-Encoding: %s\n" encoding)))
1935           (insert "\n")
1936           (mime-encode-header-in-buffer)
1937           (condition-case error
1938               (setq cipher
1939                     (epg-encrypt-string
1940                      context
1941                      (buffer-substring (point-min) (point-max))
1942                      (epa-select-keys
1943                       context
1944                       "\
1945 Select recipients for encryption.
1946 If no one is selected, symmetric encryption will be performed.  "
1947                       (mapcar (lambda (recipient)
1948                                 (nth 1 (std11-extract-address-components
1949                                         recipient)))
1950                               (delete "" (split-string recipients
1951                                                        "[ \f\t\n\r\v,]+"))))))
1952             (error (signal 'mime-edit-error (cdr error))))
1953           (delete-region (point-min)(point-max))
1954           (goto-char beg)
1955           (insert (format "--[[application/pkcs7-mime;
1956  smime-type=enveloped-data;
1957  name=smime.p7m
1958 Content-Disposition: attachment; filename=smime.p7m][base64]]
1959
1960 ")
1961                   (base64-encode-string cipher)))))))
1962
1963 (defsubst replace-space-with-underline (str)
1964   (mapconcat (function
1965               (lambda (arg)
1966                 (char-to-string
1967                  (if (eq arg ?\ )
1968                      ?_
1969                    arg)))) str ""))
1970
1971 (defun mime-edit-make-boundary ()
1972   (concat mime-multipart-boundary "_"
1973           (replace-space-with-underline (current-time-string))))
1974
1975 (defun mime-edit-translate-body ()
1976   "Encode the tagged MIME body in current buffer in MIME compliant message."
1977   (interactive)
1978   (save-excursion
1979     (let ((boundary (mime-edit-make-boundary))
1980           (i 1)
1981           ret)
1982       (while (mime-edit-process-multipart-1
1983               (format "%s-%d" boundary i))
1984         (setq i (1+ i)))
1985       (save-restriction
1986         ;; We are interested in message body.
1987         (let* ((beg
1988                 (progn
1989                   (goto-char (point-min))
1990                   (re-search-forward
1991                    (concat "\n" (regexp-quote mail-header-separator)
1992                            (if mime-ignore-preceding-spaces
1993                                "[ \t\n]*\n" "\n")) nil 'move)
1994                   (point)))
1995                (end
1996                 (progn
1997                   (goto-char (point-max))
1998                   (and mime-ignore-trailing-spaces
1999                        (re-search-backward "[^ \t\n]\n" beg t)
2000                        (forward-char 1))
2001                   (point))))
2002           (setq ret (mime-edit-translate-region
2003                      beg end
2004                      (format "%s-%d" boundary i)))))
2005       (mime-edit-dequote-region (point-min)(point-max))
2006       (let ((contype (car ret))         ;Content-Type
2007             (encoding (nth 1 ret))      ;Content-Transfer-Encoding
2008             )
2009         ;; Insert User-Agent field
2010         (and mime-edit-insert-user-agent-field
2011              (or (mail-position-on-field "User-Agent")
2012                  (insert mime-edit-user-agent-value)))
2013         ;; Make primary MIME headers.
2014         (or (mail-position-on-field "MIME-Version")
2015             (insert mime-edit-mime-version-value))
2016         ;; Remove old Content-Type and other fields.
2017         (save-restriction
2018           (goto-char (point-min))
2019           (search-forward (concat "\n" mail-header-separator "\n") nil t)
2020           (narrow-to-region (point-min) (point))
2021           (goto-char (point-min))
2022           (mime-delete-field "Content-Type")
2023           (mime-delete-field "Content-Transfer-Encoding"))
2024         ;; Then, insert Content-Type and Content-Transfer-Encoding fields.
2025         (mail-position-on-field "Content-Type")
2026         (insert contype)
2027         (if encoding
2028             (progn
2029               (mail-position-on-field "Content-Transfer-Encoding")
2030               (insert encoding)))))))
2031
2032 (defun mime-edit-translate-single-part-tag (boundary &optional prefix)
2033   "Translate single-part-tag to MIME header."
2034   (if (re-search-forward mime-edit-single-part-tag-regexp nil t)
2035       (let* ((beg (match-beginning 0))
2036              (end (match-end 0))
2037              (tag (buffer-substring beg end)))
2038         (delete-region beg end)
2039         (let ((contype (mime-edit-get-contype tag))
2040               (encoding (mime-edit-get-encoding tag)))
2041           (insert (concat prefix "--" boundary "\n"))
2042           (save-restriction
2043             (narrow-to-region (point)(point))
2044             (insert "Content-Type: " contype "\n")
2045             (if encoding
2046                 (insert "Content-Transfer-Encoding: " encoding "\n"))
2047             (mime-encode-header-in-buffer))
2048           (cons (and contype
2049                      (downcase contype))
2050                 (and encoding
2051                      (downcase encoding)))))))
2052
2053 (defun mime-edit-translate-region (beg end &optional boundary multipart)
2054   (or boundary
2055       (setq boundary (mime-edit-make-boundary)))
2056   (save-excursion
2057     (save-restriction
2058       (narrow-to-region beg end)
2059       (let ((tag nil)                   ;MIME tag
2060             (contype nil)               ;Content-Type
2061             (encoding nil)              ;Content-Transfer-Encoding
2062             (nparts 0))                 ;Number of body parts
2063         ;; Normalize the body part by inserting appropriate message
2064         ;; tags for every message contents.
2065         (mime-edit-normalize-body)
2066         ;; Counting the number of Content-Type.
2067         (goto-char (point-min))
2068         (while (re-search-forward mime-edit-single-part-tag-regexp nil t)
2069           (setq nparts (1+ nparts)))
2070         ;; Begin translation.
2071         (cond
2072          ((and (<= nparts 1)(not multipart))
2073           ;; It's a singular message.
2074           (goto-char (point-min))
2075           (while (re-search-forward
2076                   mime-edit-single-part-tag-regexp nil t)
2077             (setq tag
2078                   (buffer-substring (match-beginning 0) (match-end 0)))
2079             (delete-region (match-beginning 0) (1+ (match-end 0)))
2080             (setq contype (mime-edit-get-contype tag))
2081             (setq encoding (mime-edit-get-encoding tag))))
2082          (t
2083           ;; It's a multipart message.
2084           (goto-char (point-min))
2085           (let ((prio mime-content-transfer-encoding-priority-list)
2086                 part-info nprio)
2087             (when (setq part-info
2088                         (mime-edit-translate-single-part-tag boundary))
2089               (and (setq nprio (member (cdr part-info) prio))
2090                    (setq prio nprio))
2091               (while (setq part-info
2092                            (mime-edit-translate-single-part-tag boundary "\n"))
2093                 (and (setq nprio (member (cdr part-info) prio))
2094                      (setq prio nprio))))
2095             ;; Define Content-Type as "multipart/mixed".
2096             (setq contype
2097                   (concat "multipart/mixed;\n boundary=\"" boundary "\""))
2098             (setq encoding (car prio))
2099             ;; Insert the trailer.
2100             (goto-char (point-max))
2101             (insert "\n--" boundary "--\n"))))
2102          (list contype encoding boundary nparts)))))
2103
2104 (defun mime-edit-normalize-body ()
2105   "Normalize the body part by inserting appropriate message tags."
2106   ;; Insert the first MIME tags if necessary.
2107   (goto-char (point-min))
2108   (if (not (looking-at mime-edit-single-part-tag-regexp))
2109       (insert (mime-make-text-tag) "\n"))
2110   ;; Check each tag, and add new tag or correct it if necessary.
2111   (goto-char (point-min))
2112   (while (re-search-forward mime-edit-single-part-tag-regexp nil t)
2113     (let* ((tag (buffer-substring (match-beginning 0) (match-end 0)))
2114            (contype (mime-edit-get-contype tag))
2115            (charset (mime-get-parameter contype "charset"))
2116            (encoding (mime-edit-get-encoding tag)))
2117       ;; Remove extra whitespaces after the tag.
2118       (if (looking-at "[ \t]+$")
2119           (delete-region (match-beginning 0) (match-end 0)))
2120       (let ((beg (point))
2121             (end (mime-edit-content-end)))
2122         (if (= end (point-max))
2123             nil
2124           (goto-char end)
2125           (or (looking-at mime-edit-beginning-tag-regexp)
2126               (eobp)
2127               (insert (mime-make-text-tag) "\n")))
2128         (remove-text-properties beg end '(invisible mime-edit-invisible))
2129         (goto-char beg))
2130       (cond
2131        ((mime-test-content-type contype "message")
2132         ;; Content-type "message" should be sent as is.
2133         (forward-line 1))
2134        ((mime-test-content-type contype "text")
2135         ;; Define charset for text if necessary.
2136         (setq charset (if charset
2137                           (intern (downcase charset))
2138                         (mime-edit-choose-charset)))
2139         (mime-edit-define-charset charset)
2140         (cond ((string-equal contype "text/x-rot13-47-48")
2141                (save-excursion
2142                  (forward-line)
2143                  (mule-caesar-region (point) (mime-edit-content-end))))
2144               ((string-equal contype "text/enriched")
2145                (save-excursion
2146                  (let ((beg (progn
2147                               (forward-line)
2148                               (point)))
2149                        (end (mime-edit-content-end)))
2150                    ;; Patch for hard newlines
2151                    ;; (save-excursion
2152                    ;;   (goto-char beg)
2153                    ;;   (while (search-forward "\n" end t)
2154                    ;;     (put-text-property (match-beginning 0)
2155                    ;;                        (point)
2156                    ;;                        'hard t)))
2157                    ;; End patch for hard newlines
2158                    (enriched-encode beg end nil)
2159                    (goto-char beg)
2160                    (if (search-forward "\n\n")
2161                        (delete-region beg (match-end 0)))))))
2162         ;; Point is now on current tag.
2163         ;; Define encoding and encode text if necessary.
2164         (or encoding    ;Encoding is not specified.
2165             (let* ((encoding
2166                     (let (bits conv)
2167                       (let ((ret (cdr (assq charset mime-charset-type-list))))
2168                         (if ret
2169                             (setq bits (car ret)
2170                                   conv (nth 1 ret))
2171                           (setq bits 8
2172                                 conv "quoted-printable")))
2173                       (if (<= bits mime-transfer-level)
2174                           (mime-encoding-name bits)
2175                         conv)))
2176                    (beg (mime-edit-content-beginning)))
2177               (encode-mime-charset-region beg (mime-edit-content-end)
2178                                           charset)
2179               ;; Protect "From " in beginning of line
2180               (save-restriction
2181                 (narrow-to-region beg (mime-edit-content-end))
2182                 (goto-char beg)
2183                 (let (case-fold-search)
2184                   (if (re-search-forward "^From " nil t)
2185                       (unless encoding
2186                         (if (memq charset '(iso-2022-jp
2187                                             iso-2022-jp-2
2188                                             iso-2022-int-1
2189                                             x-ctext))
2190                             (while (progn
2191                                      (replace-match "\e(BFrom ")
2192                                      (re-search-forward "^From " nil t)))
2193                           (setq encoding "quoted-printable"))))))
2194               ;; canonicalize line break code
2195               (or (member encoding '(nil "7bit" "8bit" "quoted-printable"))
2196                   (save-restriction
2197                     (narrow-to-region beg (mime-edit-content-end))
2198                     (goto-char beg)
2199                     (while (re-search-forward "\\(\\=\\|[^\r]\\)\n" nil t)
2200                       ;; In a certain period, `replace-match' with "\\N"
2201                       ;; converted 8-bit characters into multibyte string,
2202                       ;; but it has been fixed at 2004-01-15.
2203                       ;;(replace-match "\\1\r\n"))))
2204                       (backward-char 1)
2205                       (insert "\r")
2206                       (forward-char 1))))
2207               (goto-char beg)
2208               (mime-encode-region beg (mime-edit-content-end)
2209                                   (or encoding "7bit"))
2210               (mime-edit-define-encoding encoding)))
2211         (goto-char (mime-edit-content-end)))
2212        ((null encoding)         ;Encoding is not specified.
2213         ;; Application, image, audio, video, and any other
2214         ;; unknown content-type without encoding should be
2215         ;; encoded.
2216         (let* ((encoding "base64")      ;Encode in BASE64 by default.
2217                (beg (mime-edit-content-beginning))
2218                (end (mime-edit-content-end)))
2219           (mime-encode-region beg end encoding)
2220           (mime-edit-define-encoding encoding))
2221         (forward-line 1))))))
2222
2223 (defun mime-delete-field (field)
2224   "Delete header FIELD."
2225   (let ((regexp (format "^%s:[ \t]*" field)))
2226     (goto-char (point-min))
2227     (while (re-search-forward regexp nil t)
2228       (delete-region (match-beginning 0)
2229                      (1+ (std11-field-end))))))
2230
2231 \f
2232 ;;;
2233 ;;; Platform dependent functions
2234 ;;;
2235
2236 ;; Sun implementations
2237
2238 (defun mime-edit-voice-recorder-for-sun (encoding)
2239   "Record voice in a buffer using Sun audio device,
2240 and insert data encoded as ENCODING."
2241   (message "Start the recording on %s.  Type C-g to finish the recording..."
2242            (system-name))
2243   (mime-insert-encoded-file "/dev/audio" encoding))
2244
2245 \f
2246 ;;; @ Other useful commands.
2247 ;;;
2248
2249 ;; Message forwarding commands as content-type "message/rfc822".
2250
2251 (defun mime-edit-insert-message (&optional message)
2252   (interactive)
2253   (let ((inserter (cdr (assq major-mode mime-edit-message-inserter-alist))))
2254     (if (and inserter (fboundp inserter))
2255         (progn
2256           (mime-edit-insert-tag "message" "rfc822")
2257           (funcall inserter message))
2258       (message "Sorry, I don't have message inserter for your MUA."))))
2259
2260 (defun mime-edit-insert-mail (&optional message)
2261   (interactive)
2262   (let ((inserter (cdr (assq major-mode mime-edit-mail-inserter-alist))))
2263     (if (and inserter (fboundp inserter))
2264         (progn
2265           (mime-edit-insert-tag "message" "rfc822")
2266           (funcall inserter message))
2267       (message "Sorry, I don't have mail inserter for your MUA."))))
2268
2269 (defun mime-edit-inserted-message-filter ()
2270   (save-excursion
2271     (save-restriction
2272       (let ((header-start (point))
2273             (case-fold-search t)
2274             beg end)
2275         ;; for Emacs 18
2276         ;; (if (re-search-forward "^$" (marker-position (mark-marker)))
2277         (if (re-search-forward "^$" (mark t))
2278             (narrow-to-region header-start (match-beginning 0)))
2279         (goto-char header-start)
2280         (while (and (re-search-forward
2281                      mime-edit-yank-ignored-field-regexp nil t)
2282                     (setq beg (match-beginning 0))
2283                     (setq end (1+ (std11-field-end))))
2284           (delete-region beg end))))))
2285
2286
2287 ;;; @ multipart enclosure
2288 ;;;
2289
2290 (defun mime-edit-enclose-region-internal (type beg end)
2291   (save-excursion
2292     (goto-char beg)
2293     (save-restriction
2294       (narrow-to-region beg end)
2295       (insert (format "--<<%s>>-{\n" type))
2296       (goto-char (point-max))
2297       (insert (format "--}-<<%s>>\n" type))
2298       (goto-char (point-max)))
2299     (or (looking-at mime-edit-beginning-tag-regexp)
2300         (eobp)
2301         (insert (mime-make-text-tag) "\n"))))
2302
2303 (defun mime-edit-enclose-quote-region (beg end)
2304   (interactive "*r")
2305   (mime-edit-enclose-region-internal 'quote beg end))
2306
2307 (defun mime-edit-enclose-mixed-region (beg end)
2308   (interactive "*r")
2309   (mime-edit-enclose-region-internal 'mixed beg end))
2310
2311 (defun mime-edit-enclose-parallel-region (beg end)
2312   (interactive "*r")
2313   (mime-edit-enclose-region-internal 'parallel beg end))
2314
2315 (defun mime-edit-enclose-digest-region (beg end)
2316   (interactive "*r")
2317   (mime-edit-enclose-region-internal 'digest beg end))
2318
2319 (defun mime-edit-enclose-alternative-region (beg end)
2320   (interactive "*r")
2321   (mime-edit-enclose-region-internal 'alternative beg end))
2322
2323 (defun mime-edit-enclose-pgp-signed-region (beg end)
2324   (interactive "*r")
2325   (mime-edit-enclose-region-internal 'pgp-signed beg end))
2326
2327 (defun mime-edit-enclose-pgp-encrypted-region (beg end)
2328   (interactive "*r")
2329   (mime-edit-enclose-region-internal 'pgp-encrypted beg end))
2330
2331 (defun mime-edit-enclose-smime-signed-region (beg end)
2332   (interactive "*r")
2333   (mime-edit-enclose-region-internal 'smime-signed beg end))
2334
2335 (defun mime-edit-enclose-smime-encrypted-region (beg end)
2336   (interactive "*r")
2337   (mime-edit-enclose-region-internal 'smime-encrypted beg end))
2338
2339 (defun mime-edit-insert-key (&optional arg)
2340   "Insert a pgp public key."
2341   (interactive "P")
2342   (mime-edit-insert-tag "application" "pgp-keys")
2343   (mime-edit-define-encoding "7bit")
2344   (let ((context (epg-make-context)))
2345     (epg-context-set-armor context t)
2346     (epg-export-keys-to-string context
2347                                (epa-select-keys context
2348                                                 "Select keys for export.  ")))
2349   (if (and (not (eobp))
2350            (not (looking-at mime-edit-single-part-tag-regexp)))
2351       (insert (mime-make-text-tag) "\n")))
2352
2353
2354 ;;; @ flag setting
2355 ;;;
2356
2357 (defun mime-edit-set-split (arg)
2358   (interactive
2359    (list
2360     (y-or-n-p "Do you want to enable split? ")))
2361   (setq mime-edit-split-message arg)
2362   (if arg
2363       (message "This message is enabled to split.")
2364     (message "This message is not enabled to split.")))
2365
2366 (defun mime-edit-toggle-transfer-level (&optional transfer-level)
2367   "Toggle transfer-level is 7bit or 8bit through.
2368
2369 Optional TRANSFER-LEVEL is a number of transfer-level, 7 or 8."
2370   (interactive)
2371   (if (numberp transfer-level)
2372       (setq mime-transfer-level transfer-level)
2373     (if (< mime-transfer-level 8)
2374         (setq mime-transfer-level 8)
2375       (setq mime-transfer-level 7)))
2376   (message (format "Current transfer-level is %d bit"
2377                    mime-transfer-level))
2378   (setq mime-transfer-level-string
2379         (mime-encoding-name mime-transfer-level 'not-omit))
2380   (force-mode-line-update))
2381
2382 (defun mime-edit-set-transfer-level-7bit ()
2383   (interactive)
2384   (mime-edit-toggle-transfer-level 7))
2385
2386 (defun mime-edit-set-transfer-level-8bit ()
2387   (interactive)
2388   (mime-edit-toggle-transfer-level 8))
2389
2390
2391 ;;; @ pgp
2392 ;;;
2393
2394 (defvar mime-edit-pgp-processing nil)
2395 (make-variable-buffer-local 'mime-edit-pgp-processing)
2396
2397 (defun mime-edit-set-sign (arg)
2398   (interactive
2399    (list
2400     (y-or-n-p "Do you want to sign? ")))
2401   (if arg
2402       (progn
2403         (or (memq 'sign mime-edit-pgp-processing)
2404             (setq mime-edit-pgp-processing
2405                   (nconc mime-edit-pgp-processing
2406                          (copy-sequence '(sign)))))
2407         (message "This message will be signed."))
2408     (setq mime-edit-pgp-processing
2409           (delq 'sign mime-edit-pgp-processing))
2410     (message "This message will not be signed.")))
2411
2412 (defun mime-edit-set-encrypt (arg)
2413   (interactive
2414    (list
2415     (y-or-n-p "Do you want to encrypt? ")))
2416   (if arg
2417       (progn
2418         (or (memq 'encrypt mime-edit-pgp-processing)
2419             (setq mime-edit-pgp-processing
2420                   (nconc mime-edit-pgp-processing
2421                          (copy-sequence '(encrypt)))))
2422         (message "This message will be encrypt."))
2423     (setq mime-edit-pgp-processing
2424           (delq 'encrypt mime-edit-pgp-processing))
2425     (message "This message will not be encrypt.")))
2426
2427 (defun mime-edit-pgp-enclose-buffer ()
2428   (let ((beg (save-excursion
2429                (goto-char (point-min))
2430                (if (search-forward (concat "\n" mail-header-separator "\n"))
2431                    (match-end 0)))))
2432     (if beg
2433         (dolist (pgp-processing mime-edit-pgp-processing)
2434           (case pgp-processing
2435             (sign
2436              (mime-edit-enclose-pgp-signed-region
2437               beg (point-max)))
2438             (encrypt
2439              (mime-edit-enclose-pgp-encrypted-region
2440               beg (point-max))))))))
2441
2442
2443 ;;; @ split
2444 ;;;
2445
2446 (defun mime-edit-insert-partial-header (fields subject
2447                                                id number total separator)
2448   (insert fields)
2449   (insert (format "Subject: %s (%d/%d)\n" subject number total))
2450   (insert mime-edit-mime-version-field-for-message/partial)
2451   (insert (format "\
2452 Content-Type: message/partial; id=%s; number=%d; total=%d\n%s\n"
2453                   id number total separator)))
2454
2455 (defun mime-edit-split-and-send
2456   (&optional cmd lines mime-edit-message-max-length)
2457   (interactive)
2458   (or lines
2459       (setq lines
2460             (count-lines (point-min) (point-max))))
2461   (or mime-edit-message-max-length
2462       (setq mime-edit-message-max-length
2463             (or (cdr (assq major-mode mime-edit-message-max-lines-alist))
2464                 mime-edit-message-default-max-lines)))
2465   (let ((separator mail-header-separator)
2466         (id (concat "\""
2467                     (replace-space-with-underline (current-time-string))
2468                     "@" (system-name) "\"")))
2469     (run-hooks 'mime-edit-before-split-hook)
2470     (let ((the-buf (current-buffer))
2471           (copy-buf (get-buffer-create " *Original Message*"))
2472           (header (std11-header-string-except
2473                    mime-edit-split-ignored-field-regexp separator))
2474           (subject (mail-fetch-field "subject"))
2475           (total (+ (/ lines mime-edit-message-max-length)
2476                     (if (> (mod lines mime-edit-message-max-length) 0)
2477                         1)))
2478           (command
2479            (or cmd
2480                (cdr
2481                 (assq major-mode
2482                       mime-edit-split-message-sender-alist))
2483                (function
2484                 (lambda ()
2485                   (interactive)
2486                   (error "Split sender is not specified for `%s'." major-mode)))))
2487           (mime-edit-partial-number 1)
2488           data)
2489       (save-excursion
2490         (set-buffer copy-buf)
2491         (erase-buffer)
2492         (insert-buffer the-buf)
2493         (save-restriction
2494           (if (re-search-forward
2495                (concat "^" (regexp-quote separator) "$") nil t)
2496               (let ((he (match-beginning 0)))
2497                 (replace-match "")
2498                 (narrow-to-region (point-min) he)))
2499           (goto-char (point-min))
2500           (while (re-search-forward mime-edit-split-blind-field-regexp nil t)
2501             (delete-region (match-beginning 0)
2502                            (1+ (std11-field-end))))))
2503       (while (< mime-edit-partial-number total)
2504         (erase-buffer)
2505         (save-excursion
2506           (set-buffer copy-buf)
2507           (setq data (buffer-substring
2508                       (point-min)
2509                       (progn
2510                         (goto-line mime-edit-message-max-length)
2511                         (point))))
2512           (delete-region (point-min)(point)))
2513         (mime-edit-insert-partial-header
2514          header subject id mime-edit-partial-number total separator)
2515         (insert data)
2516         (save-excursion
2517           (message (format "Sending %d/%d..."
2518                            mime-edit-partial-number total))
2519           (call-interactively command)
2520           (message (format "Sending %d/%d...done"
2521                            mime-edit-partial-number total)))
2522         (setq mime-edit-partial-number
2523               (1+ mime-edit-partial-number)))
2524       (erase-buffer)
2525       (save-excursion
2526         (set-buffer copy-buf)
2527         (setq data (buffer-string))
2528         (erase-buffer))
2529       (mime-edit-insert-partial-header
2530        header subject id mime-edit-partial-number total separator)
2531       (insert data)
2532       (save-excursion
2533         (message (format "Sending %d/%d..."
2534                          mime-edit-partial-number total))
2535         (message (format "Sending %d/%d...done"
2536                          mime-edit-partial-number total))))))
2537
2538 (defun mime-edit-maybe-split-and-send (&optional cmd)
2539   (interactive)
2540   (run-hooks 'mime-edit-before-send-hook)
2541   (let ((mime-edit-message-max-length
2542          (or (cdr (assq major-mode mime-edit-message-max-lines-alist))
2543              mime-edit-message-default-max-lines))
2544         (lines (count-lines (point-min) (point-max))))
2545     (if (and (> lines mime-edit-message-max-length)
2546              mime-edit-split-message)
2547         (mime-edit-split-and-send cmd lines mime-edit-message-max-length))))
2548
2549
2550 ;;; @ preview message
2551 ;;;
2552
2553 (defvar mime-edit-buffer nil) ; buffer local variable
2554 (defvar mime-edit-temp-message-buffer nil) ; buffer local variable
2555
2556 (defun mime-edit-preview-message ()
2557   "preview editing MIME message."
2558   (interactive)
2559   (let* ((str (buffer-string))
2560          (separator mail-header-separator)
2561          (the-buf (current-buffer))
2562          (buf-name (buffer-name))
2563          (temp-buf-name (concat "*temp-article:" buf-name "*"))
2564          (buf (get-buffer temp-buf-name))
2565          (pgp-processing mime-edit-pgp-processing))
2566     (if buf
2567         (progn
2568           (switch-to-buffer buf)
2569           (erase-buffer))
2570       (setq buf (get-buffer-create temp-buf-name))
2571       (switch-to-buffer buf))
2572     (insert str)
2573     (setq major-mode 'mime-temp-message-mode)
2574     (make-local-variable 'mail-header-separator)
2575     (setq mail-header-separator separator)
2576     (make-local-variable 'mime-edit-buffer)
2577     (setq mime-edit-buffer the-buf)
2578     (setq mime-edit-pgp-processing pgp-processing)
2579
2580     (run-hooks 'mime-edit-translate-hook)
2581     (mime-edit-translate-buffer)
2582     (goto-char (point-min))
2583     (if (re-search-forward
2584          (concat "^" (regexp-quote separator) "$"))
2585         (replace-match ""))
2586     (mime-view-buffer)
2587     (make-local-variable 'mime-edit-temp-message-buffer)
2588     (setq mime-edit-temp-message-buffer buf)))
2589
2590 (defun mime-edit-quitting-method ()
2591   "Quitting method for mime-view."
2592   (let* ((temp mime-edit-temp-message-buffer)
2593          buf)
2594     (mime-preview-kill-buffer)
2595     (set-buffer temp)
2596     (setq buf mime-edit-buffer)
2597     (kill-buffer temp)
2598     (switch-to-buffer buf)))
2599
2600 (set-alist 'mime-preview-quitting-method-alist
2601            'mime-temp-message-mode
2602            #'mime-edit-quitting-method)
2603
2604
2605 ;;; @ edit again
2606 ;;;
2607
2608 (defvar mime-edit-again-ignored-field-regexp
2609   (concat "^\\(" "Content-.*\\|Mime-Version"
2610           (if mime-edit-insert-user-agent-field "\\|User-Agent")
2611           "\\):")
2612   "Regexp for deleted header fields when `mime-edit-again' is called.")
2613
2614 (defsubst eliminate-top-spaces (string)
2615   "Eliminate top sequence of space or tab in STRING."
2616   (if (string-match "^[ \t]+" string)
2617       (substring string (match-end 0))
2618     string))
2619
2620 (defun mime-edit-decode-multipart-in-buffer (content-type not-decode-text)
2621   (let* ((subtype
2622           (or
2623            (cdr (assoc (mime-content-type-parameter content-type "protocol")
2624                        '(("application/pgp-encrypted" . pgp-encrypted)
2625                          ("application/pgp-signature" . pgp-signed))))
2626            (mime-content-type-subtype content-type)))
2627          (boundary (mime-content-type-parameter content-type "boundary"))
2628          (boundary-pat (concat "\n--" (regexp-quote boundary) "[ \t]*\n")))
2629     (re-search-forward boundary-pat nil t)
2630     (let ((bb (match-beginning 0)) eb tag)
2631       (setq tag (format "\n--<<%s>>-{\n" subtype))
2632       (goto-char bb)
2633       (insert tag)
2634       (setq bb (+ bb (length tag)))
2635       (re-search-forward
2636        (concat "\n--" (regexp-quote boundary) "--[ \t]*\n")
2637        nil t)
2638       (setq eb (match-beginning 0))
2639       (replace-match (format "--}-<<%s>>\n" subtype))
2640       (save-restriction
2641         (narrow-to-region bb eb)
2642         (goto-char (point-min))
2643         (while (re-search-forward boundary-pat nil t)
2644           (let ((beg (match-beginning 0))
2645                 end)
2646             (delete-region beg (match-end 0))
2647             (save-excursion
2648               (if (re-search-forward boundary-pat nil t)
2649                   (setq end (match-beginning 0))
2650                 (setq end (point-max)))
2651               (save-restriction
2652                 (narrow-to-region beg end)
2653                 (cond
2654                  ((eq subtype 'pgp-encrypted)
2655                   (when (progn
2656                            (goto-char (point-min))
2657                            (re-search-forward "^-+BEGIN PGP MESSAGE-+$"
2658                                               nil t))
2659                     (insert (epg-decrypt-string
2660                              (epg-make-context)
2661                              (buffer-substring (match-beginning 0)
2662                                                (point-max))))
2663                     (delete-region (point)(point-max))
2664                     (mime-edit-decode-message-in-buffer
2665                      nil not-decode-text)
2666                     (delete-region (goto-char (point-min))
2667                                    (if (search-forward "\n\n" nil t)
2668                                        (match-end 0)
2669                                      (point-min)))
2670                     (goto-char (point-max))))
2671                  (t
2672                   (mime-edit-decode-message-in-buffer
2673                    (if (eq subtype 'digest)
2674                        (eval-when-compile
2675                          (make-mime-content-type 'message 'rfc822)))
2676                    not-decode-text)
2677                   (goto-char (point-max))))))))))
2678     (goto-char (point-min))
2679     (or (= (point-min) 1)
2680         (delete-region (point-min)
2681                        (if (search-forward "\n\n" nil t)
2682                            (match-end 0)
2683                          (point-min))))))
2684
2685 (defun mime-edit-decode-single-part-in-buffer
2686   (content-type not-decode-text &optional content-disposition)
2687   (let* ((type (mime-content-type-primary-type content-type))
2688          (subtype (mime-content-type-subtype content-type))
2689          (ctype (format "%s/%s" type subtype))
2690          charset
2691          (pstr (let ((bytes (+ 14 (length ctype))))
2692                  (mapconcat (function
2693                              (lambda (attr)
2694                                (if (string= (car attr) "charset")
2695                                    (progn
2696                                      (setq charset (cdr attr))
2697                                      "")
2698                                  (let* ((str (concat (car attr)
2699                                                      "=" (cdr attr)))
2700                                         (bs (length str)))
2701                                    (setq bytes (+ bytes bs 2))
2702                                    (if (< bytes 76)
2703                                        (concat "; " str)
2704                                      (setq bytes (+ bs 1))
2705                                      (concat ";\n " str)
2706                                      )))))
2707                             (mime-content-type-parameters content-type) "")))
2708          encoding
2709          encoded
2710          (limit (save-excursion
2711                   (if (search-forward "\n\n" nil t)
2712                       (1- (point)))))
2713          (disposition-type
2714           (mime-content-disposition-type content-disposition))
2715          (disposition-str
2716           (if disposition-type
2717               (let ((bytes (+ 21 (length (format "%s" disposition-type)))))
2718                 (mapconcat (function
2719                             (lambda (attr)
2720                               (let* ((str (concat
2721                                            (car attr)
2722                                            "="
2723                                            (if (string-equal "filename"
2724                                                              (car attr))
2725                                                (std11-wrap-as-quoted-string
2726                                                 (cdr attr))
2727                                              (cdr attr))))
2728                                      (bs (length str)))
2729                                 (setq bytes (+ bytes bs 2))
2730                                 (if (< bytes 76)
2731                                     (concat "; " str)
2732                                   (setq bytes (+ bs 1))
2733                                   (concat ";\n " str)
2734                                   ))))
2735                            (mime-content-disposition-parameters
2736                             content-disposition)
2737                            "")))))
2738     (if disposition-type
2739         (setq pstr (format "%s\nContent-Disposition: %s%s"
2740                            pstr disposition-type disposition-str)))
2741     (save-excursion
2742       (if (re-search-forward
2743            "^Content-Transfer-Encoding:" limit t)
2744           (let ((beg (match-beginning 0))
2745                 (hbeg (match-end 0))
2746                 (end (std11-field-end limit)))
2747             (setq encoding
2748                   (downcase
2749                    (eliminate-top-spaces
2750                     (std11-unfold-string
2751                      (buffer-substring hbeg end)))))
2752             (if (or charset (eq type 'text))
2753                 (progn
2754                   (delete-region beg (1+ end))
2755                   (goto-char (point-min))
2756                   (if (search-forward "\n\n" nil t)
2757                       (progn
2758                         (mime-decode-region
2759                          (match-end 0)(point-max) encoding)
2760                         (setq encoded t
2761                               encoding nil))))))))
2762     (if (and (eq type 'text)
2763              (or encoded (not not-decode-text)))
2764         (progn
2765           (save-excursion
2766             (goto-char (point-min))
2767             (while (re-search-forward "\r\n" nil t)
2768               (replace-match "\n")))
2769           (decode-mime-charset-region (point-min)(point-max)
2770                                       (or charset default-mime-charset))))
2771     (let ((he (if (re-search-forward "^$" nil t)
2772                   (match-end 0)
2773                 (point-min))))
2774       (if (and (eq type 'text)
2775                (eq subtype 'x-rot13-47-48))
2776           (mule-caesar-region he (point-max)))
2777       (if (= (point-min) 1)
2778           (progn
2779             (goto-char he)
2780             (insert
2781              (concat "\n"
2782                      (mime-create-tag
2783                       (format "%s/%s%s" type subtype pstr)
2784                       encoding))))
2785         (delete-region (point-min) he)
2786         (insert
2787          (mime-create-tag (format "%s/%s%s" type subtype pstr)
2788                           encoding))))))
2789
2790 ;;;###autoload
2791 (defun mime-edit-decode-message-in-buffer (&optional default-content-type
2792                                                      not-decode-text)
2793   (save-excursion
2794     (goto-char (point-min))
2795     (let ((ctl (or (mime-read-Content-Type)
2796                    default-content-type)))
2797       (if ctl
2798           (let ((type (mime-content-type-primary-type ctl)))
2799             (cond
2800              ((and (eq type 'application)
2801                    (eq (mime-content-type-subtype ctl) 'pgp-signature))
2802               (delete-region (point-min)(point-max)))
2803              ((eq type 'multipart)
2804               (mime-edit-decode-multipart-in-buffer ctl not-decode-text))
2805              (t
2806               (mime-edit-decode-single-part-in-buffer
2807                ctl not-decode-text (mime-read-Content-Disposition)))))
2808         (or not-decode-text
2809             (decode-mime-charset-region (point-min) (point-max)
2810                                         default-mime-charset)))
2811       (if (= (point-min) 1)
2812           (progn
2813             (save-restriction
2814               (std11-narrow-to-header)
2815               (goto-char (point-min))
2816               (while (re-search-forward
2817                       mime-edit-again-ignored-field-regexp nil t)
2818                 (delete-region (match-beginning 0) (1+ (std11-field-end)))))
2819             (mime-decode-header-in-buffer (not not-decode-text)))))))
2820
2821 ;;;###autoload
2822 (defun mime-edit-again (&optional not-decode-text no-separator not-turn-on)
2823   "Convert current buffer to MIME-Edit buffer and turn on MIME-Edit mode.
2824 Content-Type and Content-Transfer-Encoding header fields will be
2825 converted to MIME-Edit tags."
2826   (interactive)
2827   (goto-char (point-min))
2828   (if (search-forward
2829        (concat "\n" (regexp-quote mail-header-separator) "\n")
2830        nil t)
2831       (replace-match "\n\n"))
2832   (mime-edit-decode-message-in-buffer nil not-decode-text)
2833   (goto-char (point-min))
2834   (or no-separator
2835       (and (re-search-forward "^$")
2836            (replace-match mail-header-separator)))
2837   (or not-turn-on
2838       (turn-on-mime-edit)))
2839
2840
2841 ;;; @ end
2842 ;;;
2843
2844 (provide 'mime-edit)
2845
2846 (run-hooks 'mime-edit-load-hook)
2847
2848 ;;; mime-edit.el ends here