X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=wl%2Fwl-mime.el;h=37afaf2cec768e39d3081d3ad4052e2bb3fa23e6;hb=1860db905101ddc8f1d960e0cfc0554d0dc41411;hp=ff97691d3f149894cb36a310cd63be4471c7abc9;hpb=5f8df269dd48534955d4dd2ddd7e1f7902011d23;p=elisp%2Fwanderlust.git diff --git a/wl/wl-mime.el b/wl/wl-mime.el index ff97691..37afaf2 100644 --- a/wl/wl-mime.el +++ b/wl/wl-mime.el @@ -1,4 +1,4 @@ -;;; wl-mime.el -- SEMI implementations of MIME processing on Wanderlust. +;;; wl-mime.el --- SEMI implementations of MIME processing on Wanderlust. ;; Copyright (C) 1998,1999,2000 Yuuichi Teranishi @@ -24,10 +24,10 @@ ;; ;;; Commentary: -;; +;; ;;; Code: -;; +;; (require 'mime-view) (require 'mime-edit) @@ -35,12 +35,9 @@ (require 'elmo) (eval-when-compile - (defalias-maybe 'Meadow-version 'ignore)) - -(defvar xemacs-betaname) -(defvar xemacs-codename) -(defvar enable-multibyte-characters) -(defvar mule-version) + (defalias-maybe 'pgg-decrypt-region 'ignore) + (defalias-maybe 'pgg-display-output-buffer 'ignore) + (defalias-maybe 'pgg-verify-region 'ignore)) ;;; Draft @@ -51,7 +48,11 @@ (defun wl-draft-yank-current-message-entity () "Yank currently displayed message entity. -By setting following-method as yank-content." +By setting following-method as yank-content. + +If region is active, yank region contents instead. \(this feature is available +if and only if `transient-mark-mode' \(GNU Emacs\) or `zmacs-regions' \(XEmacs\) +has Non-nil value\)" (let ((wl-draft-buffer (current-buffer)) (mime-view-following-method-alist (list (cons 'wl-original-message-mode @@ -61,26 +62,108 @@ By setting following-method as yank-content." (function wl-draft-yank-to-draft-buffer))))) (if (get-buffer (wl-current-message-buffer)) (save-excursion + (set-buffer (wl-current-message-buffer)) (save-restriction - (set-buffer (wl-current-message-buffer)) (widen) - (mime-preview-follow-current-entity)))))) + (if (wl-region-exists-p) + (wl-mime-preview-follow-current-region) + (mime-preview-follow-current-entity))))))) + +;; modified mime-preview-follow-current-entity from mime-view.el +(defun wl-mime-preview-follow-current-region () + "Write follow message to current region. +It calls following-method selected from variable +`mime-preview-following-method-alist'." + (interactive) + (let ((r-beg (region-beginning)) + (r-end (region-end)) + (entity (get-text-property (point-min) + 'mime-view-entity))) + (let* ((mode (mime-preview-original-major-mode 'recursive)) + (new-name + (format "%s-active-region" (buffer-name))) + new-buf + (the-buf (current-buffer)) + fields) + (save-excursion + (set-buffer (setq new-buf (get-buffer-create new-name))) + (erase-buffer) + (insert ?\n) + (insert-buffer-substring the-buf r-beg r-end) + (goto-char (point-min)) + (let ((current-entity + (if (and (eq (mime-entity-media-type entity) 'message) + (eq (mime-entity-media-subtype entity) 'rfc822)) + (car (mime-entity-children entity)) + entity))) + (while (and current-entity + (if (and (eq (mime-entity-media-type + current-entity) 'message) + (eq (mime-entity-media-subtype + current-entity) 'rfc822)) + nil + (mime-insert-header current-entity fields) + t)) + (setq fields (std11-collect-field-names) + current-entity (mime-entity-parent current-entity)) + )) + (let ((rest mime-view-following-required-fields-list) + field-name ret) + (while rest + (setq field-name (car rest)) + (or (std11-field-body field-name) + (progn + (save-excursion + (set-buffer the-buf) + (let ((entity (when mime-mother-buffer + (set-buffer mime-mother-buffer) + (get-text-property (point) + 'mime-view-entity)))) + (while (and entity + (null (setq ret (mime-entity-fetch-field + entity field-name)))) + (setq entity (mime-entity-parent entity))))) + (if ret + (insert (concat field-name ": " ret "\n")) + ))) + (setq rest (cdr rest)) + )) + ) + (let ((f (cdr (assq mode mime-preview-following-method-alist)))) + (if (functionp f) + (funcall f new-buf) + (message + (format + "Sorry, following method for %s is not implemented yet." + mode)) + )) + ))) (defalias 'wl-draft-enclose-digest-region 'mime-edit-enclose-digest-region) (defun wl-draft-preview-message () - "" + "Preview editing message." (interactive) (let* (recipients-message + (current-point (point)) (config-exec-flag wl-draft-config-exec-flag) + (parent-folder wl-draft-parent-folder) (mime-display-header-hook 'wl-highlight-headers) + (mime-header-encode-method-alist + (append + '((wl-draft-eword-encode-address-list + . (To Cc Bcc Resent-To Resent-Cc Resent-Bcc From))) + (if (boundp 'mime-header-encode-method-alist) + (symbol-value 'mime-header-encode-method-alist)))) mime-view-ignored-field-list ; all header. (mime-edit-translate-buffer-hook (append (list (function (lambda () - (let ((wl-draft-config-exec-flag config-exec-flag)) + (let ((wl-draft-config-exec-flag config-exec-flag) + (wl-draft-parent-folder parent-folder)) + (goto-char current-point) (run-hooks 'wl-draft-send-hook) (setq recipients-message (condition-case err @@ -140,22 +223,192 @@ By setting following-method as yank-content." (defun wl-message-request-partial (folder number) (elmo-set-work-buf (elmo-message-fetch (wl-folder-get-elmo-folder folder) - number + number (elmo-make-fetch-strategy 'entire) nil (current-buffer) 'unread) (mime-parse-buffer nil))) -(defalias 'wl-message-read 'mime-preview-scroll-up-entity) -(defalias 'wl-message-next-content 'mime-preview-move-to-next) -(defalias 'wl-message-prev-content 'mime-preview-move-to-previous) -(defalias 'wl-message-play-content 'mime-preview-play-current-entity) -(defalias 'wl-message-extract-content 'mime-preview-extract-current-entity) -(defalias 'wl-message-quit 'mime-preview-quit) +(defalias 'wl-message-read 'mime-preview-scroll-up-entity) +(defalias 'wl-message-next-content 'mime-preview-move-to-next) +(defalias 'wl-message-prev-content 'mime-preview-move-to-previous) +(defalias 'wl-message-play-content 'mime-preview-play-current-entity) +(defalias 'wl-message-extract-content 'mime-preview-extract-current-entity) +(defalias 'wl-message-quit 'mime-preview-quit) (defalias 'wl-message-button-dispatcher-internal 'mime-button-dispatcher) +(defsubst wl-mime-node-id-to-string (node-id) + (if (consp node-id) + (mapconcat (function (lambda (num) (format "%s" (1+ num)))) + (reverse node-id) + ".") + "0")) + +(defun wl-message-delete-current-part () + "Delete a part under the cursor from the multipart message." + (interactive) + (save-restriction + (widen) + (let* ((entity (get-text-property (point) 'mime-view-entity)) + (node-id (mime-entity-node-id entity)) + (header-start (mime-buffer-entity-header-start-internal entity)) + (body-end (mime-buffer-entity-body-end-internal entity)) + (folder (wl-folder-get-elmo-folder wl-message-buffer-cur-folder)) + (number wl-message-buffer-cur-number) + (msgid (elmo-message-field folder number 'message-id)) + (orig-buf wl-message-buffer-original-buffer)) + (if (eq (luna-class-name entity) 'mime-elmo-imap-entity) + (error "Please fetch the entire message (by typing 'C-u .') and try again")) + (with-current-buffer orig-buf + (unless (string-equal + (buffer-string) + (elmo-message-fetch folder number + (elmo-make-fetch-strategy 'entire))) + (error "Buffer content differs from actual message"))) + (when (and (elmo-folder-writable-p folder) + (buffer-live-p orig-buf) + node-id + (yes-or-no-p + (format "Do you really want to delete part %s? " + (wl-mime-node-id-to-string node-id)))) + (when (with-temp-buffer + (insert-buffer orig-buf) + (delete-region header-start body-end) + (goto-char header-start) + (insert "Content-Type: text/plain; charset=US-ASCII\n\n") + (insert "** This part has been removed by Wanderlust **\n\n") + (elmo-folder-append-buffer folder t)) + + (elmo-folder-move-messages + folder (list number) + (wl-folder-get-elmo-folder wl-trash-folder)) + (when (and (elmo-cache-get-path msgid) + (file-exists-p (elmo-cache-get-path msgid))) + (delete-file (elmo-cache-get-path msgid))) + + (mime-preview-quit) + (wl-summary-delete-messages-on-buffer (list number)) + (wl-summary-toggle-disp-msg 'off) + (setq wl-message-buffer nil) + (wl-summary-sync nil "update")))))) + +(defun wl-message-decrypt-pgp-nonmime () + "Decrypt PGP encrypted region" + (interactive) + (require 'pgg) + (save-excursion + (beginning-of-line) + (if (or (re-search-forward "^-+END PGP MESSAGE-+$" nil t) + (re-search-backward "^-+END PGP MESSAGE-+$" nil t)) + (let (beg end status) + (setq end (match-end 0)) + (if (setq beg (re-search-backward "^-+BEGIN PGP MESSAGE-+$" nil t)) + (let ((inhibit-read-only t) + (buffer-file-coding-system wl-cs-autoconv)) + (setq status (pgg-decrypt-region beg end)) + (pgg-display-output-buffer beg end status)) + (message "Cannot find pgp encrypted region"))) + (message "Cannot find pgp encrypted region")))) + +(defun wl-message-verify-pgp-nonmime (&optional arg) + "Verify PGP signed region. +With ARG, ask coding system and encode the region with it before verifying." + (interactive "P") + (require 'pgg) + (save-excursion + (beginning-of-line) + (let ((msg-buf (current-buffer)) + beg end status m-beg) + (if (and (when (or (re-search-forward "^-+END PGP SIGNATURE-+$" nil t) + (re-search-backward "^-+END PGP SIGNATURE-+$" nil t)) + (setq end (match-end 0))) + (setq beg (re-search-backward "^-+BEGIN PGP SIGNED MESSAGE-+$" nil t))) + (progn + (if arg + (with-temp-buffer + (insert-buffer-substring msg-buf beg end) + (set-mark (point-min)) + (goto-char (point-max)) + (call-interactively 'encode-coding-region) + (setq status (pgg-verify-region (point-min) (point-max) nil 'fetch))) + (let* ((situation (mime-preview-find-boundary-info)) + (p-end (aref situation 1)) + (entity (aref situation 2)) + (count 0)) + (goto-char p-end) + (while (< beg (point)) + (if (re-search-backward "^-+BEGIN PGP SIGNED MESSAGE-+$" nil t) + (setq count (+ count 1)) + (debug))) + (with-temp-buffer + (insert (mime-entity-body entity)) + (goto-char (point-max)) + (while (> count 0) + (if (re-search-backward "^-+BEGIN PGP SIGNED MESSAGE-+$" nil t) + (setq count (- count 1)) + (debug))) + (let ((r-beg (point)) + (r-end (re-search-forward "^-+END PGP SIGNATURE-+$" nil t))) + (if r-end + (setq status (pgg-verify-region r-beg r-end nil 'fetch)) + (debug)))))) + (mime-show-echo-buffer) + (set-buffer mime-echo-buffer-name) + (set-window-start + (get-buffer-window mime-echo-buffer-name) + (point-max)) + (setq m-beg (point)) + (insert-buffer-substring + (if status pgg-output-buffer pgg-errors-buffer)) + (encode-coding-region m-beg (point) buffer-file-coding-system) + (decode-coding-region m-beg (point) wl-cs-autoconv)) + (message "Cannot find pgp signed region"))))) + +;; XXX: encrypted multipart isn't represented as multipart +(defun wl-mime-preview-application/pgp (parent-entity entity situation) + (require 'pgg) + (goto-char (point-max)) + (let ((p (point)) + raw-buf to-buf representation-type child-entity) + (goto-char p) + (save-restriction + (narrow-to-region p p) + (setq to-buf (current-buffer)) + (with-temp-buffer + (setq raw-buf (current-buffer)) + (mime-insert-entity entity) + (when (progn + (goto-char (point-min)) + (re-search-forward "^-+BEGIN PGP MESSAGE-+$" nil t)) + (pgg-decrypt-region (point-min)(point-max)) + (delete-region (point-min) (point-max)) + (insert-buffer pgg-output-buffer) + (setq representation-type 'elmo-buffer)) + (setq child-entity (mime-parse-message + (mm-expand-class-name representation-type) + nil + parent-entity + (mime-entity-node-id-internal parent-entity))) + (mime-display-entity + child-entity + nil + `((header . visible) + (body . visible) + (entity-button . invisible)) + to-buf))))) + +(defun wl-mime-preview-application/pgp-encrypted (entity situation) + (let* ((entity-node-id (mime-entity-node-id entity)) + (mother (mime-entity-parent entity)) + (knum (car entity-node-id)) + (onum (if (> knum 0) + (1- knum) + (1+ knum))) + (orig-entity (nth onum (mime-entity-children mother)))) + (wl-mime-preview-application/pgp entity orig-entity situation))) + ;;; Summary (defun wl-summary-burst-subr (message-entity target number) ;; returns new number. @@ -169,7 +422,7 @@ By setting following-method as yank-content." number)))) ((and (eq (cdr (assq 'type content-type)) 'message) (eq (cdr (assq 'subtype content-type)) 'rfc822)) - (message (format "Bursting...%s" (setq number (+ 1 number)))) + (message "Bursting...%s" (setq number (+ 1 number))) (setq entity (car (mime-entity-children message-entity))) (with-temp-buffer @@ -179,17 +432,18 @@ By setting following-method as yank-content." (mime-entity-fetch-field entity "Message-ID"))))) number)) -(defun wl-summary-burst () - "" - (interactive) +(defun wl-summary-burst (&optional arg) + "De-capsulate embedded messages in MIME format. +With ARG, ask destination folder." + (interactive "P") (let ((raw-buf (wl-summary-get-original-buffer)) (view-buf wl-message-buffer) - children message-entity content-type target) + children message-entity content-type target-name target) (save-excursion (setq target wl-summary-buffer-elmo-folder) - (while (not (elmo-folder-writable-p target)) - (setq target - (wl-summary-read-folder wl-default-folder "to extract to"))) + (when (or arg (not (elmo-folder-writable-p target))) + (setq target-name (wl-summary-read-folder wl-default-folder "to extract to")) + (setq target (wl-folder-get-elmo-folder target-name))) (wl-summary-set-message-buffer-or-redisplay) (with-current-buffer view-buf (setq message-entity (get-text-property (point-min) 'mime-view-entity))) @@ -200,26 +454,29 @@ By setting following-method as yank-content." (message "Bursting...done")) (if (elmo-folder-plugged-p target) (elmo-folder-check target))) - (wl-summary-sync-update))) + (when (or (not target-name) + (string= wl-summary-buffer-folder-name target-name)) + (save-excursion (wl-summary-sync-update))))) ;; internal variable. -(defvar wl-mime-save-dir nil "Last saved directory.") +(defvar wl-mime-save-directory nil "Last saved directory.") ;;; Yet another save method. (defun wl-mime-save-content (entity situation) (let ((filename (read-file-name "Save to file: " (expand-file-name (or (mime-entity-safe-filename entity) ".") - (or wl-mime-save-dir - wl-tmp-dir))))) + (or wl-mime-save-directory + wl-temporary-file-directory))))) (while (file-directory-p filename) (setq filename (read-file-name "Please set filename (not directory): " filename))) - (if (file-exists-p filename) - (or (yes-or-no-p (format "File %s exists. Save anyway? " filename)) - (error "Not saved"))) - (setq wl-mime-save-dir (file-name-directory filename)) - (mime-write-entity-content entity filename))) + (if (and (file-exists-p filename) + (not (yes-or-no-p (format "File %s exists. Save anyway? " + filename)))) + (message "Not saved") + (setq wl-mime-save-directory (file-name-directory filename)) + (mime-write-entity-content entity filename)))) ;;; Yet another combine method. (defun wl-mime-combine-message/partial-pieces (entity situation) @@ -298,6 +555,14 @@ By setting following-method as yank-content." (elmo-mime-insert-header entity situation) (wl-highlight-headers))) +(defun wl-mime-decrypt-application/pgp-encrypted (entity situation) + (let ((summary-buffer wl-message-buffer-cur-summary-buffer) + (original-buffer wl-message-buffer-original-buffer)) + (mime-decrypt-application/pgp-encrypted entity situation) + (setq wl-message-buffer-cur-summary-buffer summary-buffer) + (setq wl-message-buffer-original-buffer original-buffer))) + + ;;; Setup methods. (defun wl-mime-setup () (set-alist 'mime-preview-quitting-method-alist @@ -321,6 +586,14 @@ By setting following-method as yank-content." (major-mode . wl-original-message-mode))) (ctree-set-calist-strictly + 'mime-preview-condition + '((type . application)(subtype . pgp-encrypted) + (encoding . t) + (body . invisible) + (body-presentation-method . wl-mime-preview-application/pgp-encrypted) + (major-mode . wl-original-message-mode))) + + (ctree-set-calist-strictly 'mime-acting-condition '((type . message) (subtype . partial) (method . wl-mime-combine-message/partial-pieces) @@ -329,6 +602,12 @@ By setting following-method as yank-content." (ctree-set-calist-strictly 'mime-acting-condition + '((type . application) (subtype . pgp-encrypted) + (method . wl-mime-decrypt-application/pgp-encrypted) + (major-mode . wl-original-message-mode))) + + (ctree-set-calist-strictly + 'mime-acting-condition '((mode . "extract") (major-mode . wl-original-message-mode) (method . wl-mime-save-content)))