1 ;;; wl-mime.el --- SEMI implementations of MIME processing on Wanderlust.
3 ;; Copyright (C) 1998,1999,2000 Yuuichi Teranishi <teranisi@gohome.org>
5 ;; Author: Yuuichi Teranishi <teranisi@gohome.org>
6 ;; Keywords: mail, net news
8 ;; This file is part of Wanderlust (Yet Another Message Interface on Emacsen).
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)
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.
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.
38 (defalias-maybe 'Meadow-version 'ignore))
40 (defvar xemacs-betaname)
41 (defvar xemacs-codename)
42 (defvar enable-multibyte-characters)
47 (defalias 'wl-draft-editor-mode 'mime-edit-mode)
49 (defalias 'wl-draft-decode-message-in-buffer
50 'mime-edit-decode-message-in-buffer)
52 (defun wl-draft-yank-current-message-entity ()
53 "Yank currently displayed message entity.
54 By setting following-method as yank-content.
56 If region is active, yank region contents instead. \(this feature is available
57 if and only if `transient-mark-mode' \(GNU Emacs\) or `zmacs-regions' \(XEmacs\)
59 (let ((wl-draft-buffer (current-buffer))
60 (mime-view-following-method-alist
61 (list (cons 'wl-original-message-mode
62 (function wl-draft-yank-to-draft-buffer))))
63 (mime-preview-following-method-alist
64 (list (cons 'wl-original-message-mode
65 (function wl-draft-yank-to-draft-buffer)))))
66 (if (get-buffer (wl-current-message-buffer))
68 (set-buffer (wl-current-message-buffer))
71 (if (or (and wl-on-xemacs
72 zmacs-regions zmacs-region-active-p)
73 (and (not wl-on-xemacs)
74 transient-mark-mode mark-active))
75 (wl-mime-preview-follow-current-region)
76 (mime-preview-follow-current-entity)))))))
78 ;; modified mime-preview-follow-current-entity from mime-view.el
79 (defun wl-mime-preview-follow-current-region ()
80 "Write follow message to current region.
81 It calls following-method selected from variable
82 `mime-preview-following-method-alist'."
84 (let ((r-beg (region-beginning))
86 (entity (get-text-property (point-min)
88 (let* ((mode (mime-preview-original-major-mode 'recursive))
90 (format "%s-active-region" (buffer-name)))
92 (the-buf (current-buffer))
95 (set-buffer (setq new-buf (get-buffer-create new-name)))
98 (insert-buffer-substring the-buf r-beg r-end)
99 (goto-char (point-min))
100 (let ((current-entity
101 (if (and (eq (mime-entity-media-type entity) 'message)
102 (eq (mime-entity-media-subtype entity) 'rfc822))
103 (car (mime-entity-children entity))
105 (while (and current-entity
106 (if (and (eq (mime-entity-media-type
107 current-entity) 'message)
108 (eq (mime-entity-media-subtype
109 current-entity) 'rfc822))
111 (mime-insert-header current-entity fields)
113 (setq fields (std11-collect-field-names)
114 current-entity (mime-entity-parent current-entity))
116 (let ((rest mime-view-following-required-fields-list)
119 (setq field-name (car rest))
120 (or (std11-field-body field-name)
124 (let ((entity (when mime-mother-buffer
125 (set-buffer mime-mother-buffer)
126 (get-text-property (point)
127 'mime-view-entity))))
129 (null (setq ret (mime-entity-fetch-field
130 entity field-name))))
131 (setq entity (mime-entity-parent entity)))))
133 (insert (concat field-name ": " ret "\n"))
135 (setq rest (cdr rest))
138 (let ((f (cdr (assq mode mime-preview-following-method-alist))))
143 "Sorry, following method for %s is not implemented yet."
148 (defalias 'wl-draft-enclose-digest-region 'mime-edit-enclose-digest-region)
150 (defun wl-draft-preview-message ()
151 "Preview editing message."
153 (let* (recipients-message
154 (current-point (point))
155 (config-exec-flag wl-draft-config-exec-flag)
156 (parent-folder wl-draft-parent-folder)
157 (mime-display-header-hook 'wl-highlight-headers)
158 (mime-header-encode-method-alist
160 '((wl-draft-eword-encode-address-list
161 . (To Cc Bcc Resent-To Resent-Cc Bcc Resent-Bcc)))
162 (if (boundp 'mime-header-encode-method-alist)
163 (symbol-value 'mime-header-encode-method-alist))))
164 mime-view-ignored-field-list ; all header.
165 (mime-edit-translate-buffer-hook
170 (let ((wl-draft-config-exec-flag config-exec-flag)
171 (wl-draft-parent-folder parent-folder))
172 (goto-char current-point)
173 (run-hooks 'wl-draft-send-hook)
174 (setq recipients-message
176 (concat "Recipients: "
179 (wl-draft-deduce-address-list
183 (goto-char (point-min))
187 (regexp-quote mail-header-separator)
193 (kill-buffer (current-buffer))
194 (signal (car err) (cdr err)))))))))
195 mime-edit-translate-buffer-hook)))
196 (mime-edit-preview-message)
197 (let ((buffer-read-only nil))
198 (when wl-highlight-body-too
200 (run-hooks 'wl-draft-preview-message-hook))
201 (message recipients-message)))
203 (defalias 'wl-draft-caesar-region 'mule-caesar-region)
205 (defalias 'wl-draft-insert-message 'mime-edit-insert-message)
207 (defalias 'wl-draft-insert-mail 'mime-edit-insert-mail)
211 (defun wl-message-decode-mode (outbuf inbuf)
212 (let ((mime-view-content-header-filter-hook 'wl-highlight-headers)
213 (mime-display-header-hook 'wl-highlight-headers))
214 (mime-view-mode nil nil nil inbuf outbuf)))
216 (defun wl-message-decode-with-all-header (outbuf inbuf)
217 (let ((mime-view-ignored-field-regexp "^:$")
218 (mime-view-content-header-filter-hook 'wl-highlight-headers)
219 (mime-display-header-hook 'wl-highlight-headers)
220 mime-view-ignored-field-list)
221 (mime-view-mode nil nil nil inbuf outbuf)))
223 (defun wl-message-delete-mime-out-buf ()
224 (let (mime-out-buf mime-out-win)
225 (if (setq mime-out-buf (get-buffer mime-echo-buffer-name))
226 (if (setq mime-out-win (get-buffer-window mime-out-buf))
227 (delete-window mime-out-win)))))
229 (defun wl-message-request-partial (folder number)
231 (elmo-message-fetch (wl-folder-get-elmo-folder folder)
233 (elmo-make-fetch-strategy 'entire)
237 (mime-parse-buffer nil)))
239 (defalias 'wl-message-read 'mime-preview-scroll-up-entity)
240 (defalias 'wl-message-next-content 'mime-preview-move-to-next)
241 (defalias 'wl-message-prev-content 'mime-preview-move-to-previous)
242 (defalias 'wl-message-play-content 'mime-preview-play-current-entity)
243 (defalias 'wl-message-extract-content 'mime-preview-extract-current-entity)
244 (defalias 'wl-message-quit 'mime-preview-quit)
245 (defalias 'wl-message-button-dispatcher-internal
246 'mime-button-dispatcher)
248 (defsubst wl-mime-node-id-to-string (node-id)
250 (mapconcat (function (lambda (num) (format "%s" (1+ num))))
255 (defun wl-message-delete-current-part ()
256 "Delete a part under the cursor from the multipart message."
260 (let* ((entity (get-text-property (point) 'mime-view-entity))
261 (node-id (mime-entity-node-id entity))
262 (header-start (mime-buffer-entity-header-start-internal entity))
263 (body-end (mime-buffer-entity-body-end-internal entity))
264 (folder (wl-folder-get-elmo-folder wl-message-buffer-cur-folder))
265 (number wl-message-buffer-cur-number)
266 (msgid (elmo-message-field folder number 'message-id))
267 (orig-buf wl-message-buffer-original-buffer))
268 (if (eq (luna-class-name entity) 'mime-elmo-imap-entity)
269 (error "Please fetch the entire message (by typing 'C-u .') and try again"))
270 (with-current-buffer orig-buf
271 (unless (string-equal
273 (elmo-message-fetch folder number
274 (elmo-make-fetch-strategy 'entire)))
275 (error "Buffer content differs from actual message")))
276 (when (and (elmo-folder-writable-p folder)
277 (buffer-live-p orig-buf)
280 (format "Do you really want to delete part %s? "
281 (wl-mime-node-id-to-string node-id))))
283 (insert-buffer orig-buf)
284 (delete-region header-start body-end)
285 (goto-char header-start)
286 (insert "Content-Type: text/plain; charset=US-ASCII\n\n")
287 (insert "** This part has been removed by Wanderlust **\n\n")
288 (elmo-folder-append-buffer folder t))
290 (elmo-folder-append-messages
291 (wl-folder-get-elmo-folder wl-trash-folder)
292 folder (list number) nil)
293 (elmo-folder-delete-messages folder (list number))
295 (when (file-exists-p (elmo-cache-get-path msgid))
296 (delete-file (elmo-cache-get-path msgid)))
299 (wl-summary-toggle-disp-msg 'off)
300 (wl-summary-sync nil "update")))))
303 (defun wl-summary-burst-subr (message-entity target number)
304 ;; returns new number.
305 (let (content-type entity)
306 (setq content-type (mime-entity-content-type message-entity))
307 (cond ((eq (cdr (assq 'type content-type)) 'multipart)
308 (dolist (entity (mime-entity-children message-entity))
309 (setq number (wl-summary-burst-subr
313 ((and (eq (cdr (assq 'type content-type)) 'message)
314 (eq (cdr (assq 'subtype content-type)) 'rfc822))
315 (message "Bursting...%s" (setq number (+ 1 number)))
317 (car (mime-entity-children message-entity)))
319 (insert (mime-entity-body message-entity))
320 (elmo-folder-append-buffer
322 (mime-entity-fetch-field entity "Message-ID")))))
325 (defun wl-summary-burst (&optional arg)
326 "De-capsulate embedded messages in MIME format.
327 With ARG, ask destination folder."
329 (let ((raw-buf (wl-summary-get-original-buffer))
330 (view-buf wl-message-buffer)
331 children message-entity content-type target)
333 (setq target wl-summary-buffer-elmo-folder)
334 (when (or arg (not (elmo-folder-writable-p target)))
335 (let ((fld (wl-summary-read-folder wl-default-folder "to extract to")))
336 (setq target (wl-folder-get-elmo-folder fld))))
337 (wl-summary-set-message-buffer-or-redisplay)
338 (with-current-buffer view-buf
339 (setq message-entity (get-text-property (point-min) 'mime-view-entity)))
341 (message "Bursting...")
342 (with-current-buffer raw-buf
343 (wl-summary-burst-subr message-entity target 0))
344 (message "Bursting...done"))
345 (if (elmo-folder-plugged-p target)
346 (elmo-folder-check target)))
347 (wl-summary-sync-update)))
349 ;; internal variable.
350 (defvar wl-mime-save-directory nil "Last saved directory.")
351 ;;; Yet another save method.
352 (defun wl-mime-save-content (entity situation)
353 (let ((filename (read-file-name "Save to file: "
355 (or (mime-entity-safe-filename entity)
357 (or wl-mime-save-directory
358 wl-temporary-file-directory)))))
359 (while (file-directory-p filename)
360 (setq filename (read-file-name "Please set filename (not directory): "
362 (if (and (file-exists-p filename)
363 (not (yes-or-no-p (format "File %s exists. Save anyway? "
365 (message "Not saved")
366 (setq wl-mime-save-directory (file-name-directory filename))
367 (mime-write-entity-content entity filename))))
369 ;;; Yet another combine method.
370 (defun wl-mime-combine-message/partial-pieces (entity situation)
371 "Internal method for wl to combine message/partial messages automatically."
373 (let* ((msgdb (save-excursion
374 (set-buffer wl-message-buffer-cur-summary-buffer)
375 (wl-summary-buffer-msgdb)))
376 (mime-display-header-hook 'wl-highlight-headers)
377 (folder wl-message-buffer-cur-folder)
378 (id (or (cdr (assoc "id" situation)) ""))
379 (mother (current-buffer))
380 (summary-buf wl-message-buffer-cur-summary-buffer)
382 (root-dir (expand-file-name
383 (concat "m-prts-" (user-login-name))
384 temporary-file-directory))
386 (setq root-dir (concat root-dir "/" (replace-as-filename id)))
387 (setq full-file (concat root-dir "/FULL"))
388 (if (or (file-exists-p full-file)
389 (not (y-or-n-p "Merge partials? ")))
390 (with-current-buffer mother
391 (mime-store-message/partial-piece entity situation)
392 (setq wl-message-buffer-cur-summary-buffer summary-buf)
393 (make-variable-buffer-local 'mime-preview-over-to-next-method-alist)
394 (setq mime-preview-over-to-next-method-alist
395 (cons (cons 'mime-show-message-mode 'wl-message-exit)
396 mime-preview-over-to-next-method-alist))
397 (make-variable-buffer-local 'mime-preview-over-to-previous-method-alist)
398 (setq mime-preview-over-to-previous-method-alist
399 (cons (cons 'mime-show-message-mode 'wl-message-exit)
400 mime-preview-over-to-previous-method-alist)))
403 (decode-mime-charset-string
404 (mime-entity-read-field entity 'Subject)
405 wl-summary-buffer-mime-charset)))
406 (if (string-match "[0-9\n]+" subject-id)
407 (setq subject-id (substring subject-id 0 (match-beginning 0))))
408 (setq overviews (elmo-msgdb-get-overview msgdb))
412 (regexp-quote subject-id)
413 (elmo-msgdb-overview-entity-get-subject (car overviews)))
415 ;; request message at the cursor in Subject buffer.
416 (wl-message-request-partial
418 (elmo-msgdb-overview-entity-get-number
420 (situation (mime-entity-situation message))
421 (the-id (or (cdr (assoc "id" situation)) "")))
422 (when (string= (downcase the-id)
424 (with-current-buffer mother
425 (mime-store-message/partial-piece message situation))
426 (if (file-exists-p full-file)
428 (setq overviews (cdr overviews)))
429 (message "Not all partials found.")))))
431 (defun wl-mime-display-text/plain (entity situation)
433 (mime-display-text/plain entity situation)
434 (wl-highlight-message beg (point-max) t t)))
436 (defun wl-mime-display-header (entity situation)
437 (let ((elmo-message-ignored-field-list
438 (if wl-message-buffer-all-header-flag
440 wl-message-ignored-field-list))
441 (elmo-message-visible-field-list wl-message-visible-field-list)
442 (elmo-message-sorted-field-list wl-message-sort-field-list))
443 (elmo-mime-insert-header entity situation)
444 (wl-highlight-headers)))
446 (defun wl-mime-decrypt-application/pgp-encrypted (entity situation)
447 (let ((summary-buffer wl-message-buffer-cur-summary-buffer)
448 (original-buffer wl-message-buffer-original-buffer))
449 (mime-decrypt-application/pgp-encrypted entity situation)
450 (setq wl-message-buffer-cur-summary-buffer summary-buffer)
451 (setq wl-message-buffer-original-buffer original-buffer)))
455 (defun wl-mime-setup ()
456 (set-alist 'mime-preview-quitting-method-alist
457 'wl-original-message-mode 'wl-message-exit)
458 (set-alist 'mime-view-over-to-previous-method-alist
459 'wl-original-message-mode 'wl-message-exit)
460 (set-alist 'mime-view-over-to-next-method-alist
461 'wl-original-message-mode 'wl-message-exit)
462 (set-alist 'mime-preview-over-to-previous-method-alist
463 'wl-original-message-mode 'wl-message-exit)
464 (set-alist 'mime-preview-over-to-next-method-alist
465 'wl-original-message-mode 'wl-message-exit)
466 (add-hook 'wl-summary-redisplay-hook 'wl-message-delete-mime-out-buf)
467 (add-hook 'wl-message-exit-hook 'wl-message-delete-mime-out-buf)
469 (ctree-set-calist-strictly
470 'mime-preview-condition
471 '((type . text) (subtype . plain)
473 (body-presentation-method . wl-mime-display-text/plain)
474 (major-mode . wl-original-message-mode)))
476 (ctree-set-calist-strictly
477 'mime-acting-condition
478 '((type . message) (subtype . partial)
479 (method . wl-mime-combine-message/partial-pieces)
480 (request-partial-message-method . wl-message-request-partial)
481 (major-mode . wl-original-message-mode)))
483 (ctree-set-calist-strictly
484 'mime-acting-condition
485 '((type . application) (subtype . pgp-encrypted)
486 (method . wl-mime-decrypt-application/pgp-encrypted)
487 (major-mode . wl-original-message-mode)))
489 (ctree-set-calist-strictly
490 'mime-acting-condition
492 (major-mode . wl-original-message-mode)
493 (method . wl-mime-save-content)))
494 (set-alist 'mime-preview-following-method-alist
495 'wl-original-message-mode
496 (function wl-message-follow-current-entity))
497 (set-alist 'mime-view-following-method-alist
498 'wl-original-message-mode
499 (function wl-message-follow-current-entity))
500 (set-alist 'mime-edit-message-inserter-alist
501 'wl-draft-mode (function wl-draft-insert-current-message))
502 (set-alist 'mime-edit-mail-inserter-alist
503 'wl-draft-mode (function wl-draft-insert-get-message))
504 (set-alist 'mime-edit-split-message-sender-alist
506 (cdr (assq 'mail-mode mime-edit-split-message-sender-alist)))
507 (set-alist 'mime-raw-representation-type-alist
508 'wl-original-message-mode 'binary)
509 ;; Sort and highlight header fields.
510 (or wl-message-ignored-field-list
511 (setq wl-message-ignored-field-list
512 mime-view-ignored-field-list))
513 (or wl-message-visible-field-list
514 (setq wl-message-visible-field-list
515 mime-view-visible-field-list))
516 (set-alist 'mime-header-presentation-method-alist
517 'wl-original-message-mode
518 'wl-mime-display-header)
519 ;; To avoid overriding wl-draft-mode-map.
520 (when (boundp 'mime-setup-signature-key-alist)
521 (unless (assq 'wl-draft-mode mime-setup-signature-key-alist)
522 (setq mime-setup-signature-key-alist
523 (cons '(wl-draft-mode . "\C-c\C-w")
524 mime-setup-signature-key-alist)))))
527 (product-provide (provide 'wl-mime) (require 'wl-version))
529 ;;; wl-mime.el ends here