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