From mboxrd@z Thu Jan 1 00:00:00 1970 From: Erik Hetzner Subject: [PATCH] org-attach.el: Get attachments from git annex Date: Sun, 24 Jan 2016 20:34:20 -0800 Message-ID: <56b2c213.08e5420a.3d619.ffffd033@mx.google.com> References: <568b532e.d111620a.b25a8.ffffbb7c@mx.google.com> <87poxg8s22.fsf@kyleam.com> <568c6aaa.c345620a.7f4da.6359@mx.google.com> <56a5b193.ca77420a.1551e.667c@mx.google.com> <87lh7dz79f.fsf@gmx.us> <56a70513.6861420a.33633.5843@mx.google.com> <87egd4u6tq.fsf@kyleam.com> <56a7a139.885d620a.6b777.576d@mx.google.com> <87io2gb5xh.fsf@kyleam.com> <87oac8hu9p.fsf@gmx.us> <56a87251.0e2a620a.4811f.fffff1c6@mx.google.com> <87lh79t04p.fsf@kyleam.com> Reply-To: Erik Hetzner Mime-Version: 1.0 (generated by SEMI-EPG 1.14.7 - "Harue") Content-Type: text/plain; charset=US-ASCII Return-path: Received: from eggs.gnu.org ([2001:4830:134:3::10]:38895) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1aRANO-0000fO-7m for emacs-orgmode@gnu.org; Wed, 03 Feb 2016 22:14:36 -0500 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1aRANK-0000Df-4O for emacs-orgmode@gnu.org; Wed, 03 Feb 2016 22:14:34 -0500 Received: from mail-pf0-x22c.google.com ([2607:f8b0:400e:c00::22c]:36303) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1aRANJ-0000DY-PW for emacs-orgmode@gnu.org; Wed, 03 Feb 2016 22:14:30 -0500 Received: by mail-pf0-x22c.google.com with SMTP id n128so28299026pfn.3 for ; Wed, 03 Feb 2016 19:14:29 -0800 (PST) In-Reply-To: <87lh79t04p.fsf@kyleam.com> List-Id: "General discussions about Org-mode." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: emacs-orgmode-bounces+geo-emacs-orgmode=m.gmane.org@gnu.org Sender: emacs-orgmode-bounces+geo-emacs-orgmode=m.gmane.org@gnu.org To: Kyle Meyer Cc: emacs-orgmode@gnu.org, Rasmus From: Erik Hetzner * org-attach.el (org-attach-use-annex): New function to check if git annex should be used. (org-attach-annex-get-maybe): New function to get a file from git annex if necessary. (org-attach-annex-auto-get): New defcustom to determine behavior of org-attach-annex-get-maybe. (org-attach-open): Automatically get attached files from git annex when opening if necessary. * testing/lisp/test-org-annex.el: New file for testing org-attach. Only contains code for testing org-attach with git annex at the moment. * mk/targets.mk: Fix cleantest target so it can delete git annex repos. --- lisp/org-attach.el | 69 ++++++++++++++++++++++------- mk/targets.mk | 2 + testing/lisp/test-org-attach.el | 97 +++++++++++++++++++++++++++++++++++++++++ 3 files changed, 152 insertions(+), 16 deletions(-) create mode 100644 testing/lisp/test-org-attach.el diff --git a/lisp/org-attach.el b/lisp/org-attach.el index e6ad4b1..15d4841 100644 --- a/lisp/org-attach.el +++ b/lisp/org-attach.el @@ -131,6 +131,17 @@ When set to `query', ask the user instead." (const :tag "Always delete attachments" t) (const :tag "Query the user" query))) +(defcustom org-attach-annex-auto-get 'ask + "Confirmation preference for automatically getting annex files. +If \\='ask, prompt using `y-or-n-p'. If t, always get. If nil, never get." + :group 'org-attach + :package-version '(Org . "9") + :version "25.1" + :type '(choice + (const :tag "confirm with `y-or-n-p'" ask) + (const :tag "always get from annex if necessary" t) + (const :tag "never get from annex" nil))) + ;;;###autoload (defun org-attach () "The dispatcher for attachment commands. @@ -270,29 +281,53 @@ the ATTACH_DIR property) their own attachment directory." (org-entry-put nil "ATTACH_DIR_INHERIT" "t") (message "Children will inherit attachment directory")) +(defun org-attach-use-annex () + "Return non-nil if git annex can be used." + (let ((git-dir (vc-git-root (expand-file-name org-attach-directory)))) + (and org-attach-git-annex-cutoff + (or (file-exists-p (expand-file-name "annex" git-dir)) + (file-exists-p (expand-file-name ".git/annex" git-dir)))))) + +(defun org-attach-annex-get-maybe (path) + "Call git annex get PATH (via shell) if using git annex. +Signals an error if the file content is not available and it was not retrieved." + (when (and (org-attach-use-annex) + (not + (string-equal + "found" + (shell-command-to-string + (format "git annex find --format=found --in=here %s" + (shell-quote-argument path)))))) + (let ((should-get + (if (eq org-attach-annex-auto-get 'ask) + (y-or-n-p (format "Run git annex get %s? " path)) + org-attach-annex-auto-get))) + (if should-get + (progn (message "Running git annex get \"%s\"." path) + (call-process "git" nil nil nil "annex" "get" path)) + (error "File %s stored in git annex but it is not available, and was not retrieved" + path))))) + (defun org-attach-commit () "Commit changes to git if `org-attach-directory' is properly initialized. This checks for the existence of a \".git\" directory in that directory." (let* ((dir (expand-file-name org-attach-directory)) (git-dir (vc-git-root dir)) + (use-annex (org-attach-use-annex)) (changes 0)) (when (and git-dir (executable-find "git")) (with-temp-buffer (cd dir) - (let ((have-annex - (and org-attach-git-annex-cutoff - (or (file-exists-p (expand-file-name "annex" git-dir)) - (file-exists-p (expand-file-name ".git/annex" git-dir)))))) - (dolist (new-or-modified - (split-string - (shell-command-to-string - "git ls-files -zmo --exclude-standard") "\0" t)) - (if (and have-annex - (>= (nth 7 (file-attributes new-or-modified)) - org-attach-git-annex-cutoff)) - (call-process "git" nil nil nil "annex" "add" new-or-modified) - (call-process "git" nil nil nil "add" new-or-modified)) - (incf changes))) + (dolist (new-or-modified + (split-string + (shell-command-to-string + "git ls-files -zmo --exclude-standard") "\0" t)) + (if (and use-annex + (>= (nth 7 (file-attributes new-or-modified)) + org-attach-git-annex-cutoff)) + (call-process "git" nil nil nil "annex" "add" new-or-modified) + (call-process "git" nil nil nil "add" new-or-modified)) + (incf changes)) (dolist (deleted (split-string (shell-command-to-string "git ls-files -z --deleted") "\0" t)) @@ -465,8 +500,10 @@ If IN-EMACS is non-nil, force opening in Emacs." (file (if (= (length files) 1) (car files) (completing-read "Open attachment: " - (mapcar #'list files) nil t)))) - (org-open-file (expand-file-name file attach-dir) in-emacs))) + (mapcar #'list files) nil t))) + (path (expand-file-name file attach-dir))) + (org-attach-annex-get-maybe path) + (org-open-file path in-emacs))) (defun org-attach-open-in-emacs () "Open attachment, force opening in Emacs. diff --git a/mk/targets.mk b/mk/targets.mk index d390fdb..cab65cb 100644 --- a/mk/targets.mk +++ b/mk/targets.mk @@ -158,4 +158,6 @@ cleandocs: -$(FIND) doc -name \*~ -exec $(RM) {} \; cleantest: +# git annex makes files 444, change to user writable so we can delete them + if [ -d $(testdir) ] ; then chmod u+w -R $(testdir) ; fi $(RMR) $(testdir) diff --git a/testing/lisp/test-org-attach.el b/testing/lisp/test-org-attach.el new file mode 100644 index 0000000..9772bd7 --- /dev/null +++ b/testing/lisp/test-org-attach.el @@ -0,0 +1,97 @@ +;;; test-org-attach.el --- Tests for Org Attach +;; +;; Copyright (c) 2016 Erik Hetzner +;; Authors: Erik Hetzner + +;; This file is not part of GNU Emacs. + +;; 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 . + +;;; Code: +(require 'org-attach) +(require 'cl-lib) + +(defmacro test-org-attach-annex/with-annex (&rest body) + `(let ((tmpdir (make-temp-file "org-annex-test" t))) + (unwind-protect + (let ((default-directory tmpdir) + (org-attach-directory tmpdir)) + (shell-command "git init") + (shell-command "git annex init") + ,@body)))) + +(ert-deftest test-org-attach/use-annex () + (org-test-for-executable "git-annex") + (test-org-attach-annex/with-annex + (let ((org-attach-git-annex-cutoff 1)) + (should (org-attach-use-annex))) + + (let ((org-attach-git-annex-cutoff nil)) + (should-not (org-attach-use-annex)))) + + ;; test with non annex directory + (let ((tmpdir (make-temp-file "org-annex-test" t))) + (unwind-protect + (let ((default-directory tmpdir) + (org-attach-directory tmpdir)) + (shell-command "git init") + (should-not (org-attach-use-annex))) + (delete-directory tmpdir 'recursive)))) + +(ert-deftest test-org-attach/get-maybe () + (org-test-for-executable "git-annex") + (test-org-attach-annex/with-annex + (let ((path (expand-file-name "test-file")) + (annex-dup (make-temp-file "org-annex-test" t))) + (with-temp-buffer + (insert "hello world\n") + (write-file path)) + (shell-command "git annex add test-file") + (shell-command "git annex sync") + ;; Set up remote & copy files there + (let ((annex-original default-directory) + (default-directory annex-dup)) + (shell-command (format "git clone %s ." (shell-quote-argument annex-original))) + (shell-command "git annex init dup") + (shell-command (format "git remote add original %s" (shell-quote-argument annex-original))) + (shell-command "git annex get test-file") + (shell-command "git annex sync")) + (shell-command (format "git remote add dup %s" (shell-quote-argument annex-dup))) + (shell-command "git annex sync") + (shell-command "git annex drop --force test-file") + ;; test getting the file from the dup when we should ALWAYS get + (should (not (file-exists-p (file-symlink-p (expand-file-name "test-file"))))) + (let ((org-attach-annex-auto-get t)) + (org-attach-annex-get-maybe (expand-file-name "test-file")) + ;; check that the file has the right contents + (with-temp-buffer + (insert-file-contents path) + (should (string-equal "hello world\n" (buffer-string))))) + ;; test getting the file from the dup when we should NEVER get + (shell-command "git annex drop --force test-file") + (let ((org-attach-annex-auto-get nil)) + (should-error (org-attach-annex-get-maybe (expand-file-name "test-file")))) + (let ((org-attach-annex-auto-get 'ask) + (called nil)) + (flet ((y-or-n-p (prompt) + (setq called 'was-called) + t)) + (org-attach-annex-get-maybe (expand-file-name "test-file")) + ;; check that the file has the right contents + (with-temp-buffer + (insert-file-contents path) + (should (string-equal "hello world\n" (buffer-string)))) + (should (eq called 'was-called))))))) + +;;; test-org-attach.el ends here -- 2.5.0