wl/wl-mime.el

   1 ;;; wl-mime.el --- SEMI implementations of MIME processing on Wanderlust.
   2
   3 ;; Copyright (C) 1998,1999,2000 Yuuichi Teranishi <teranisi@gohome.org>
   4
   5 ;; Author: Yuuichi Teranishi <teranisi@gohome.org>
   6 ;; Keywords: mail, net news
   7
   8 ;; This file is part of Wanderlust (Yet Another Message Interface on Emacsen).
   9
  10 ;; This program is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14 ;;
  15 ;; This program is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19 ;;
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24 ;;
  25
  26 ;;; Commentary:
  27 ;;
  28
  29 ;;; Code:
  30 ;;
  31 (require 'mime-view)
  32 (require 'mime-edit)
  33 (require 'mime-play)
  34 (require 'elmo)
  35 (require 'wl-vars)
  36
  37 (eval-when-compile
  38   (defalias-maybe 'pgg-decrypt-region 'ignore)
  39   (defalias-maybe 'pgg-display-output-buffer 'ignore)
  40   (defalias-maybe 'pgg-verify-region 'ignore))
  41
  42 ;;; Draft
  43
  44 (defalias 'wl-draft-editor-mode 'mime-edit-mode)
  45
  46 (defalias 'wl-draft-decode-message-in-buffer
  47   'mime-edit-decode-message-in-buffer)
  48
  49 (defun wl-draft-yank-current-message-entity ()
  50   "Yank currently displayed message entity.
  51 By setting following-method as yank-content.
  52
  53 If region is active, yank region contents instead. \(this feature is available
  54 if and only if `transient-mark-mode' \(GNU Emacs\) or `zmacs-regions' \(XEmacs\)
  55 has Non-nil value\)"
  56   (let ((wl-draft-buffer (current-buffer))
  57         (mime-view-following-method-alist
  58          (list (cons 'wl-original-message-mode
  59                      (function wl-draft-yank-to-draft-buffer))))
  60         (mime-preview-following-method-alist
  61          (list (cons 'wl-original-message-mode
  62                      (function wl-draft-yank-to-draft-buffer))))
  63         (message-buffer (wl-current-message-buffer)))
  64     (if message-buffer
  65         (save-excursion
  66           (set-buffer message-buffer)
  67           (save-restriction
  68             (widen)
  69             (cond
  70              ((wl-region-exists-p)
  71               (wl-mime-preview-follow-current-region))
  72              ((not (wl-message-mime-analysis-p
  73                     (wl-message-buffer-display-type)))
  74               (wl-mime-preview-follow-no-mime
  75                (wl-message-buffer-display-type)))
  76              (t
  77               (mime-preview-follow-current-entity)))))
  78       (error "No message."))))
  79
  80 ;; modified mime-preview-follow-current-entity from mime-view.el
  81 (defun wl-mime-preview-follow-no-mime (display-type)
  82   "Write follow message to current message, without mime.
  83 It calls following-method selected from variable
  84 `mime-preview-following-method-alist'."
  85   (interactive)
  86   (let* ((mode (mime-preview-original-major-mode 'recursive))
  87          (new-name (format "%s-no-mime" (buffer-name)))
  88          new-buf min beg end
  89          (entity (get-text-property (point-min) 'elmo-as-is-entity))
  90          (the-buf (current-buffer))
  91          fields)
  92     (save-excursion
  93       (goto-char (point-min))
  94       (setq min (point-min)
  95             beg (re-search-forward "^$" nil t)
  96             end (point-max)))
  97     (save-excursion
  98       (set-buffer (setq new-buf (get-buffer-create new-name)))
  99       (erase-buffer)
 100       (insert-buffer-substring the-buf beg end)
 101       (goto-char (point-min))
 102       ;; Insert all headers.
 103       (let ((elmo-mime-display-header-analysis
 104              (wl-message-mime-analysis-p display-type 'header)))
 105         (elmo-mime-insert-sorted-header entity))
 106       (let ((f (cdr (assq mode mime-preview-following-method-alist))))
 107         (if (functionp f)
 108             (funcall f new-buf)
 109           (message
 110            "Sorry, following method for %s is not implemented yet."
 111            mode))))))
 112
 113 ;; modified mime-preview-follow-current-entity from mime-view.el
 114 (defun wl-mime-preview-follow-current-region ()
 115   "Write follow message to current region.
 116 It calls following-method selected from variable
 117 `mime-preview-following-method-alist'."
 118   (interactive)
 119   (let ((r-beg (region-beginning))
 120         (r-end (region-end))
 121         (entity (get-text-property (point-min)
 122                                    'mime-view-entity)))
 123     (let* ((mode (mime-preview-original-major-mode 'recursive))
 124            (new-name
 125             (format "%s-active-region" (buffer-name)))
 126            new-buf
 127            (the-buf (current-buffer))
 128            fields)
 129       (save-excursion
 130         (set-buffer (setq new-buf (get-buffer-create new-name)))
 131         (erase-buffer)
 132         (insert ?\n)
 133         (insert-buffer-substring the-buf r-beg r-end)
 134         (goto-char (point-min))
 135         (let ((current-entity
 136                (if (and entity
 137                         (eq (mime-entity-media-type entity) 'message)
 138                         (eq (mime-entity-media-subtype entity) 'rfc822))
 139                    (car (mime-entity-children entity))
 140                  entity)))
 141           (while (and current-entity
 142                       (if (and (eq (mime-entity-media-type
 143                                     current-entity) 'message)
 144                                (eq (mime-entity-media-subtype
 145                                     current-entity) 'rfc822))
 146                           nil
 147                         (mime-insert-header current-entity fields)
 148                         t))
 149             (setq fields (std11-collect-field-names)
 150                   current-entity (mime-entity-parent current-entity))))
 151         (let ((rest mime-view-following-required-fields-list)
 152               field-name ret)
 153           (while rest
 154             (setq field-name (car rest))
 155             (or (std11-field-body field-name)
 156                 (progn
 157                   (save-excursion
 158                     (set-buffer the-buf)
 159                     (let ((entity (when mime-mother-buffer
 160                                     (set-buffer mime-mother-buffer)
 161                                     (get-text-property (point)
 162                                                        'mime-view-entity))))
 163                       (while (and entity
 164                                   (null (setq ret (mime-entity-fetch-field
 165                                                    entity field-name))))
 166                         (setq entity (mime-entity-parent entity)))))
 167                   (if ret
 168                       (insert (concat field-name ": " ret "\n")))))
 169             (setq rest (cdr rest)))))
 170       (let ((f (cdr (assq mode mime-preview-following-method-alist))))
 171         (if (functionp f)
 172             (funcall f new-buf)
 173           (message
 174            "Sorry, following method for %s is not implemented yet."
 175            mode))))))
 176
 177 (defalias 'wl-draft-enclose-digest-region 'mime-edit-enclose-digest-region)
 178
 179 (defun wl-draft-preview-attributes-list ()
 180   (if (listp (car wl-draft-preview-attributes-list))
 181       (elmo-uniq-list
 182        (nconc (and (wl-message-mail-p)
 183                    (copy-sequence
 184                     (cdr (assq 'mail wl-draft-preview-attributes-list))))
 185               (and (wl-message-news-p)
 186                    (copy-sequence
 187                     (cdr (assq 'news wl-draft-preview-attributes-list))))))
 188     wl-draft-preview-attributes-list))
 189
 190 (defun wl-draft-show-attributes-buffer (attribute-values)
 191   (let* ((cur-win (selected-window))
 192          (size (min
 193                 (- (window-height cur-win)
 194                    window-min-height 1)
 195                 (- (window-height cur-win)
 196                    (max
 197                     window-min-height
 198                     (1+ wl-draft-preview-attributes-buffer-lines))))))
 199     (split-window cur-win (if (> size 0) size window-min-height))
 200     (select-window (next-window))
 201     (let ((pop-up-windows nil))
 202       (switch-to-buffer (get-buffer-create
 203                          wl-draft-preview-attributes-buffer-name)))
 204     (with-current-buffer
 205         (get-buffer wl-draft-preview-attributes-buffer-name)
 206       (setq buffer-read-only t)
 207       (let (buffer-read-only)
 208         (erase-buffer)
 209         (dolist (pair attribute-values)
 210           (insert (capitalize (symbol-name (car pair))) ": "
 211                   (format "%s" (or (cdr pair) ""))
 212                   "\n"))
 213         (goto-char (point-min))
 214         (wl-highlight-headers)))
 215     (select-window cur-win)))
 216
 217 (defun wl-draft-hide-attributes-buffer ()
 218   (let (window buffer)
 219     (when (setq window (get-buffer-window
 220                         wl-draft-preview-attributes-buffer-name))
 221       (select-window window)
 222       (delete-window))
 223     (when (setq buffer (get-buffer wl-draft-preview-attributes-buffer-name))
 224       (kill-buffer buffer))))
 225
 226 (defun wl-draft-attribute-recipients ()
 227   (concat (mapconcat
 228            'identity
 229            (wl-draft-deduce-address-list
 230             (current-buffer)
 231             (point-min)
 232             (save-excursion
 233               (goto-char (point-min))
 234               (re-search-forward
 235                (concat
 236                 "^"
 237                 (regexp-quote mail-header-separator)
 238                 "$")
 239                nil t)
 240               (point)))
 241            ", ")))
 242
 243 (defun wl-draft-attribute-envelope-from ()
 244   (or wl-envelope-from
 245       (wl-address-header-extract-address wl-from)))
 246
 247 (defun wl-draft-attribute-smtp-posting-server ()
 248   (or wl-smtp-posting-server
 249       (progn (require 'smtp) smtp-server)
 250       "localhost"))
 251
 252 (defun wl-draft-attribute-smtp-posting-port ()
 253   (or wl-smtp-posting-port
 254       (progn (require 'smtp) smtp-service)))
 255
 256 (defun wl-draft-attribute-newsgroups ()
 257   (std11-field-body "Newsgroups"))
 258
 259 (defun wl-draft-nntp-attribute (attribute &optional alternatives)
 260   (let ((config (cdr (elmo-string-matched-assoc
 261                       (std11-field-body "newsgroups")
 262                       wl-nntp-posting-config-alist)))
 263         entry)
 264     (when (stringp config)
 265       (setq config (list (cons 'server config))))
 266     (if (setq entry (assq attribute config))
 267         ;; maybe nil
 268         (cdr entry)
 269       (let (value)
 270         (while alternatives
 271           (if (setq value (symbol-value (car alternatives)))
 272               (setq alternatives nil)
 273             (setq alternatives (cdr alternatives))))
 274         value))))
 275
 276 (defun wl-draft-attribute-nntp-posting-server ()
 277   (wl-draft-nntp-attribute
 278    'server
 279    '(wl-nntp-posting-server elmo-nntp-default-server)))
 280
 281 (defun wl-draft-attribute-nntp-posting-port ()
 282   (wl-draft-nntp-attribute
 283    'point
 284    '(wl-nntp-posting-port elmo-nntp-default-port)))
 285
 286 (defun wl-draft-attribute-value (attr)
 287   (let ((name (symbol-name attr))
 288         fsymbol symbol)
 289     (cond ((and (setq fsymbol (intern-soft
 290                                (format "wl-draft-attribute-%s" name)))
 291                 (fboundp fsymbol))
 292            (funcall fsymbol))
 293           ((and (setq symbol (intern-soft (format "wl-%s" name)))
 294                 (boundp symbol))
 295            (symbol-value symbol))
 296           ((boundp attr)
 297            (symbol-value attr)))))
 298
 299 (defun wl-mime-quit-preview ()
 300   "Quitting method for mime-view."
 301   (let* ((temp (and (boundp 'mime-edit-temp-message-buffer) ;; for SEMI <= 1.14.6
 302                     mime-edit-temp-message-buffer))
 303          (window (selected-window))
 304          buf)
 305     (mime-preview-kill-buffer)
 306     (set-buffer temp)
 307     (setq buf mime-edit-buffer)
 308     (kill-buffer temp)
 309     (select-window window)
 310     (switch-to-buffer buf)))
 311
 312 (defun wl-draft-preview-message ()
 313   "Preview editing message."
 314   (interactive)
 315   (let* (attribute-values
 316          (orig-buffer (current-buffer))
 317          (current-point (point))
 318          (config-exec-flag wl-draft-config-exec-flag)
 319          (parent-folder wl-draft-parent-folder)
 320          (mime-display-header-hook 'wl-highlight-headers)
 321          (mime-header-encode-method-alist
 322           (append
 323            '((wl-draft-eword-encode-address-list
 324               .  (To Cc Bcc Resent-To Resent-Cc Resent-Bcc From)))
 325            (if (boundp 'mime-header-encode-method-alist)
 326                (symbol-value 'mime-header-encode-method-alist))))
 327          mime-view-ignored-field-list   ; all header.
 328          (mime-edit-translate-buffer-hook
 329           (cons
 330            (lambda ()
 331              (let ((wl-draft-config-exec-flag config-exec-flag)
 332                    (wl-draft-parent-folder parent-folder)
 333                    (copy-buffer (current-buffer)))
 334                (wl-copy-local-variables
 335                 orig-buffer
 336                 copy-buffer
 337                 (with-current-buffer orig-buffer
 338                   (append wl-draft-config-variables
 339                           (wl-draft-clone-local-variables))))
 340                (goto-char current-point)
 341                (run-hooks 'wl-draft-send-hook)
 342                (condition-case err
 343                    (setq attribute-values
 344                          (mapcar
 345                           (lambda (attr)
 346                             (cons attr (wl-draft-attribute-value attr)))
 347                           (if wl-draft-preview-attributes
 348                               (wl-draft-preview-attributes-list)
 349                             '(recipients))))
 350                  (error
 351                   (kill-buffer (current-buffer))
 352                   (signal (car err) (cdr err))))))
 353            mime-edit-translate-buffer-hook)))
 354     (mime-edit-preview-message)
 355     (make-local-variable 'mime-preview-quitting-method-alist)
 356     (setq mime-preview-quitting-method-alist
 357           '((mime-temp-message-mode . wl-mime-quit-preview)))
 358     (let ((buffer-read-only nil))
 359       (when wl-highlight-body-too
 360         (wl-highlight-body))
 361       (run-hooks 'wl-draft-preview-message-hook))
 362     (make-local-hook 'kill-buffer-hook)
 363     (add-hook 'kill-buffer-hook #'wl-draft-hide-attributes-buffer nil t)
 364     (if wl-draft-preview-attributes
 365         (ignore-errors ; in case when the window is too small
 366          (wl-draft-show-attributes-buffer attribute-values))
 367       (message (concat "Recipients: "
 368                        (cdr (assq 'recipients attribute-values)))))))
 369
 370 (defalias 'wl-draft-caesar-region  'mule-caesar-region)
 371
 372 (defalias 'wl-draft-insert-message 'mime-edit-insert-message)
 373
 374 (defalias 'wl-draft-insert-mail 'mime-edit-insert-mail)
 375
 376 ;;; Message
 377
 378 (defun wl-message-decode-mode (outbuf inbuf)
 379   (let ((mime-view-content-header-filter-hook 'wl-highlight-headers)
 380         (mime-display-header-hook 'wl-highlight-headers))
 381     (mime-view-mode nil nil nil inbuf outbuf)))
 382
 383 (defun wl-message-decode-with-all-header (outbuf inbuf)
 384   (let ((mime-view-ignored-field-regexp "^:$")
 385         (mime-view-content-header-filter-hook 'wl-highlight-headers)
 386         (mime-display-header-hook 'wl-highlight-headers)
 387         mime-view-ignored-field-list)
 388     (mime-view-mode nil nil nil inbuf outbuf)))
 389
 390 (defun wl-message-delete-mime-out-buf ()
 391   (let (mime-out-buf mime-out-win)
 392     (if (setq mime-out-buf (get-buffer mime-echo-buffer-name))
 393         (if (setq mime-out-win (get-buffer-window mime-out-buf))
 394             (delete-window mime-out-win)))))
 395
 396 (defun wl-message-request-partial (folder number)
 397   (elmo-set-work-buf
 398    (elmo-message-fetch (wl-folder-get-elmo-folder folder)
 399                        number
 400                        (elmo-make-fetch-strategy 'entire)
 401                        'unread)
 402    (mime-parse-buffer nil)))
 403
 404 (defalias 'wl-message-read              'mime-preview-scroll-up-entity)
 405 (defalias 'wl-message-next-content      'mime-preview-move-to-next)
 406 (defalias 'wl-message-prev-content      'mime-preview-move-to-previous)
 407 (defalias 'wl-message-play-content      'mime-preview-play-current-entity)
 408 (defalias 'wl-message-extract-content   'mime-preview-extract-current-entity)
 409 (defalias 'wl-message-quit              'mime-preview-quit)
 410 (defalias 'wl-message-button-dispatcher-internal
 411   'mime-button-dispatcher)
 412
 413 (defsubst wl-mime-node-id-to-string (node-id)
 414   (if (consp node-id)
 415       (mapconcat (function (lambda (num) (format "%s" (1+ num))))
 416                  (reverse node-id)
 417                  ".")
 418     "0"))
 419
 420 (defun wl-message-delete-current-part ()
 421   "Delete a part under the cursor from the multipart message."
 422   (interactive)
 423   (save-restriction
 424     (widen)
 425     (let* ((entity (get-text-property (point) 'mime-view-entity))
 426            (node-id (mime-entity-node-id entity))
 427            (filename (mime-entity-safe-filename entity))
 428            (header-start (mime-buffer-entity-header-start-internal entity))
 429            (body-end (mime-buffer-entity-body-end-internal entity))
 430            (folder (wl-folder-get-elmo-folder wl-message-buffer-cur-folder))
 431            (number wl-message-buffer-cur-number)
 432            (msgid (elmo-message-field folder number 'message-id))
 433            (orig-buf wl-message-buffer-original-buffer))
 434       (if (eq (luna-class-name entity) 'mime-elmo-imap-entity)
 435           (error "Please fetch the entire message (by typing 'C-u .') and try again"))
 436       (with-current-buffer orig-buf
 437         (unless (string-equal
 438                  (buffer-string)
 439                  (elmo-message-fetch-string
 440                   folder number
 441                   (elmo-make-fetch-strategy 'entire)))
 442           (error "Buffer content differs from actual message")))
 443       (when (and (elmo-folder-writable-p folder)
 444                  (buffer-live-p orig-buf)
 445                  node-id
 446                  (yes-or-no-p
 447                   (format "Do you really want to delete part %s? "
 448                           (wl-mime-node-id-to-string node-id))))
 449         (when (with-temp-buffer
 450                 (insert-buffer orig-buf)
 451                 (delete-region header-start body-end)
 452                 (goto-char header-start)
 453                 (insert "Content-Type: text/plain; charset=US-ASCII\n")
 454                 (when filename
 455                   (insert
 456                    "Content-Disposition:"
 457                    (mime-encode-field-body
 458                          (concat ""
 459                                  (and filename
 460                                       (concat " inline; filename=" (std11-wrap-as-quoted-string filename))))
 461                          "Content-Disposition")
 462                    "\n"))
 463                 (insert "\n")
 464                 (insert "** This part has been removed by Wanderlust **\n\n")
 465                 (elmo-folder-append-buffer folder))
 466
 467           (elmo-folder-move-messages
 468            folder (list number)
 469            (wl-folder-get-elmo-folder wl-trash-folder))
 470           (when (and (elmo-cache-get-path msgid)
 471                      (file-exists-p (elmo-cache-get-path msgid)))
 472             (delete-file (elmo-cache-get-path msgid)))
 473
 474           (mime-preview-quit)
 475           (wl-summary-delete-messages-on-buffer (list number))
 476           (wl-summary-toggle-disp-msg 'off)
 477           (setq wl-message-buffer nil)
 478           (wl-summary-sync nil "update"))))))
 479
 480 (defun wl-message-decrypt-pgp-nonmime ()
 481   "Decrypt PGP encrypted region"
 482   (interactive)
 483   (require 'pgg)
 484   (save-excursion
 485     (beginning-of-line)
 486     (if (or (re-search-forward "^-+END PGP MESSAGE-+$" nil t)
 487             (re-search-backward "^-+END PGP MESSAGE-+$" nil t))
 488         (let (beg end status)
 489           (setq end (match-end 0))
 490           (if (setq beg (re-search-backward "^-+BEGIN PGP MESSAGE-+$" nil t))
 491               (let ((inhibit-read-only t)
 492                     (buffer-file-coding-system wl-cs-autoconv))
 493                 (setq status (pgg-decrypt-region beg end))
 494                 (pgg-display-output-buffer beg end status))
 495             (message "Cannot find pgp encrypted region")))
 496       (message "Cannot find pgp encrypted region"))))
 497
 498 (defun wl-message-verify-pgp-nonmime (&optional arg)
 499   "Verify PGP signed region.
 500 With ARG, ask coding system and encode the region with it before verifying."
 501   (interactive "P")
 502   (require 'pgg)
 503   (save-excursion
 504     (beginning-of-line)
 505     (let ((message-buffer (current-buffer))
 506           beg end coding-system success)
 507       (setq end (and (or (re-search-forward "^-+END PGP SIGNATURE-+$" nil t)
 508                          (re-search-backward "^-+END PGP SIGNATURE-+$" nil t)
 509                          (error "Cannot find pgp signed region"))
 510                      (match-end 0)))
 511       (setq beg (or (re-search-backward "^-+BEGIN PGP SIGNED MESSAGE-+$" nil t)
 512                     (error "Cannot find pgp signed region")))
 513       (setq coding-system
 514             (or (let* ((situation (mime-preview-find-boundary-info))
 515                        (entity (aref situation 2)))
 516                   (mime-charset-to-coding-system
 517                    (mime-content-type-parameter
 518                     (mime-entity-content-type entity)
 519                     "charset")))
 520                 buffer-file-coding-system))
 521       (when arg
 522         (setq coding-system (read-coding-system
 523                              (format "Coding system (%S): " coding-system)
 524                              coding-system)))
 525       (with-temp-buffer
 526         (insert-buffer-substring message-buffer beg end)
 527         (encode-coding-region (point-min) (point-max) coding-system)
 528         (setq success (pgg-verify-region (point-min) (point-max) nil 'fetch)))
 529       (mime-show-echo-buffer)
 530       (set-buffer mime-echo-buffer-name)
 531       (set-window-start
 532        (get-buffer-window mime-echo-buffer-name)
 533        (point-max))
 534       (insert-buffer-substring
 535        (if success pgg-output-buffer pgg-errors-buffer)))))
 536
 537 ;; XXX: encrypted multipart isn't represented as multipart
 538 (defun wl-mime-preview-application/pgp (parent-entity entity situation)
 539   (require 'pgg)
 540   (goto-char (point-max))
 541   (let ((p (point))
 542         raw-buf to-buf representation-type child-entity)
 543     (goto-char p)
 544     (save-restriction
 545       (narrow-to-region p p)
 546       (setq to-buf (current-buffer))
 547       (with-temp-buffer
 548         (setq raw-buf (current-buffer))
 549         (mime-insert-entity entity)
 550         (when (progn
 551                 (goto-char (point-min))
 552                 (re-search-forward "^-+BEGIN PGP MESSAGE-+$" nil t))
 553           (pgg-decrypt-region (point-min)(point-max))
 554           (delete-region (point-min) (point-max))
 555           (insert-buffer pgg-output-buffer)
 556           (setq representation-type 'elmo-buffer))
 557         (setq child-entity (mime-parse-message
 558                             (mm-expand-class-name representation-type)
 559                             nil
 560                             parent-entity
 561                             (mime-entity-node-id-internal parent-entity)))
 562         (mime-display-entity
 563          child-entity
 564          nil
 565          `((header . visible)
 566            (body . visible)
 567            (entity-button . invisible))
 568          to-buf)))))
 569
 570 (defun wl-mime-preview-application/pgp-encrypted (entity situation)
 571   (let* ((entity-node-id (mime-entity-node-id entity))
 572          (mother (mime-entity-parent entity))
 573          (knum (car entity-node-id))
 574          (onum (if (> knum 0)
 575                    (1- knum)
 576                  (1+ knum)))
 577          (orig-entity (nth onum (mime-entity-children mother))))
 578     (wl-mime-preview-application/pgp entity orig-entity situation)))
 579
 580 ;;; Summary
 581 (defun wl-summary-burst-subr (message-entity target number)
 582   ;; returns new number.
 583   (let (content-type entity)
 584     (setq content-type (mime-entity-content-type message-entity))
 585     (cond ((eq (cdr (assq 'type content-type)) 'multipart)
 586            (dolist (entity (mime-entity-children message-entity))
 587              (setq number (wl-summary-burst-subr
 588                            entity
 589                            target
 590                            number))))
 591           ((and (eq (cdr (assq 'type content-type)) 'message)
 592                 (eq (cdr (assq 'subtype content-type)) 'rfc822))
 593            (message "Bursting...%s" (setq number (+ 1 number)))
 594            (setq entity
 595                  (car (mime-entity-children message-entity)))
 596            (with-temp-buffer
 597              (insert (mime-entity-body message-entity))
 598              (elmo-folder-append-buffer target))))
 599     number))
 600
 601 (defun wl-summary-burst (&optional arg)
 602   "De-capsulate embedded messages in MIME format.
 603 With ARG, ask destination folder."
 604   (interactive "P")
 605   (let ((raw-buf (wl-summary-get-original-buffer))
 606         (view-buf wl-message-buffer)
 607         message-entity target)
 608     (save-excursion
 609       (when (and (null arg)
 610                  (elmo-folder-writable-p wl-summary-buffer-elmo-folder))
 611         (setq target wl-summary-buffer-elmo-folder))
 612       (while (null target)
 613         (let ((name (wl-summary-read-folder wl-default-folder
 614                                             "to extract to")))
 615           (setq target (wl-folder-get-elmo-folder name))
 616           (unless (elmo-folder-writable-p target)
 617             (message "%s is not writable" name)
 618             (setq target nil)
 619             (sit-for 1))))
 620       (wl-summary-set-message-buffer-or-redisplay)
 621       (with-current-buffer view-buf
 622         (setq message-entity
 623               (get-text-property (point-min) 'mime-view-entity)))
 624       (when message-entity
 625         (message "Bursting...")
 626         (with-current-buffer raw-buf
 627           (wl-summary-burst-subr message-entity target 0))
 628         (message "Bursting...done"))
 629       (if (elmo-folder-plugged-p target)
 630           (elmo-folder-check target)))
 631     (when (and target
 632                (string= wl-summary-buffer-folder-name
 633                         (elmo-folder-name-internal target)))
 634       (save-excursion (wl-summary-sync-update)))))
 635
 636 ;; internal variable.
 637 (defvar wl-mime-save-directory nil "Last saved directory.")
 638 ;;; Yet another save method.
 639 (defun wl-mime-save-content (entity situation)
 640   (let ((filename (expand-file-name
 641                    (read-file-name "Save to file: "
 642                                    (expand-file-name
 643                                     (or (mime-entity-safe-filename entity)
 644                                         ".")
 645                                     (or wl-mime-save-directory
 646                                         wl-temporary-file-directory))))))
 647     (while (file-directory-p filename)
 648       (setq filename (read-file-name "Please set filename (not directory): "
 649                                      filename)))
 650     (if (and (file-exists-p filename)
 651              (not (yes-or-no-p (format "File %s exists. Save anyway? "
 652                                        filename))))
 653         (message "Not saved")
 654       (setq wl-mime-save-directory (file-name-directory filename))
 655       (mime-write-entity-content entity filename))))
 656
 657 ;;; Yet another combine method.
 658 (defun wl-mime-combine-message/partial-pieces (entity situation)
 659   "Internal method for wl to combine message/partial messages automatically."
 660   (interactive)
 661   (let* ((folder (with-current-buffer wl-message-buffer-cur-summary-buffer
 662                    wl-summary-buffer-elmo-folder))
 663          (mime-display-header-hook 'wl-highlight-headers)
 664          (id (or (cdr (assoc "id" situation)) ""))
 665          (mother (current-buffer))
 666          (summary-buf wl-message-buffer-cur-summary-buffer)
 667          subject-id overviews
 668          (root-dir (expand-file-name
 669                     (concat "m-prts-" (user-login-name))
 670                     temporary-file-directory))
 671          full-file point)
 672     (setq root-dir (concat root-dir "/" (replace-as-filename id)))
 673     (setq full-file (concat root-dir "/FULL"))
 674     (if (or (file-exists-p full-file)
 675             (not (y-or-n-p "Merge partials? ")))
 676         (with-current-buffer mother
 677           (mime-store-message/partial-piece entity situation)
 678           (setq wl-message-buffer-cur-summary-buffer summary-buf)
 679           (make-variable-buffer-local 'mime-preview-over-to-next-method-alist)
 680           (setq mime-preview-over-to-next-method-alist
 681                 (cons (cons 'mime-show-message-mode 'wl-message-exit)
 682                       mime-preview-over-to-next-method-alist))
 683           (make-variable-buffer-local 'mime-preview-over-to-previous-method-alist)
 684           (setq mime-preview-over-to-previous-method-alist
 685                 (cons (cons 'mime-show-message-mode 'wl-message-exit)
 686                       mime-preview-over-to-previous-method-alist)))
 687       (setq subject-id
 688             (eword-decode-string
 689              (decode-mime-charset-string
 690               (mime-entity-read-field entity 'Subject)
 691               wl-summary-buffer-mime-charset)))
 692       (if (string-match "[0-9\n]+" subject-id)
 693           (setq subject-id (substring subject-id 0 (match-beginning 0))))
 694       (catch 'tag
 695         (elmo-folder-do-each-message-entity (entity folder)
 696           (when (string-match
 697                  (regexp-quote subject-id)
 698                  (elmo-message-entity-field entity 'subject))
 699             (let* ((message
 700                     ;; request message at the cursor in Subject buffer.
 701                     (wl-message-request-partial
 702                      (elmo-folder-name-internal folder)
 703                      (elmo-message-entity-number entity)))
 704                    (situation (mime-entity-situation message))
 705                    (the-id (or (cdr (assoc "id" situation)) "")))
 706               (when (string= (downcase the-id)
 707                              (downcase id))
 708                 (with-current-buffer mother
 709                   (mime-store-message/partial-piece message situation))
 710                 (if (file-exists-p full-file)
 711                     (throw 'tag nil))))))
 712         (message "Not all partials found.")))))
 713
 714 (defun wl-mime-display-text/plain (entity situation)
 715   (let ((beg (point)))
 716     (mime-display-text/plain entity situation)
 717     (wl-highlight-message beg (point-max) t t)))
 718
 719 (defun wl-mime-display-header (entity situation)
 720   (let ((elmo-message-ignored-field-list
 721          (if wl-message-buffer-require-all-header
 722              nil
 723            wl-message-ignored-field-list))
 724         (elmo-message-visible-field-list wl-message-visible-field-list)
 725         (elmo-message-sorted-field-list wl-message-sort-field-list))
 726     (elmo-mime-insert-header entity situation)
 727     (wl-highlight-headers)))
 728
 729 (defun wl-mime-decrypt-application/pgp-encrypted (entity situation)
 730   (let ((summary-buffer wl-message-buffer-cur-summary-buffer)
 731         (original-buffer wl-message-buffer-original-buffer))
 732     (mime-decrypt-application/pgp-encrypted entity situation)
 733     (setq wl-message-buffer-cur-summary-buffer summary-buffer)
 734     (setq wl-message-buffer-original-buffer original-buffer)))
 735
 736
 737 ;;; Setup methods.
 738 (defun wl-mime-setup ()
 739   (set-alist 'mime-preview-quitting-method-alist
 740              'wl-original-message-mode 'wl-message-exit)
 741   (set-alist 'mime-view-over-to-previous-method-alist
 742              'wl-original-message-mode 'wl-message-exit)
 743   (set-alist 'mime-view-over-to-next-method-alist
 744              'wl-original-message-mode 'wl-message-exit)
 745   (set-alist 'mime-preview-over-to-previous-method-alist
 746              'wl-original-message-mode 'wl-message-exit)
 747   (set-alist 'mime-preview-over-to-next-method-alist
 748              'wl-original-message-mode 'wl-message-exit)
 749   (add-hook 'wl-summary-redisplay-hook 'wl-message-delete-mime-out-buf)
 750   (add-hook 'wl-message-exit-hook 'wl-message-delete-mime-out-buf)
 751
 752   (ctree-set-calist-strictly
 753    'mime-preview-condition
 754    '((type . text) (subtype . plain)
 755      (body . visible)
 756      (body-presentation-method . wl-mime-display-text/plain)
 757      (major-mode . wl-original-message-mode)))
 758
 759   (ctree-set-calist-strictly
 760    'mime-preview-condition
 761    '((type . application)(subtype . pgp-encrypted)
 762      (encoding . t)
 763      (body . invisible)
 764      (body-presentation-method . wl-mime-preview-application/pgp-encrypted)
 765      (major-mode . wl-original-message-mode)))
 766
 767   (ctree-set-calist-strictly
 768    'mime-acting-condition
 769    '((type . message) (subtype . partial)
 770      (method .  wl-mime-combine-message/partial-pieces)
 771      (request-partial-message-method . wl-message-request-partial)
 772      (major-mode . wl-original-message-mode)))
 773
 774   (ctree-set-calist-strictly
 775    'mime-acting-condition
 776    '((type . application) (subtype . pgp-encrypted)
 777      (method . wl-mime-decrypt-application/pgp-encrypted)
 778      (major-mode . wl-original-message-mode)))
 779
 780   (ctree-set-calist-strictly
 781    'mime-acting-condition
 782    '((mode . "extract")
 783      (major-mode . wl-original-message-mode)
 784      (method . wl-mime-save-content)))
 785   (set-alist 'mime-preview-following-method-alist
 786              'wl-original-message-mode
 787              (function wl-message-follow-current-entity))
 788   (set-alist 'mime-view-following-method-alist
 789              'wl-original-message-mode
 790              (function wl-message-follow-current-entity))
 791   (set-alist 'mime-edit-message-inserter-alist
 792              'wl-draft-mode (function wl-draft-insert-current-message))
 793   (set-alist 'mime-edit-mail-inserter-alist
 794              'wl-draft-mode (function wl-draft-insert-get-message))
 795   (set-alist 'mime-edit-split-message-sender-alist
 796              'wl-draft-mode
 797              (cdr (assq 'mail-mode mime-edit-split-message-sender-alist)))
 798   (set-alist 'mime-raw-representation-type-alist
 799              'wl-original-message-mode 'binary)
 800   ;; Sort and highlight header fields.
 801   (or wl-message-ignored-field-list
 802       (setq wl-message-ignored-field-list
 803             mime-view-ignored-field-list))
 804   (or wl-message-visible-field-list
 805       (setq wl-message-visible-field-list
 806             mime-view-visible-field-list))
 807   (set-alist 'mime-header-presentation-method-alist
 808              'wl-original-message-mode
 809              'wl-mime-display-header)
 810   ;; To avoid overriding wl-draft-mode-map.
 811   (when (boundp 'mime-setup-signature-key-alist)
 812     (unless (assq 'wl-draft-mode mime-setup-signature-key-alist)
 813       (setq mime-setup-signature-key-alist
 814             (cons '(wl-draft-mode . "\C-c\C-w")
 815                   mime-setup-signature-key-alist)))))
 816
 817 (require 'product)
 818 (product-provide (provide 'wl-mime) (require 'wl-version))
 819
 820 ;;; wl-mime.el ends here