[elpa] externals/gnorb 62368b7 017/449: gnorb-gnus.el: Make attachment fiddling work in org capture

[Stefan Monnier]

branch: externals/gnorb
commit 62368b7f1e9fd0317cddbb860aa7aa9bb50e95fa
Author: Eric Abrahamsen <eric@ericabrahamsen.net>
Commit: Eric Abrahamsen <eric@ericabrahamsen.net>

    gnorb-gnus.el: Make attachment fiddling work in org capture
    
    Setting a :gnus-attachments t key on capture templates will copy
    attachments to the captured heading using org-attach.
---
 lisp/gnorb-gnus.el | 93 ++++++++++++++++++++++++++++++++++++++++++++----------
 1 file changed, 76 insertions(+), 17 deletions(-)

diff --git a/lisp/gnorb-gnus.el b/lisp/gnorb-gnus.el
index 46632b2..2839e46 100644
--- a/lisp/gnorb-gnus.el
+++ b/lisp/gnorb-gnus.el
@@ -34,6 +34,10 @@
 ;;; What follows is a very careful copy-pasta of bits and pieces from
 ;;; mm-decode.el and gnus-art.el. Voodoo was involved.
 
+(defvar gnorb-gnus-capture-attachments nil
+  "Holding place for attachment names during the capture
+  process.")
+
 (defun gnorb-gnus-article-org-attach (n)
   "Save MIME part N, which is the numerical prefix, of the
   article under point as an attachment to the specified org
@@ -52,26 +56,81 @@
 
 (defun gnorb-gnus-attach-part (handle &optional org-heading)
   "Attach HANDLE to an existing org heading."
-  (let ((filename (or (mail-content-type-get
-                       (mm-handle-disposition handle) 'filename)
-                      (mail-content-type-get
-                       (mm-handle-type handle) 'name)))
+  (let ((filename (gnorb-gnus-save-part handle))
        (org-heading (or org-heading
-                        (org-refile-get-location "Attach part to"))))
-    (require 'org-attach)
-    (when filename
-      (setq filename (gnus-map-function mm-file-name-rewrite-functions
-                                       (file-name-nondirectory filename))))
-    ;; Get a temp pathname inside `gnorb-tmp-dir', and save the
-    ;; attachment there
+                        (org-refile-get-location "Attach part to")))))
+  (require 'org-attach)
+  (save-window-excursion
+    (find-file (nth 1 org-heading))
+    (goto-char (nth 3 org-heading))
+    (org-attach-attach filename nil 'mv)))
+
+(defun gnorb-gnus-save-part (handle)
+  (let ((filename (or (mail-content-type-get
+                      (mm-handle-disposition handle) 'filename)
+                     (mail-content-type-get
+                      (mm-handle-type handle) 'name))))
+    (setq filename
+         (gnus-map-function mm-file-name-rewrite-functions
+                            (file-name-nondirectory filename)))
     (setq filename (expand-file-name filename gnorb-tmp-dir))
     (mm-save-part-to-file handle filename)
-    ;; then visit the headline in question...
-    (save-window-excursion
-      (find-file (nth 1 org-heading))
-      (goto-char (nth 3 org-heading))
-     ;; ...and actually attach the file, moving it out of the tmp dir
-     (org-attach-attach filename nil 'mv))))
+    filename))
+
+(defun gnorb-gnus-collect-all-attachments (&optional capture-p)
+  "Collect all the attachments from the message under point, and
+save them into `gnorb-tmp-dir'."
+  (save-excursion
+    (when capture-p
+      (set-buffer (org-capture-get :original-buffer)))
+    (unless (memq major-mode '(gnus-summary-mode gnus-article-mode))
+       (error "Only works in Gnus summary or article buffers"))
+    (let ((article (gnus-summary-article-number)) 
+         mime-handles)
+      (when (or (null gnus-current-article)
+               (null gnus-article-current)
+               (/= article (cdr gnus-article-current))
+               (not (equal (car gnus-article-current) gnus-newsgroup-name)))
+       (gnus-summary-display-article article))
+      (gnus-eval-in-buffer-window gnus-article-buffer
+       (setq mime-handles (cl-remove-if-not
+                           (lambda (h) (equal "attachment" (car (nth 5 h))))
+                           gnus-article-mime-handle-alist) ))
+      (when mime-handles
+       (dolist (h mime-handles)
+         (let ((filename
+                (gnorb-gnus-save-part (cdr h))))
+           (when capture-p
+             (push filename gnorb-gnus-capture-attachments))))))))
+
+;;; Make the above work in the capture process
+
+(defun gnorb-gnus-capture-attach ()
+  (when (and (org-capture-get :gnus-attachments)
+            (with-current-buffer
+                (org-capture-get :original-buffer)
+              (memq major-mode '(gnus-summary-mode gnus-article-mode))))
+    (require 'org-attach)
+    (setq gnorb-gnus-capture-attachments nil)
+    (gnorb-gnus-collect-all-attachments t)
+    (when gnorb-gnus-capture-attachments
+      (dolist (a gnorb-gnus-capture-attachments)
+       (org-attach-attach a nil 'mv)))))
+
+(add-hook 'org-capture-mode-hook 'gnorb-gnus-capture-attach)
+
+(defun gnorb-gnus-capture-abort-cleanup ()
+  (when (and org-note-abort
+            (org-capture-get :gnus-attachments))
+    (condition-case error
+       (progn (org-attach-delete-all)
+              (setq abort-note 'clean))
+      ((error
+       (setq abort-note 'dirty))))))
+
+(add-hook 'org-capture-prepare-finalize-hook
+         'gnorb-gnus-capture-abort-cleanup)
+
 
 ;;; Something is still slightly wrong about the following -- it
 ;;; doesn't provide "a" as a key on the button itself, which is what I