* wl-mime.el (wl-draft-preview-attributes-list): New function.
[elisp/wanderlust.git] / 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
32 (require 'mime-view)
33 (require 'mime-edit)
34 (require 'mime-play)
35 (require 'elmo)
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        (append (and (wl-message-mail-p)
183                     (cdr (assq 'mail wl-draft-preview-attributes-list)))
184                (and (wl-message-news-p)
185                     (cdr (assq 'news wl-draft-preview-attributes-list)))))
186     wl-draft-preview-attributes-list))
187
188 (defun wl-draft-show-attributes-buffer (attribute-values)
189   (let* ((cur-win (selected-window))
190          (size (min
191                 (- (window-height cur-win)
192                    window-min-height 1)
193                 (- (window-height cur-win)
194                    (max
195                     window-min-height
196                     (1+ wl-draft-preview-attributes-buffer-lines))))))
197     (split-window cur-win (if (> size 0) size window-min-height))
198     (select-window (next-window))
199     (let ((pop-up-windows nil))
200       (switch-to-buffer (get-buffer-create
201                          wl-draft-preview-attributes-buffer-name)))
202     (with-current-buffer
203         (get-buffer wl-draft-preview-attributes-buffer-name)
204       (setq buffer-read-only t)
205       (let (buffer-read-only)
206         (erase-buffer)
207         (dolist (pair attribute-values)
208           (insert (capitalize (symbol-name (car pair))) ": "
209                   (format "%s" (or (cdr pair) ""))
210                   "\n"))
211         (goto-char (point-min))
212         (wl-highlight-headers)))
213     (select-window cur-win)))
214
215 (defun wl-draft-hide-attributes-buffer ()
216   (let (window buffer)
217     (when (setq window (get-buffer-window
218                         wl-draft-preview-attributes-buffer-name))
219       (select-window window)
220       (delete-window))
221     (when (setq buffer (get-buffer wl-draft-preview-attributes-buffer-name))
222       (kill-buffer buffer))))
223
224 (defun wl-draft-attribute-recipients ()
225   (concat (mapconcat
226            'identity
227            (wl-draft-deduce-address-list
228             (current-buffer)
229             (point-min)
230             (save-excursion
231               (goto-char (point-min))
232               (re-search-forward
233                (concat
234                 "^"
235                 (regexp-quote mail-header-separator)
236                 "$")
237                nil t)
238               (point)))
239            ", ")))
240
241 (defun wl-draft-attribute-envelope-from ()
242   (or wl-envelope-from
243       (wl-address-header-extract-address wl-from)))
244
245 (defun wl-draft-attribute-smtp-posting-server ()
246   (or wl-smtp-posting-server
247       (progn (require 'smtp) smtp-server)
248       "localhost"))
249
250 (defun wl-draft-attribute-smtp-posting-port ()
251   (or wl-smtp-posting-port
252       (progn (require 'smtp) smtp-service)))
253
254 (defun wl-draft-attribute-newsgroups ()
255   (std11-field-body "Newsgroups"))
256
257 (defun wl-draft-attribute-nntp-posting-server ()
258   (or wl-nntp-posting-server elmo-nntp-default-server))
259
260 (defun wl-draft-attribute-nntp-posting-port ()
261   (or wl-nntp-posting-port elmo-nntp-default-port))
262
263 (defun wl-draft-attribute-value (attr)
264   (let ((name (symbol-name attr))
265         fsymbol symbol)
266     (cond ((and (setq fsymbol (intern-soft
267                                (format "wl-draft-attribute-%s" name)))
268                 (fboundp fsymbol))
269            (funcall fsymbol))
270           ((and (setq symbol (intern-soft (format "wl-%s" name)))
271                 (boundp symbol))
272            (symbol-value symbol))
273           ((boundp attr)
274            (symbol-value attr)))))
275
276 (defun wl-mime-quit-preview ()
277   "Quitting method for mime-view."
278   (let* ((temp (and (boundp 'mime-edit-temp-message-buffer) ;; for SEMI <= 1.14.6
279                     mime-edit-temp-message-buffer))
280          (window (selected-window))
281          buf)
282     (mime-preview-kill-buffer)
283     (set-buffer temp)
284     (setq buf mime-edit-buffer)
285     (kill-buffer temp)
286     (select-window window)
287     (switch-to-buffer buf)))
288
289 (defun wl-draft-preview-message ()
290   "Preview editing message."
291   (interactive)
292   (let* (attribute-values
293          (orig-buffer (current-buffer))
294          (current-point (point))
295          (config-exec-flag wl-draft-config-exec-flag)
296          (parent-folder wl-draft-parent-folder)
297          (mime-display-header-hook 'wl-highlight-headers)
298          (mime-header-encode-method-alist
299           (append
300            '((wl-draft-eword-encode-address-list
301               .  (To Cc Bcc Resent-To Resent-Cc Resent-Bcc From)))
302            (if (boundp 'mime-header-encode-method-alist)
303                (symbol-value 'mime-header-encode-method-alist))))
304          mime-view-ignored-field-list   ; all header.
305          (mime-edit-translate-buffer-hook
306           (cons
307            (lambda ()
308              (let ((wl-draft-config-exec-flag config-exec-flag)
309                    (wl-draft-parent-folder parent-folder)
310                    (copy-buffer (current-buffer)))
311                (wl-copy-local-variables
312                 orig-buffer
313                 copy-buffer
314                 (with-current-buffer orig-buffer
315                   (append wl-draft-config-variables
316                           (wl-draft-clone-local-variables))))
317                (goto-char current-point)
318                (run-hooks 'wl-draft-send-hook)
319                (condition-case err
320                    (setq attribute-values
321                          (mapcar
322                           (lambda (attr)
323                             (cons attr (wl-draft-attribute-value attr)))
324                           (if wl-draft-preview-attributes
325                               (wl-draft-preview-attributes-list)
326                             '(recipients))))
327                  (error
328                   (kill-buffer (current-buffer))
329                   (signal (car err) (cdr err))))))
330            mime-edit-translate-buffer-hook)))
331     (mime-edit-preview-message)
332     (make-local-variable 'mime-preview-quitting-method-alist)
333     (setq mime-preview-quitting-method-alist
334           '((mime-temp-message-mode . wl-mime-quit-preview)))
335     (let ((buffer-read-only nil))
336       (when wl-highlight-body-too
337         (wl-highlight-body))
338       (run-hooks 'wl-draft-preview-message-hook))
339     (make-local-hook 'kill-buffer-hook)
340     (add-hook 'kill-buffer-hook #'wl-draft-hide-attributes-buffer nil t)
341     (if wl-draft-preview-attributes
342         (ignore-errors ; in case when the window is too small
343          (wl-draft-show-attributes-buffer attribute-values))
344       (message (concat "Recipients: "
345                        (cdr (assq 'recipients attribute-values)))))))
346
347 (defalias 'wl-draft-caesar-region  'mule-caesar-region)
348
349 (defalias 'wl-draft-insert-message 'mime-edit-insert-message)
350
351 (defalias 'wl-draft-insert-mail 'mime-edit-insert-mail)
352
353 ;;; Message
354
355 (defun wl-message-decode-mode (outbuf inbuf)
356   (let ((mime-view-content-header-filter-hook 'wl-highlight-headers)
357         (mime-display-header-hook 'wl-highlight-headers))
358     (mime-view-mode nil nil nil inbuf outbuf)))
359
360 (defun wl-message-decode-with-all-header (outbuf inbuf)
361   (let ((mime-view-ignored-field-regexp "^:$")
362         (mime-view-content-header-filter-hook 'wl-highlight-headers)
363         (mime-display-header-hook 'wl-highlight-headers)
364         mime-view-ignored-field-list)
365     (mime-view-mode nil nil nil inbuf outbuf)))
366
367 (defun wl-message-delete-mime-out-buf ()
368   (let (mime-out-buf mime-out-win)
369     (if (setq mime-out-buf (get-buffer mime-echo-buffer-name))
370         (if (setq mime-out-win (get-buffer-window mime-out-buf))
371             (delete-window mime-out-win)))))
372
373 (defun wl-message-request-partial (folder number)
374   (elmo-set-work-buf
375    (elmo-message-fetch (wl-folder-get-elmo-folder folder)
376                        number
377                        (elmo-make-fetch-strategy 'entire)
378                        'unread)
379    (mime-parse-buffer nil)))
380
381 (defalias 'wl-message-read              'mime-preview-scroll-up-entity)
382 (defalias 'wl-message-next-content      'mime-preview-move-to-next)
383 (defalias 'wl-message-prev-content      'mime-preview-move-to-previous)
384 (defalias 'wl-message-play-content      'mime-preview-play-current-entity)
385 (defalias 'wl-message-extract-content   'mime-preview-extract-current-entity)
386 (defalias 'wl-message-quit              'mime-preview-quit)
387 (defalias 'wl-message-button-dispatcher-internal
388   'mime-button-dispatcher)
389
390 (defsubst wl-mime-node-id-to-string (node-id)
391   (if (consp node-id)
392       (mapconcat (function (lambda (num) (format "%s" (1+ num))))
393                  (reverse node-id)
394                  ".")
395     "0"))
396
397 (defun wl-message-delete-current-part ()
398   "Delete a part under the cursor from the multipart message."
399   (interactive)
400   (save-restriction
401     (widen)
402     (let* ((entity (get-text-property (point) 'mime-view-entity))
403            (node-id (mime-entity-node-id entity))
404            (filename (mime-entity-safe-filename entity))
405            (header-start (mime-buffer-entity-header-start-internal entity))
406            (body-end (mime-buffer-entity-body-end-internal entity))
407            (folder (wl-folder-get-elmo-folder wl-message-buffer-cur-folder))
408            (number wl-message-buffer-cur-number)
409            (msgid (elmo-message-field folder number 'message-id))
410            (orig-buf wl-message-buffer-original-buffer))
411       (if (eq (luna-class-name entity) 'mime-elmo-imap-entity)
412           (error "Please fetch the entire message (by typing 'C-u .') and try again"))
413       (with-current-buffer orig-buf
414         (unless (string-equal
415                  (buffer-string)
416                  (elmo-message-fetch-string
417                   folder number
418                   (elmo-make-fetch-strategy 'entire)))
419           (error "Buffer content differs from actual message")))
420       (when (and (elmo-folder-writable-p folder)
421                  (buffer-live-p orig-buf)
422                  node-id
423                  (yes-or-no-p
424                   (format "Do you really want to delete part %s? "
425                           (wl-mime-node-id-to-string node-id))))
426         (when (with-temp-buffer
427                 (insert-buffer orig-buf)
428                 (delete-region header-start body-end)
429                 (goto-char header-start)
430                 (insert "Content-Type: text/plain; charset=US-ASCII\n")
431                 (when filename
432                   (insert
433                    "Content-Disposition:"
434                    (mime-encode-field-body
435                          (concat ""
436                                  (and filename
437                                       (concat " inline; filename=" (std11-wrap-as-quoted-string filename))))
438                          "Content-Disposition")
439                    "\n"))
440                 (insert "\n")
441                 (insert "** This part has been removed by Wanderlust **\n\n")
442                 (elmo-folder-append-buffer folder))
443
444           (elmo-folder-move-messages
445            folder (list number)
446            (wl-folder-get-elmo-folder wl-trash-folder))
447           (when (and (elmo-cache-get-path msgid)
448                      (file-exists-p (elmo-cache-get-path msgid)))
449             (delete-file (elmo-cache-get-path msgid)))
450
451           (mime-preview-quit)
452           (wl-summary-delete-messages-on-buffer (list number))
453           (wl-summary-toggle-disp-msg 'off)
454           (setq wl-message-buffer nil)
455           (wl-summary-sync nil "update"))))))
456
457 (defun wl-message-decrypt-pgp-nonmime ()
458   "Decrypt PGP encrypted region"
459   (interactive)
460   (require 'pgg)
461   (save-excursion
462     (beginning-of-line)
463     (if (or (re-search-forward "^-+END PGP MESSAGE-+$" nil t)
464             (re-search-backward "^-+END PGP MESSAGE-+$" nil t))
465         (let (beg end status)
466           (setq end (match-end 0))
467           (if (setq beg (re-search-backward "^-+BEGIN PGP MESSAGE-+$" nil t))
468               (let ((inhibit-read-only t)
469                     (buffer-file-coding-system wl-cs-autoconv))
470                 (setq status (pgg-decrypt-region beg end))
471                 (pgg-display-output-buffer beg end status))
472             (message "Cannot find pgp encrypted region")))
473       (message "Cannot find pgp encrypted region"))))
474
475 (defun wl-message-verify-pgp-nonmime ()
476   "Verify PGP signed region"
477   (interactive)
478   (require 'pgg)
479   (save-excursion
480     (beginning-of-line)
481     (if (and (or (re-search-forward "^-+END PGP SIGNATURE-+$" nil t)
482                  (re-search-backward "^-+END PGP SIGNATURE-+$" nil t))
483              (re-search-backward "^-+BEGIN PGP SIGNED MESSAGE-+$" nil t))
484         (let (status)
485           (let* ((beg (point))
486                  (situation (mime-preview-find-boundary-info))
487                  (p-end (aref situation 1))
488                  (entity (aref situation 2))
489                  (count 0))
490             (goto-char p-end)
491             (while (< beg (point))
492               (if (re-search-backward "^-+BEGIN PGP SIGNED MESSAGE-+$" nil t)
493                   (setq count (+ count 1))
494                 (debug)))
495             (with-temp-buffer
496               (set-buffer-multibyte nil)
497               (insert (mime-entity-body entity))
498               (goto-char (point-max))
499               (while (> count 0)
500                 (if (re-search-backward "^-+BEGIN PGP SIGNED MESSAGE-+$" nil t)
501                     (setq count (- count 1))
502                   (debug)))
503               (let ((r-beg (point))
504                     (r-end (re-search-forward "^-+END PGP SIGNATURE-+$" nil t)))
505                 (if r-end
506                     (setq status (pgg-verify-region r-beg r-end nil 'fetch))
507                   (debug)))))
508           (mime-show-echo-buffer)
509           (set-buffer mime-echo-buffer-name)
510           (set-window-start
511            (get-buffer-window mime-echo-buffer-name)
512            (point-max))
513           (insert-buffer-substring
514            (if status pgg-output-buffer pgg-errors-buffer)))
515       (message "Cannot find pgp signed region"))))
516
517 ;; XXX: encrypted multipart isn't represented as multipart
518 (defun wl-mime-preview-application/pgp (parent-entity entity situation)
519   (require 'pgg)
520   (goto-char (point-max))
521   (let ((p (point))
522         raw-buf to-buf representation-type child-entity)
523     (goto-char p)
524     (save-restriction
525       (narrow-to-region p p)
526       (setq to-buf (current-buffer))
527       (with-temp-buffer
528         (setq raw-buf (current-buffer))
529         (mime-insert-entity entity)
530         (when (progn
531                 (goto-char (point-min))
532                 (re-search-forward "^-+BEGIN PGP MESSAGE-+$" nil t))
533           (pgg-decrypt-region (point-min)(point-max))
534           (delete-region (point-min) (point-max))
535           (insert-buffer pgg-output-buffer)
536           (setq representation-type 'elmo-buffer))
537         (setq child-entity (mime-parse-message
538                             (mm-expand-class-name representation-type)
539                             nil
540                             parent-entity
541                             (mime-entity-node-id-internal parent-entity)))
542         (mime-display-entity
543          child-entity
544          nil
545          `((header . visible)
546            (body . visible)
547            (entity-button . invisible))
548          to-buf)))))
549
550 (defun wl-mime-preview-application/pgp-encrypted (entity situation)
551   (let* ((entity-node-id (mime-entity-node-id entity))
552          (mother (mime-entity-parent entity))
553          (knum (car entity-node-id))
554          (onum (if (> knum 0)
555                    (1- knum)
556                  (1+ knum)))
557          (orig-entity (nth onum (mime-entity-children mother))))
558     (wl-mime-preview-application/pgp entity orig-entity situation)))
559
560 ;;; Summary
561 (defun wl-summary-burst-subr (message-entity target number)
562   ;; returns new number.
563   (let (content-type entity)
564     (setq content-type (mime-entity-content-type message-entity))
565     (cond ((eq (cdr (assq 'type content-type)) 'multipart)
566            (dolist (entity (mime-entity-children message-entity))
567              (setq number (wl-summary-burst-subr
568                            entity
569                            target
570                            number))))
571           ((and (eq (cdr (assq 'type content-type)) 'message)
572                 (eq (cdr (assq 'subtype content-type)) 'rfc822))
573            (message "Bursting...%s" (setq number (+ 1 number)))
574            (setq entity
575                  (car (mime-entity-children message-entity)))
576            (with-temp-buffer
577              (insert (mime-entity-body message-entity))
578              (elmo-folder-append-buffer target))))
579     number))
580
581 (defun wl-summary-burst (&optional arg)
582   "De-capsulate embedded messages in MIME format.
583 With ARG, ask destination folder."
584   (interactive "P")
585   (let ((raw-buf (wl-summary-get-original-buffer))
586         (view-buf wl-message-buffer)
587         message-entity target)
588     (save-excursion
589       (when (and (null arg)
590                  (elmo-folder-writable-p wl-summary-buffer-elmo-folder))
591         (setq target wl-summary-buffer-elmo-folder))
592       (while (null target)
593         (let ((name (wl-summary-read-folder wl-default-folder
594                                             "to extract to")))
595           (setq target (wl-folder-get-elmo-folder name))
596           (unless (elmo-folder-writable-p target)
597             (message "%s is not writable" name)
598             (setq target nil)
599             (sit-for 1))))
600       (wl-summary-set-message-buffer-or-redisplay)
601       (with-current-buffer view-buf
602         (setq message-entity
603               (get-text-property (point-min) 'mime-view-entity)))
604       (when message-entity
605         (message "Bursting...")
606         (with-current-buffer raw-buf
607           (wl-summary-burst-subr message-entity target 0))
608         (message "Bursting...done"))
609       (if (elmo-folder-plugged-p target)
610           (elmo-folder-check target)))
611     (when (and target
612                (string= wl-summary-buffer-folder-name
613                         (elmo-folder-name-internal target)))
614       (save-excursion (wl-summary-sync-update)))))
615
616 ;; internal variable.
617 (defvar wl-mime-save-directory nil "Last saved directory.")
618 ;;; Yet another save method.
619 (defun wl-mime-save-content (entity situation)
620   (let ((filename (expand-file-name
621                    (read-file-name "Save to file: "
622                                    (expand-file-name
623                                     (or (mime-entity-safe-filename entity)
624                                         ".")
625                                     (or wl-mime-save-directory
626                                         wl-temporary-file-directory))))))
627     (while (file-directory-p filename)
628       (setq filename (read-file-name "Please set filename (not directory): "
629                                      filename)))
630     (if (and (file-exists-p filename)
631              (not (yes-or-no-p (format "File %s exists. Save anyway? "
632                                        filename))))
633         (message "Not saved")
634       (setq wl-mime-save-directory (file-name-directory filename))
635       (mime-write-entity-content entity filename))))
636
637 ;;; Yet another combine method.
638 (defun wl-mime-combine-message/partial-pieces (entity situation)
639   "Internal method for wl to combine message/partial messages automatically."
640   (interactive)
641   (let* ((folder (with-current-buffer wl-message-buffer-cur-summary-buffer
642                    wl-summary-buffer-elmo-folder))
643          (mime-display-header-hook 'wl-highlight-headers)
644          (id (or (cdr (assoc "id" situation)) ""))
645          (mother (current-buffer))
646          (summary-buf wl-message-buffer-cur-summary-buffer)
647          subject-id overviews
648          (root-dir (expand-file-name
649                     (concat "m-prts-" (user-login-name))
650                     temporary-file-directory))
651          full-file point)
652     (setq root-dir (concat root-dir "/" (replace-as-filename id)))
653     (setq full-file (concat root-dir "/FULL"))
654     (if (or (file-exists-p full-file)
655             (not (y-or-n-p "Merge partials? ")))
656         (with-current-buffer mother
657           (mime-store-message/partial-piece entity situation)
658           (setq wl-message-buffer-cur-summary-buffer summary-buf)
659           (make-variable-buffer-local 'mime-preview-over-to-next-method-alist)
660           (setq mime-preview-over-to-next-method-alist
661                 (cons (cons 'mime-show-message-mode 'wl-message-exit)
662                       mime-preview-over-to-next-method-alist))
663           (make-variable-buffer-local 'mime-preview-over-to-previous-method-alist)
664           (setq mime-preview-over-to-previous-method-alist
665                 (cons (cons 'mime-show-message-mode 'wl-message-exit)
666                       mime-preview-over-to-previous-method-alist)))
667       (setq subject-id
668             (eword-decode-string
669              (decode-mime-charset-string
670               (mime-entity-read-field entity 'Subject)
671               wl-summary-buffer-mime-charset)))
672       (if (string-match "[0-9\n]+" subject-id)
673           (setq subject-id (substring subject-id 0 (match-beginning 0))))
674       (catch 'tag
675         (elmo-folder-do-each-message-entity (entity folder)
676           (when (string-match
677                  (regexp-quote subject-id)
678                  (elmo-message-entity-field entity 'subject 'decode))
679             (let* ((message
680                     ;; request message at the cursor in Subject buffer.
681                     (wl-message-request-partial
682                      (elmo-folder-name-internal folder)
683                      (elmo-message-entity-number entity)))
684                    (situation (mime-entity-situation message))
685                    (the-id (or (cdr (assoc "id" situation)) "")))
686               (when (string= (downcase the-id)
687                              (downcase id))
688                 (with-current-buffer mother
689                   (mime-store-message/partial-piece message situation))
690                 (if (file-exists-p full-file)
691                     (throw 'tag nil))))))
692         (message "Not all partials found.")))))
693
694 (defun wl-mime-display-text/plain (entity situation)
695   (let ((beg (point)))
696     (mime-display-text/plain entity situation)
697     (wl-highlight-message beg (point-max) t t)))
698
699 (defun wl-mime-display-header (entity situation)
700   (let ((elmo-message-ignored-field-list
701          (if wl-message-buffer-require-all-header
702              nil
703            wl-message-ignored-field-list))
704         (elmo-message-visible-field-list wl-message-visible-field-list)
705         (elmo-message-sorted-field-list wl-message-sort-field-list))
706     (elmo-mime-insert-header entity situation)
707     (wl-highlight-headers)))
708
709 (defun wl-mime-decrypt-application/pgp-encrypted (entity situation)
710   (let ((summary-buffer wl-message-buffer-cur-summary-buffer)
711         (original-buffer wl-message-buffer-original-buffer))
712     (mime-decrypt-application/pgp-encrypted entity situation)
713     (setq wl-message-buffer-cur-summary-buffer summary-buffer)
714     (setq wl-message-buffer-original-buffer original-buffer)))
715
716
717 ;;; Setup methods.
718 (defun wl-mime-setup ()
719   (set-alist 'mime-preview-quitting-method-alist
720              'wl-original-message-mode 'wl-message-exit)
721   (set-alist 'mime-view-over-to-previous-method-alist
722              'wl-original-message-mode 'wl-message-exit)
723   (set-alist 'mime-view-over-to-next-method-alist
724              'wl-original-message-mode 'wl-message-exit)
725   (set-alist 'mime-preview-over-to-previous-method-alist
726              'wl-original-message-mode 'wl-message-exit)
727   (set-alist 'mime-preview-over-to-next-method-alist
728              'wl-original-message-mode 'wl-message-exit)
729   (add-hook 'wl-summary-redisplay-hook 'wl-message-delete-mime-out-buf)
730   (add-hook 'wl-message-exit-hook 'wl-message-delete-mime-out-buf)
731
732   (ctree-set-calist-strictly
733    'mime-preview-condition
734    '((type . text) (subtype . plain)
735      (body . visible)
736      (body-presentation-method . wl-mime-display-text/plain)
737      (major-mode . wl-original-message-mode)))
738
739   (ctree-set-calist-strictly
740    'mime-preview-condition
741    '((type . application)(subtype . pgp-encrypted)
742      (encoding . t)
743      (body . invisible)
744      (body-presentation-method . wl-mime-preview-application/pgp-encrypted)
745      (major-mode . wl-original-message-mode)))
746
747   (ctree-set-calist-strictly
748    'mime-acting-condition
749    '((type . message) (subtype . partial)
750      (method .  wl-mime-combine-message/partial-pieces)
751      (request-partial-message-method . wl-message-request-partial)
752      (major-mode . wl-original-message-mode)))
753
754   (ctree-set-calist-strictly
755    'mime-acting-condition
756    '((type . application) (subtype . pgp-encrypted)
757      (method . wl-mime-decrypt-application/pgp-encrypted)
758      (major-mode . wl-original-message-mode)))
759
760   (ctree-set-calist-strictly
761    'mime-acting-condition
762    '((mode . "extract")
763      (major-mode . wl-original-message-mode)
764      (method . wl-mime-save-content)))
765   (set-alist 'mime-preview-following-method-alist
766              'wl-original-message-mode
767              (function wl-message-follow-current-entity))
768   (set-alist 'mime-view-following-method-alist
769              'wl-original-message-mode
770              (function wl-message-follow-current-entity))
771   (set-alist 'mime-edit-message-inserter-alist
772              'wl-draft-mode (function wl-draft-insert-current-message))
773   (set-alist 'mime-edit-mail-inserter-alist
774              'wl-draft-mode (function wl-draft-insert-get-message))
775   (set-alist 'mime-edit-split-message-sender-alist
776              'wl-draft-mode
777              (cdr (assq 'mail-mode mime-edit-split-message-sender-alist)))
778   (set-alist 'mime-raw-representation-type-alist
779              'wl-original-message-mode 'binary)
780   ;; Sort and highlight header fields.
781   (or wl-message-ignored-field-list
782       (setq wl-message-ignored-field-list
783             mime-view-ignored-field-list))
784   (or wl-message-visible-field-list
785       (setq wl-message-visible-field-list
786             mime-view-visible-field-list))
787   (set-alist 'mime-header-presentation-method-alist
788              'wl-original-message-mode
789              'wl-mime-display-header)
790   ;; To avoid overriding wl-draft-mode-map.
791   (when (boundp 'mime-setup-signature-key-alist)
792     (unless (assq 'wl-draft-mode mime-setup-signature-key-alist)
793       (setq mime-setup-signature-key-alist
794             (cons '(wl-draft-mode . "\C-c\C-w")
795                   mime-setup-signature-key-alist)))))
796
797 (require 'product)
798 (product-provide (provide 'wl-mime) (require 'wl-version))
799
800 ;;; wl-mime.el ends here