X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=wl%2Fwl-mime.el;h=540f87d14e742b4d70637a5ea5fac548a612a6c5;hb=acd82f4cf41e83cb2aab45ece9ff29842c6574b1;hp=bc53e0cd493192e10bc15aac996fdf04728c8ed3;hpb=11392a043e614513451adf170ac83899f81b787a;p=elisp%2Fwanderlust.git diff --git a/wl/wl-mime.el b/wl/wl-mime.el index bc53e0c..540f87d 100644 --- a/wl/wl-mime.el +++ b/wl/wl-mime.el @@ -33,11 +33,7 @@ (require 'mime-play) (require 'elmo) (require 'wl-vars) - -(eval-when-compile - (defalias-maybe 'pgg-decrypt-region 'ignore) - (defalias-maybe 'pgg-display-output-buffer 'ignore) - (defalias-maybe 'pgg-verify-region 'ignore)) +(eval-when-compile (require 'cl)) ;;; Draft @@ -390,11 +386,15 @@ It calls following-method selected from variable mime-view-ignored-field-list) (mime-view-mode nil nil nil inbuf outbuf))) -(defun wl-message-delete-mime-out-buf () - (let (mime-out-buf mime-out-win) - (if (setq mime-out-buf (get-buffer mime-echo-buffer-name)) - (if (setq mime-out-win (get-buffer-window mime-out-buf)) - (delete-window mime-out-win))))) +(defun wl-message-delete-popup-windows () + (dolist (buffer wl-message-popup-buffers) + (when (or (stringp buffer) + (and (symbolp buffer) + (boundp buffer) + (setq buffer (symbol-value buffer)))) + (let ((window (get-buffer-window buffer))) + (when window + (delete-window window)))))) (defun wl-message-request-partial (folder number) (elmo-set-work-buf @@ -450,7 +450,7 @@ It calls following-method selected from variable (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) + (insert-buffer-substring orig-buf) (delete-region header-start body-end) (goto-char header-start) (insert "Content-Type: text/plain; charset=US-ASCII\n") @@ -480,41 +480,154 @@ It calls following-method selected from variable (setq wl-message-buffer nil) (wl-summary-sync nil "update")))))) +;; PGP +(eval-when-compile + (defmacro wl-define-dummy-functions (&rest symbols) + `(dolist (symbol (quote ,symbols)) + (defalias symbol 'ignore))) + + (condition-case nil + (require 'epa) + (error + (wl-define-dummy-functions epg-make-context + epg-decrypt-string + epg-verify-string + epg-context-set-progress-callback + epg-context-result-for + epg-verify-result-to-string + epa-display-info))) + (condition-case nil + (require 'pgg) + (error + (wl-define-dummy-functions pgg-decrypt-region + pgg-verify-region + pgg-display-output-buffer)))) + +(defun wl-epg-progress-callback (context what char current total reporter) + (let ((label (elmo-progress-counter-label reporter))) + (when label + (elmo-progress-notify label :set current :total total)))) + +(defun wl-mime-pgp-decrypt-region-with-epg (beg end &optional no-decode) + (require 'epg) + (let ((context (epg-make-context))) + (elmo-with-progress-display (epg-decript nil reporter) + "Decrypting" + (epg-context-set-progress-callback context + (cons #'wl-epg-progress-callback + reporter)) + (insert (prog1 + (decode-coding-string + (epg-decrypt-string + context + (buffer-substring beg end)) + (if no-decode 'raw-text wl-cs-autoconv)) + (delete-region beg end))))) + last-coding-system-used) + +(defun wl-mime-pgp-verify-region-with-epg (beg end &optional coding-system) + (require 'epa) + (let ((context (epg-make-context))) + (elmo-with-progress-display (epg-verify nil reporter) + "Verifying" + (epg-context-set-progress-callback context + (cons #'wl-epg-progress-callback + reporter)) + (epg-verify-string + context + (encode-coding-string + (buffer-substring beg end) + (if coding-system + (coding-system-change-eol-conversion coding-system 'dos) + 'raw-text-dos)))) + (when (epg-context-result-for context 'verify) + (epa-display-info (epg-verify-result-to-string + (epg-context-result-for context 'verify)))))) + +(defun wl-mime-pgp-decrypt-region-with-pgg (beg end &optional no-decode) + (require 'pgg) + (let ((buffer-file-coding-system wl-cs-autoconv) + status) + (setq status (pgg-decrypt-region beg end)) + (if no-decode + (when status + (delete-region beg end) + (insert-buffer-substring pgg-output-buffer)) + (pgg-display-output-buffer beg end status)) + (unless status + (error "Decryption is failed")) + last-coding-system-used)) + +(defun wl-mime-pgp-verify-region-with-pgg (beg end &optional coding-system) + (require 'pgg) + (let ((message-buffer (current-buffer)) + success) + (with-temp-buffer + (insert-buffer-substring message-buffer beg end) + (when coding-system + (encode-coding-region (point-min) (point-max) coding-system)) + (setq success (pgg-verify-region (point-min) (point-max) nil 'fetch))) + (mime-show-echo-buffer) + (set-buffer mime-echo-buffer-name) + (set-window-start + (get-buffer-window mime-echo-buffer-name) + (point-max)) + (insert-buffer-substring + (if success + pgg-output-buffer + pgg-errors-buffer)))) + +(defsubst wl-mime-pgp-decrypt-region (beg end &optional no-decode) + (case wl-use-pgp-module + (epg + (wl-mime-pgp-decrypt-region-with-epg beg end no-decode)) + (pgg + (wl-mime-pgp-decrypt-region-with-pgg beg end no-decode)) + (t + (error "Don't support PGP decryption")))) + +(defsubst wl-mime-pgp-verify-region (beg end &optional coding-system) + (case wl-use-pgp-module + (epg + (wl-mime-pgp-verify-region-with-epg beg end coding-system)) + (pgg + (wl-mime-pgp-verify-region-with-pgg beg end coding-system)) + (t + (error "Don't support PGP decryption")))) + (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")))) + (let ((region (wl-find-region "^-+BEGIN PGP MESSAGE-+$" + "^-+END PGP MESSAGE-+$")) + (inhibit-read-only t) + coding-system) + (unless region + (error "Cannot find pgp encrypted region")) + (save-restriction + (let ((props (text-properties-at (car region)))) + (narrow-to-region (car region) (cdr region)) + (when (setq coding-system + (wl-mime-pgp-decrypt-region (point-min) (point-max))) + (setq props (plist-put props + 'wl-mime-decoded-coding-system + coding-system))) + (set-text-properties (point-min) (point-max) props)))))) (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 ((message-buffer (current-buffer)) - beg end coding-system success) - (setq end (and (or (re-search-forward "^-+END PGP SIGNATURE-+$" nil t) - (re-search-backward "^-+END PGP SIGNATURE-+$" nil t) - (error "Cannot find pgp signed region")) - (match-end 0))) - (setq beg (or (re-search-backward "^-+BEGIN PGP SIGNED MESSAGE-+$" nil t) - (error "Cannot find pgp signed region"))) + (let ((region (wl-find-region "^-+BEGIN PGP SIGNED MESSAGE-+$" + "^-+END PGP SIGNATURE-+$")) + coding-system) (setq coding-system - (or (let* ((situation (mime-preview-find-boundary-info)) + (or (get-text-property (car region) 'wl-mime-decoded-coding-system) + (let* ((situation (mime-preview-find-boundary-info)) (entity (aref situation 2))) (mime-charset-to-coding-system (mime-content-type-parameter @@ -525,21 +638,10 @@ With ARG, ask coding system and encode the region with it before verifying." (setq coding-system (read-coding-system (format "Coding system (%S): " coding-system) coding-system))) - (with-temp-buffer - (insert-buffer-substring message-buffer beg end) - (encode-coding-region (point-min) (point-max) coding-system) - (setq success (pgg-verify-region (point-min) (point-max) nil 'fetch))) - (mime-show-echo-buffer) - (set-buffer mime-echo-buffer-name) - (set-window-start - (get-buffer-window mime-echo-buffer-name) - (point-max)) - (insert-buffer-substring - (if success pgg-output-buffer pgg-errors-buffer))))) + (wl-mime-pgp-verify-region (car region) (cdr region) coding-system)))) ;; 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) @@ -553,9 +655,7 @@ With ARG, ask coding system and encode the region with it before verifying." (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) + (wl-mime-pgp-decrypt-region (point-min) (point-max) 'no-decode) (setq representation-type 'elmo-buffer)) (setq child-entity (mime-parse-message (mm-expand-class-name representation-type) @@ -597,6 +697,7 @@ With ARG, ask coding system and encode the region with it before verifying." (setq entity (car (mime-entity-children message-entity))) (with-temp-buffer + (set-buffer-multibyte nil) (insert (mime-entity-body message-entity)) (elmo-folder-append-buffer target)))) number)) @@ -657,6 +758,44 @@ With ARG, ask destination folder." (setq wl-mime-save-directory (file-name-directory filename)) (mime-write-entity-content entity filename)))) +(defun wl-summary-extract-attachments-1 (message-entity directory number) + ;; returns new number. + (let (children filename) + (cond + ((setq children (mime-entity-children message-entity)) + (dolist (entity children) + (setq number + (wl-summary-extract-attachments-1 entity directory number)))) + ((and (eq (mime-content-disposition-type + (mime-entity-content-disposition message-entity)) + 'attachment) + (setq filename (mime-entity-safe-filename message-entity))) + (let ((full (expand-file-name filename directory))) + (when (or (not (file-exists-p full)) + (yes-or-no-p + (format "File %s exists. Save anyway? " filename))) + (message "Extracting...%s" (setq number (+ 1 number))) + (mime-write-entity-content message-entity full))))) + number)) + +(defun wl-summary-extract-attachments (directory) + "Extract attachment parts in MIME format into the DIRECTORY." + (interactive + (let* ((default (or wl-mime-save-directory + wl-temporary-file-directory)) + (directory (read-directory-name "Extract to " default default t))) + (list (if (> (length directory) 0) directory default)))) + (unless (and (file-writable-p directory) + (file-directory-p directory)) + (error "%s is not writable" directory)) + (save-excursion + (wl-summary-set-message-buffer-or-redisplay) + (let ((entity (get-text-property (point-min) 'mime-view-entity))) + (when entity + (message "Extracting...") + (wl-summary-extract-attachments-1 entity directory 0) + (message "Extracting...done"))))) + ;;; Yet another combine method. (defun wl-mime-combine-message/partial-pieces (entity situation) "Internal method for wl to combine message/partial messages automatically." @@ -679,11 +818,11 @@ With ARG, ask destination folder." (with-current-buffer mother (mime-store-message/partial-piece entity situation) (setq wl-message-buffer-cur-summary-buffer summary-buf) - (make-variable-buffer-local 'mime-preview-over-to-next-method-alist) + (make-local-variable 'mime-preview-over-to-next-method-alist) (setq mime-preview-over-to-next-method-alist (cons (cons 'mime-show-message-mode 'wl-message-exit) mime-preview-over-to-next-method-alist)) - (make-variable-buffer-local 'mime-preview-over-to-previous-method-alist) + (make-local-variable 'mime-preview-over-to-previous-method-alist) (setq mime-preview-over-to-previous-method-alist (cons (cons 'mime-show-message-mode 'wl-message-exit) mime-preview-over-to-previous-method-alist))) @@ -727,6 +866,8 @@ With ARG, ask destination folder." (elmo-message-visible-field-list wl-message-visible-field-list) (elmo-message-sorted-field-list wl-message-sort-field-list)) (elmo-mime-insert-header entity situation) + (goto-char (point-min)) + (delete-matching-lines "^$") (wl-highlight-headers))) (defun wl-mime-decrypt-application/pgp-encrypted (entity situation) @@ -749,8 +890,9 @@ With ARG, ask destination folder." 'wl-original-message-mode 'wl-message-exit) (set-alist 'mime-preview-over-to-next-method-alist 'wl-original-message-mode 'wl-message-exit) - (add-hook 'wl-summary-redisplay-hook 'wl-message-delete-mime-out-buf) - (add-hook 'wl-message-exit-hook 'wl-message-delete-mime-out-buf) + (add-hook 'wl-summary-toggle-disp-off-hook 'wl-message-delete-popup-windows) + (add-hook 'wl-summary-redisplay-hook 'wl-message-delete-popup-windows) + (add-hook 'wl-message-exit-hook 'wl-message-delete-popup-windows) (ctree-set-calist-strictly 'mime-preview-condition