mirrors
/
org-mode
mirror of https://git.savannah.gnu.org/git/emacs/org-mode.git
0
0
Fork 1
Code Releases Activity

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.
This commit is contained in:
Marco Wahl 2017-11-15 11:25:51 +01:00
parent c029c4d45d
commit 615b147031
2 changed files with 209 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

80
lisp/org-attach.el
View File

@ -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)

129
testing/lisp/test-org-attach.el Normal file
View File

@ -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