org-attach: Attach files specified in a dired buffer.

* lisp/org-attach.el (org-attach-attach-files): New.
(org-attach-dired-marked-files-in-dired): New
(org-attach-dired-marked-files-or-file-at-cursor-in-dired): New.
(org-attach-dired-attach-to-next-best-subtree): New command.
(org-attach-dired-attach-to-next-best-subtree-cp): New command.
(org-attach-dired-attach-to-next-best-subtree-mv): New command.
(org-attach-dired-attach-to-next-best-subtree-ln): New command.
(org-attach-dired-attach-to-next-best-subtree-lns): New command.
* testing/lisp/test-org-attach.el: Tests.

lisp/org-attach.el

@@ -577,6 +577,86 @@ This function is called by `org-archive-hook'.  The option
 	  org-attach-archive-delete)
     (org-attach-delete-all t)))
 
+
+;; Attach from dired.
+
+;; Suggestion to activate shortcuts for dired.  Add the following
+;; lines to the emacs config file.
+
+;; (add-hook
+;;  'dired-mode-hook
+;;  (lambda ()
+;;    (define-key dired-mode-map (kbd "C-c C-x a") #'org-attach-dired-attach-to-next-best-subtree)
+;;    (define-key dired-mode-map (kbd "C-c C-x c") #'org-attach-dired-attach-to-next-best-subtree-cp)
+;;    (define-key dired-mode-map (kbd "C-c C-x m") #'org-attach-dired-attach-to-next-best-subtree-mv)
+;;    (define-key dired-mode-map (kbd "C-c C-x l") #'org-attach-dired-attach-to-next-best-subtree-ln)
+;;    (define-key dired-mode-map (kbd "C-c C-x s") #'org-attach-dired-attach-to-next-best-subtree-lns)))
+
+(defun org-attach-attach-files (files &optional method)
+  "Move/copy/link FILES into the attachment directory of the current task.
+METHOD may be `cp', `mv', `ln', `lns' or `url' default taken from
+`org-attach-method'."
+  (setq method (or method org-attach-method))
+  (mapc (lambda (file) (org-attach-attach file nil method)) files))
+
+(defun org-attach-dired-marked-files-in-dired ()
+  "Return list of marked files in dired."
+  (cl-assert (eq 'dired-mode major-mode))
+  (delq nil
+        (mapcar
+         (lambda (f) (if (file-directory-p f) nil f)) ;; don't attach directories
+	 (nreverse (dired-map-over-marks (dired-get-filename) nil)))))
+
+(defun org-attach-dired-marked-files-or-file-at-cursor-in-dired ()
+  "Return list of marked files in dired or file at cursor as one
+element list.  Else return nil."
+  (cl-assert (eq 'dired-mode major-mode))
+  (or (org-attach-dired-marked-files-in-dired)
+      (list (dired-get-filename 'no-dir t))))
+
+(defun org-attach-dired-attach-to-next-best-subtree (files)
+  "Attach FILES marked or current file in dired to subtree in other window.
+Precondition: Point must be in a dired buffer.
+Idea taken from `gnus-dired-attach'."
+  (interactive
+   (list (org-attach-dired-marked-files-or-file-at-cursor-in-dired)))
+  (unless (eq major-mode 'dired-mode)
+    (user-error "This command must be triggered in a dired buffer."))
+  (let ((start-win (selected-window))
+        (other-win
+         (get-window-with-predicate
+          (lambda (window)
+            (with-current-buffer (window-buffer window)
+              (eq major-mode 'org-mode))))))
+    (unless other-win
+      (user-error
+       "Can't attach to subtree.  There is no window in Org-mode"))
+    (select-window other-win)
+    (org-attach-attach-files files)
+    (select-window start-win)))
+
+(defun org-attach-dired-attach-to-next-best-subtree-cp ()
+  (interactive)
+  (let ((org-attach-method 'cp))
+    (call-interactively #'org-attach-dired-attach-to-next-best-subtree)))
+
+(defun org-attach-dired-attach-to-next-best-subtree-mv ()
+  (interactive)
+  (let ((org-attach-method 'mv))
+    (call-interactively #'org-attach-dired-attach-to-next-best-subtree)))
+
+(defun org-attach-dired-attach-to-next-best-subtree-ln ()
+  (interactive)
+  (let ((org-attach-method 'ln))
+    (call-interactively #'org-attach-dired-attach-to-next-best-subtree)))
+
+(defun org-attach-dired-attach-to-next-best-subtree-lns ()
+  (interactive)
+  (let ((org-attach-method 'lns))
+    (call-interactively #'org-attach-dired-attach-to-next-best-subtree)))
+
+
+
 (add-hook 'org-archive-hook 'org-attach-archive-delete-maybe)
 
 (provide 'org-attach)

testing/lisp/test-org-attach.el

@@ -0,0 +1,129 @@
+;;; test-org-attach.el --- tests for org-attach.el      -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2017
+
+;; Author: Marco Wahl
+;; Keywords: internal
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;
+
+;;; Code:
+
+(require 'org-attach)
+
+(defun touch (filename)
+  "Make sure FILENAME exists."
+  (find-file filename)
+  (save-buffer)
+  (kill-buffer))
+
+(ert-deftest test-org-attach/dired-attach-to-next-best-subtree/1 ()
+  "Attach file at point in dired to subtree."
+
+  ;; prepare
+  (let* ((tmpdir (make-temp-file "test-org-attach_" t "/"))
+	 (orgfilename (concat tmpdir "attach.org"))
+	 (a-filename (concat tmpdir "a")))
+    (touch a-filename)
+    (dired tmpdir)
+    (delete-other-windows)
+    (find-file-other-window orgfilename)
+    (erase-buffer)
+    (org-mode)
+    (insert "* foo   :foo:")
+    (other-window 1)
+    (assert (eq 'dired-mode major-mode))
+    (dired-goto-file a-filename)
+
+    ;;action
+    (call-interactively #'org-attach-dired-attach-to-next-best-subtree)
+    (find-file-other-window orgfilename)
+    (beginning-of-buffer)
+    (search-forward "* foo")
+
+    ;; expectation.  tag ATTACH has been appended.
+    (should
+     (reduce (lambda (x y) (or x y))
+             (mapcar (lambda (x) (string-equal "ATTACH" x))
+                     (plist-get
+                      (plist-get
+                       (org-element-at-point) 'headline) :tags))))
+
+    ;; cleanup
+    (delete-directory tmpdir 'recursive)))
+
+
+;; Use a test core several times.
+(defmacro standard-core-test-org-attach/dired-attach-function-for-method (fun)
+  "Create test core for FUN.  Attach two marked files."
+  `(let* ((tmpdir (make-temp-file "test-org-attach_" t "/"))
+	 (orgfilename (concat tmpdir "attach.org"))
+	 (a-filename (concat tmpdir "a"))
+	 (b-filename (concat tmpdir "b")))
+    (touch a-filename)
+    (touch b-filename)
+    (dired tmpdir)
+    (delete-other-windows)
+    (find-file-other-window orgfilename)
+    (org-mode)
+    (insert "* foo   :foo:")
+    (other-window 1)
+    (assert (eq 'dired-mode major-mode))
+    (dired-goto-file a-filename)
+    (dired-mark 1)
+    (dired-goto-file b-filename)
+    (dired-mark 1)
+
+    ;; action
+    (call-interactively #',fun)
+    (find-file-other-window orgfilename)
+    (beginning-of-buffer)
+    (search-forward "* foo")
+
+    ;; check
+    (should
+     (and (file-exists-p (concat (org-attach-dir) "/" "a"))
+          (file-exists-p (concat (org-attach-dir) "/" "b"))))
+
+    ;; cleanup
+    (delete-directory tmpdir 'recursive)))
+
+(ert-deftest test-org-attach/dired-attach-to-next-best-subtree/2 ()
+  "Attach two marked."
+  (standard-core-test-org-attach/dired-attach-function-for-method
+   org-attach-dired-attach-to-next-best-subtree))
+
+(ert-deftest test-org-attach/dired-attach-to-next-best-subtree-cp ()
+  (standard-core-test-org-attach/dired-attach-function-for-method
+   org-attach-dired-attach-to-next-best-subtree-cp))
+
+(ert-deftest test-org-attach/dired-attach-to-next-best-subtree-mv ()
+  (standard-core-test-org-attach/dired-attach-function-for-method
+   org-attach-dired-attach-to-next-best-subtree-mv))
+
+(ert-deftest test-org-attach/dired-attach-to-next-best-subtree-ln ()
+  (standard-core-test-org-attach/dired-attach-function-for-method
+   org-attach-dired-attach-to-next-best-subtree-mv))
+
+(ert-deftest test-org-attach/dired-attach-to-next-best-subtree-lns ()
+  (standard-core-test-org-attach/dired-attach-function-for-method
+   org-attach-dired-attach-to-next-best-subtree-lns))
+
+
+(provide 'test-org-attach)
+;;; test-org-attach.el ends here