mime-edit.el

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