| commit | author | age | ||
| 76bbd0 | 1 | ;;; org-attach.el --- Manage file attachments to Org tasks -*- lexical-binding: t; -*- |
| C | 2 | |
| 3 | ;; Copyright (C) 2008-2018 Free Software Foundation, Inc. | |
| 4 | ||
| 5 | ;; Author: John Wiegley <johnw@newartisans.com> | |
| 6 | ;; Keywords: org data task | |
| 7 | ||
| 8 | ;; This file is part of GNU Emacs. | |
| 9 | ;; | |
| 10 | ;; GNU Emacs is free software: you can redistribute it and/or modify | |
| 11 | ;; it under the terms of the GNU General Public License as published by | |
| 12 | ;; the Free Software Foundation, either version 3 of the License, or | |
| 13 | ;; (at your option) any later version. | |
| 14 | ||
| 15 | ;; GNU Emacs is distributed in the hope that it will be useful, | |
| 16 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
| 17 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
| 18 | ;; GNU General Public License for more details. | |
| 19 | ||
| 20 | ;; You should have received a copy of the GNU General Public License | |
| 21 | ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. | |
| 22 | ||
| 23 | ;;; Commentary: | |
| 24 | ||
| 25 | ;; See the Org manual for information on how to use it. | |
| 26 | ;; | |
| 27 | ;; Attachments are managed in a special directory called "data", which | |
| 28 | ;; lives in the same directory as the org file itself. If this data | |
| 29 | ;; directory is initialized as a Git repository, then org-attach will | |
| 30 | ;; automatically commit changes when it sees them. | |
| 31 | ;; | |
| 32 | ;; Attachment directories are identified using a UUID generated for the | |
| 33 | ;; task which has the attachments. These are added as property to the | |
| 34 | ;; task when necessary, and should not be deleted or changed by the | |
| 35 | ;; user, ever. UUIDs are generated by a mechanism defined in the variable | |
| 36 | ;; `org-id-method'. | |
| 37 | ||
| 38 | ;;; Code: | |
| 39 | ||
| 40 | (require 'cl-lib) | |
| 41 | (require 'org) | |
| 42 | (require 'org-id) | |
| 43 | (require 'vc-git) | |
| 44 | ||
| 45 | (declare-function dired-dwim-target-directory "dired-aux") | |
| 46 | ||
| 47 | (defgroup org-attach nil | |
| 48 | "Options concerning entry attachments in Org mode." | |
| 49 | :tag "Org Attach" | |
| 50 | :group 'org) | |
| 51 | ||
| 52 | (defcustom org-attach-directory "data/" | |
| 53 | "The directory where attachments are stored. | |
| 54 | If this is a relative path, it will be interpreted relative to the directory | |
| 55 | where the Org file lives." | |
| 56 | :group 'org-attach | |
| 57 | :type 'directory) | |
| 58 | ||
| 59 | (defcustom org-attach-commit t | |
| 60 | "If non-nil commit attachments with git. | |
| 61 | This is only done if the Org file is in a git repository." | |
| 62 | :group 'org-attach | |
| 63 | :type 'boolean | |
| 64 | :version "26.1" | |
| 65 | :package-version '(Org . "9.0")) | |
| 66 | ||
| 67 | (defcustom org-attach-git-annex-cutoff (* 32 1024) | |
| 68 | "If non-nil, files larger than this will be annexed instead of stored." | |
| 69 | :group 'org-attach | |
| 70 | :version "24.4" | |
| 71 | :package-version '(Org . "8.0") | |
| 72 | :type '(choice | |
| 73 | (const :tag "None" nil) | |
| 74 | (integer :tag "Bytes"))) | |
| 75 | ||
| 76 | (defcustom org-attach-auto-tag "ATTACH" | |
| 77 | "Tag that will be triggered automatically when an entry has an attachment." | |
| 78 | :group 'org-attach | |
| 79 | :type '(choice | |
| 80 | (const :tag "None" nil) | |
| 81 | (string :tag "Tag"))) | |
| 82 | ||
| 83 | (defcustom org-attach-file-list-property "Attachments" | |
| 84 | "The property used to keep a list of attachment belonging to this entry. | |
| 85 | This is not really needed, so you may set this to nil if you don't want it. | |
| 86 | Also, for entries where children inherit the directory, the list of | |
| 87 | attachments is not kept in this property." | |
| 88 | :group 'org-attach | |
| 89 | :type '(choice | |
| 90 | (const :tag "None" nil) | |
| 91 | (string :tag "Tag"))) | |
| 92 | ||
| 93 | (defcustom org-attach-method 'cp | |
| 94 | "The preferred method to attach a file. | |
| 95 | Allowed values are: | |
| 96 | ||
| 97 | mv rename the file to move it into the attachment directory | |
| 98 | cp copy the file | |
| 99 | ln create a hard link. Note that this is not supported | |
| 100 | on all systems, and then the result is not defined. | |
| 101 | lns create a symbol link. Note that this is not supported | |
| 102 | on all systems, and then the result is not defined." | |
| 103 | :group 'org-attach | |
| 104 | :type '(choice | |
| 105 | (const :tag "Copy" cp) | |
| 106 | (const :tag "Move/Rename" mv) | |
| 107 | (const :tag "Hard Link" ln) | |
| 108 | (const :tag "Symbol Link" lns))) | |
| 109 | ||
| 110 | (defcustom org-attach-expert nil | |
| 111 | "Non-nil means do not show the splash buffer with the attach dispatcher." | |
| 112 | :group 'org-attach | |
| 113 | :type 'boolean) | |
| 114 | ||
| 115 | (defcustom org-attach-allow-inheritance t | |
| 116 | "Non-nil means allow attachment directories be inherited." | |
| 117 | :group 'org-attach | |
| 118 | :type 'boolean) | |
| 119 | ||
| 120 | (defvar org-attach-inherited nil | |
| 121 | "Indicates if the last access to the attachment directory was inherited.") | |
| 122 | ||
| 123 | (defcustom org-attach-store-link-p nil | |
| 124 | "Non-nil means store a link to a file when attaching it." | |
| 125 | :group 'org-attach | |
| 126 | :version "24.1" | |
| 127 | :type '(choice | |
| 128 | (const :tag "Don't store link" nil) | |
| 129 | (const :tag "Link to origin location" t) | |
| 130 | (const :tag "Link to the attach-dir location" attached))) | |
| 131 | ||
| 132 | (defcustom org-attach-archive-delete nil | |
| 133 | "Non-nil means attachments are deleted upon archiving a subtree. | |
| 134 | When set to `query', ask the user instead." | |
| 135 | :group 'org-attach | |
| 136 | :version "26.1" | |
| 137 | :package-version '(Org . "8.3") | |
| 138 | :type '(choice | |
| 139 | (const :tag "Never delete attachments" nil) | |
| 140 | (const :tag "Always delete attachments" t) | |
| 141 | (const :tag "Query the user" query))) | |
| 142 | ||
| 143 | (defcustom org-attach-annex-auto-get 'ask | |
| 144 | "Confirmation preference for automatically getting annex files. | |
| 145 | If \\='ask, prompt using `y-or-n-p'. If t, always get. If nil, never get." | |
| 146 | :group 'org-attach | |
| 147 | :package-version '(Org . "9.0") | |
| 148 | :version "26.1" | |
| 149 | :type '(choice | |
| 150 | (const :tag "confirm with `y-or-n-p'" ask) | |
| 151 | (const :tag "always get from annex if necessary" t) | |
| 152 | (const :tag "never get from annex" nil))) | |
| 153 | ||
| 154 | ;;;###autoload | |
| 155 | (defun org-attach () | |
| 156 | "The dispatcher for attachment commands. | |
| 157 | Shows a list of commands and prompts for another key to execute a command." | |
| 158 | (interactive) | |
| 159 | (let (c marker) | |
| 160 | (when (eq major-mode 'org-agenda-mode) | |
| 161 | (setq marker (or (get-text-property (point) 'org-hd-marker) | |
| 162 | (get-text-property (point) 'org-marker))) | |
| 163 | (unless marker | |
| 164 | (error "No task in current line"))) | |
| 165 | (save-excursion | |
| 166 | (when marker | |
| 167 | (set-buffer (marker-buffer marker)) | |
| 168 | (goto-char marker)) | |
| 169 | (org-back-to-heading t) | |
| 170 | (save-excursion | |
| 171 | (save-window-excursion | |
| 172 | (unless org-attach-expert | |
| 173 | (with-output-to-temp-buffer "*Org Attach*" | |
| 174 | (princ "Select an Attachment Command: | |
| 175 | ||
| 176 | a Select a file and attach it to the task, using `org-attach-method'. | |
| 177 | c/m/l/y Attach a file using copy/move/link/symbolic-link method. | |
| 178 | u Attach a file from URL (downloading it). | |
| 179 | n Create a new attachment, as an Emacs buffer. | |
| 180 | z Synchronize the current task with its attachment | |
| 181 | directory, in case you added attachments yourself. | |
| 182 | ||
| 183 | o Open current task's attachments. | |
| 184 | O Like \"o\", but force opening in Emacs. | |
| 185 | f Open current task's attachment directory. | |
| 186 | F Like \"f\", but force using dired in Emacs. | |
| 187 | ||
| 188 | d Delete one attachment, you will be prompted for a file name. | |
| 189 | D Delete all of a task's attachments. A safer way is | |
| 190 | to open the directory in dired and delete from there. | |
| 191 | ||
| 192 | s Set a specific attachment directory for this entry or reset to default. | |
| 193 | i Make children of the current entry inherit its attachment directory."))) | |
| 194 | (org-fit-window-to-buffer (get-buffer-window "*Org Attach*")) | |
| 195 | (message "Select command: [acmlzoOfFdD]") | |
| 196 | (setq c (read-char-exclusive)) | |
| 197 | (and (get-buffer "*Org Attach*") (kill-buffer "*Org Attach*")))) | |
| 198 | (cond | |
| 199 | ((memq c '(?a ?\C-a)) (call-interactively 'org-attach-attach)) | |
| 200 | ((memq c '(?c ?\C-c)) | |
| 201 | (let ((org-attach-method 'cp)) (call-interactively 'org-attach-attach))) | |
| 202 | ((memq c '(?m ?\C-m)) | |
| 203 | (let ((org-attach-method 'mv)) (call-interactively 'org-attach-attach))) | |
| 204 | ((memq c '(?l ?\C-l)) | |
| 205 | (let ((org-attach-method 'ln)) (call-interactively 'org-attach-attach))) | |
| 206 | ((memq c '(?y ?\C-y)) | |
| 207 | (let ((org-attach-method 'lns)) (call-interactively 'org-attach-attach))) | |
| 208 | ((memq c '(?u ?\C-u)) | |
| 209 | (let ((org-attach-method 'url)) (call-interactively 'org-attach-url))) | |
| 210 | ((memq c '(?n ?\C-n)) (call-interactively 'org-attach-new)) | |
| 211 | ((memq c '(?z ?\C-z)) (call-interactively 'org-attach-sync)) | |
| 212 | ((memq c '(?o ?\C-o)) (call-interactively 'org-attach-open)) | |
| 213 | ((eq c ?O) (call-interactively 'org-attach-open-in-emacs)) | |
| 214 | ((memq c '(?f ?\C-f)) (call-interactively 'org-attach-reveal)) | |
| 215 | ((memq c '(?F)) (call-interactively 'org-attach-reveal-in-emacs)) | |
| 216 | ((memq c '(?d ?\C-d)) (call-interactively | |
| 217 | 'org-attach-delete-one)) | |
| 218 | ((eq c ?D) (call-interactively 'org-attach-delete-all)) | |
| 219 | ((eq c ?q) (message "Abort")) | |
| 220 | ((memq c '(?s ?\C-s)) (call-interactively | |
| 221 | 'org-attach-set-directory)) | |
| 222 | ((memq c '(?i ?\C-i)) (call-interactively | |
| 223 | 'org-attach-set-inherit)) | |
| 224 | (t (error "No such attachment command %c" c)))))) | |
| 225 | ||
| 226 | (defun org-attach-dir (&optional create-if-not-exists-p) | |
| 227 | "Return the directory associated with the current entry. | |
| 228 | This first checks for a local property ATTACH_DIR, and then for an inherited | |
| 229 | property ATTACH_DIR_INHERIT. If neither exists, the default mechanism | |
| 230 | using the entry ID will be invoked to access the unique directory for the | |
| 231 | current entry. | |
| 232 | If the directory does not exist and CREATE-IF-NOT-EXISTS-P is non-nil, | |
| 233 | the directory and (if necessary) the corresponding ID will be created." | |
| 234 | (let (attach-dir uuid) | |
| 235 | (setq org-attach-inherited (org-entry-get nil "ATTACH_DIR_INHERIT")) | |
| 236 | (cond | |
| 237 | ((setq attach-dir (org-entry-get nil "ATTACH_DIR")) | |
| 238 | (org-attach-check-absolute-path attach-dir)) | |
| 239 | ((and org-attach-allow-inheritance | |
| 240 | (org-entry-get nil "ATTACH_DIR_INHERIT" t)) | |
| 241 | (setq attach-dir | |
| 242 | (org-with-wide-buffer | |
| 243 | (if (marker-position org-entry-property-inherited-from) | |
| 244 | (goto-char org-entry-property-inherited-from) | |
| 245 | (org-back-to-heading t)) | |
| 246 | (let (org-attach-allow-inheritance) | |
| 247 | (org-attach-dir create-if-not-exists-p)))) | |
| 248 | (org-attach-check-absolute-path attach-dir) | |
| 249 | (setq org-attach-inherited t)) | |
| 250 | (t ; use the ID | |
| 251 | (org-attach-check-absolute-path nil) | |
| 252 | (setq uuid (org-id-get (point) create-if-not-exists-p)) | |
| 253 | (when (or uuid create-if-not-exists-p) | |
| 254 | (unless uuid (error "ID retrieval/creation failed")) | |
| 255 | (setq attach-dir (expand-file-name | |
| 256 | (format "%s/%s" | |
| 257 | (substring uuid 0 2) | |
| 258 | (substring uuid 2)) | |
| 259 | (expand-file-name org-attach-directory)))))) | |
| 260 | (when attach-dir | |
| 261 | (if (and create-if-not-exists-p | |
| 262 | (not (file-directory-p attach-dir))) | |
| 263 | (make-directory attach-dir t)) | |
| 264 | (and (file-exists-p attach-dir) | |
| 265 | attach-dir)))) | |
| 266 | ||
| 267 | (defun org-attach-check-absolute-path (dir) | |
| 268 | "Check if we have enough information to root the attachment directory. | |
| 269 | When DIR is given, check also if it is already absolute. Otherwise, | |
| 270 | assume that it will be relative, and check if `org-attach-directory' is | |
| 271 | absolute, or if at least the current buffer has a file name. | |
| 272 | Throw an error if we cannot root the directory." | |
| 273 | (or (and dir (file-name-absolute-p dir)) | |
| 274 | (file-name-absolute-p org-attach-directory) | |
| 275 | (buffer-file-name (buffer-base-buffer)) | |
| 276 | (error "Need absolute `org-attach-directory' to attach in buffers without filename"))) | |
| 277 | ||
| 278 | (defun org-attach-set-directory (&optional arg) | |
| 279 | "Set the ATTACH_DIR node property and ask to move files there. | |
| 280 | The property defines the directory that is used for attachments | |
| 281 | of the entry. When called with `\\[universal-argument]', reset \ | |
| 282 | the directory to | |
| 283 | the default ID based one." | |
| 284 | (interactive "P") | |
| 285 | (let ((old (org-attach-dir)) | |
| 286 | (new | |
| 287 | (progn | |
| 288 | (if arg (org-entry-delete nil "ATTACH_DIR") | |
| 289 | (let ((dir (read-directory-name | |
| 290 | "Attachment directory: " | |
| 291 | (org-entry-get nil | |
| 292 | "ATTACH_DIR" | |
| 293 | (and org-attach-allow-inheritance t))))) | |
| 294 | (org-entry-put nil "ATTACH_DIR" dir))) | |
| 295 | (org-attach-dir t)))) | |
| 296 | (unless (or (string= old new) | |
| 297 | (not old)) | |
| 298 | (when (yes-or-no-p "Copy over attachments from old directory? ") | |
| 299 | (copy-directory old new t nil t)) | |
| 300 | (when (yes-or-no-p (concat "Delete " old)) | |
| 301 | (delete-directory old t))))) | |
| 302 | ||
| 303 | (defun org-attach-set-inherit () | |
| 304 | "Set the ATTACH_DIR_INHERIT property of the current entry. | |
| 305 | The property defines the directory that is used for attachments | |
| 306 | of the entry and any children that do not explicitly define (by setting | |
| 307 | the ATTACH_DIR property) their own attachment directory." | |
| 308 | (interactive) | |
| 309 | (org-entry-put nil "ATTACH_DIR_INHERIT" "t") | |
| 310 | (message "Children will inherit attachment directory")) | |
| 311 | ||
| 312 | (defun org-attach-use-annex () | |
| 313 | "Return non-nil if git annex can be used." | |
| 314 | (let ((git-dir (vc-git-root (expand-file-name org-attach-directory)))) | |
| 315 | (and org-attach-git-annex-cutoff | |
| 316 | (or (file-exists-p (expand-file-name "annex" git-dir)) | |
| 317 | (file-exists-p (expand-file-name ".git/annex" git-dir)))))) | |
| 318 | ||
| 319 | (defun org-attach-annex-get-maybe (path) | |
| 320 | "Call git annex get PATH (via shell) if using git annex. | |
| 321 | Signals an error if the file content is not available and it was not retrieved." | |
| 322 | (let* ((default-directory (expand-file-name org-attach-directory)) | |
| 323 | (path-relative (file-relative-name path))) | |
| 324 | (when (and (org-attach-use-annex) | |
| 325 | (not | |
| 326 | (string-equal | |
| 327 | "found" | |
| 328 | (shell-command-to-string | |
| 329 | (format "git annex find --format=found --in=here %s" | |
| 330 | (shell-quote-argument path-relative)))))) | |
| 331 | (let ((should-get | |
| 332 | (if (eq org-attach-annex-auto-get 'ask) | |
| 333 | (y-or-n-p (format "Run git annex get %s? " path-relative)) | |
| 334 | org-attach-annex-auto-get))) | |
| 335 | (if should-get | |
| 336 | (progn (message "Running git annex get \"%s\"." path-relative) | |
| 337 | (call-process "git" nil nil nil "annex" "get" path-relative)) | |
| 338 | (error "File %s stored in git annex but it is not available, and was not retrieved" | |
| 339 | path)))))) | |
| 340 | ||
| 341 | (defun org-attach-commit () | |
| 342 | "Commit changes to git if `org-attach-directory' is properly initialized. | |
| 343 | This checks for the existence of a \".git\" directory in that directory." | |
| 344 | (let* ((dir (expand-file-name org-attach-directory)) | |
| 345 | (git-dir (vc-git-root dir)) | |
| 346 | (use-annex (org-attach-use-annex)) | |
| 347 | (changes 0)) | |
| 348 | (when (and git-dir (executable-find "git")) | |
| 349 | (with-temp-buffer | |
| 350 | (cd dir) | |
| 351 | (dolist (new-or-modified | |
| 352 | (split-string | |
| 353 | (shell-command-to-string | |
| 354 | "git ls-files -zmo --exclude-standard") "\0" t)) | |
| 355 | (if (and use-annex | |
| 356 | (>= (nth 7 (file-attributes new-or-modified)) | |
| 357 | org-attach-git-annex-cutoff)) | |
| 358 | (call-process "git" nil nil nil "annex" "add" new-or-modified) | |
| 359 | (call-process "git" nil nil nil "add" new-or-modified)) | |
| 360 | (cl-incf changes)) | |
| 361 | (dolist (deleted | |
| 362 | (split-string | |
| 363 | (shell-command-to-string "git ls-files -z --deleted") "\0" t)) | |
| 364 | (call-process "git" nil nil nil "rm" deleted) | |
| 365 | (cl-incf changes)) | |
| 366 | (when (> changes 0) | |
| 367 | (shell-command "git commit -m 'Synchronized attachments'")))))) | |
| 368 | ||
| 369 | (defun org-attach-tag (&optional off) | |
| 370 | "Turn the autotag on or (if OFF is set) off." | |
| 371 | (when org-attach-auto-tag | |
| 372 | (save-excursion | |
| 373 | (org-back-to-heading t) | |
| 374 | (org-toggle-tag org-attach-auto-tag (if off 'off 'on))))) | |
| 375 | ||
| 376 | (defun org-attach-untag () | |
| 377 | "Turn the autotag off." | |
| 378 | (org-attach-tag 'off)) | |
| 379 | ||
| 380 | (defun org-attach-store-link (file) | |
| 381 | "Add a link to `org-stored-link' when attaching a file. | |
| 382 | Only do this when `org-attach-store-link-p' is non-nil." | |
| 383 | (setq org-stored-links | |
| 384 | (cons (list (org-attach-expand-link file) | |
| 385 | (file-name-nondirectory file)) | |
| 386 | org-stored-links))) | |
| 387 | ||
| 388 | (defun org-attach-url (url) | |
| 389 | (interactive "MURL of the file to attach: \n") | |
| 390 | (org-attach-attach url)) | |
| 391 | ||
| 392 | (defun org-attach-attach (file &optional visit-dir method) | |
| 393 | "Move/copy/link FILE into the attachment directory of the current task. | |
| 394 | If VISIT-DIR is non-nil, visit the directory with dired. | |
| 395 | METHOD may be `cp', `mv', `ln', `lns' or `url' default taken from | |
| 396 | `org-attach-method'." | |
| 397 | (interactive | |
| 398 | (list | |
| 399 | (read-file-name "File to keep as an attachment:" | |
| 400 | (or (progn | |
| 401 | (require 'dired-aux) | |
| 402 | (dired-dwim-target-directory)) | |
| 403 | default-directory)) | |
| 404 | current-prefix-arg | |
| 405 | nil)) | |
| 406 | (setq method (or method org-attach-method)) | |
| 407 | (let ((basename (file-name-nondirectory file))) | |
| 408 | (when (and org-attach-file-list-property (not org-attach-inherited)) | |
| 409 | (org-entry-add-to-multivalued-property | |
| 410 | (point) org-attach-file-list-property basename)) | |
| 411 | (let* ((attach-dir (org-attach-dir t)) | |
| 412 | (fname (expand-file-name basename attach-dir))) | |
| 413 | (cond | |
| 414 | ((eq method 'mv) (rename-file file fname)) | |
| 415 | ((eq method 'cp) (copy-file file fname)) | |
| 416 | ((eq method 'ln) (add-name-to-file file fname)) | |
| 417 | ((eq method 'lns) (make-symbolic-link file fname)) | |
| 418 | ((eq method 'url) (url-copy-file file fname))) | |
| 419 | (when org-attach-commit | |
| 420 | (org-attach-commit)) | |
| 421 | (org-attach-tag) | |
| 422 | (cond ((eq org-attach-store-link-p 'attached) | |
| 423 | (org-attach-store-link fname)) | |
| 424 | ((eq org-attach-store-link-p t) | |
| 425 | (org-attach-store-link file))) | |
| 426 | (if visit-dir | |
| 427 | (dired attach-dir) | |
| 428 | (message "File %S is now a task attachment." basename))))) | |
| 429 | ||
| 430 | (defun org-attach-attach-cp () | |
| 431 | "Attach a file by copying it." | |
| 432 | (interactive) | |
| 433 | (let ((org-attach-method 'cp)) (call-interactively 'org-attach-attach))) | |
| 434 | (defun org-attach-attach-mv () | |
| 435 | "Attach a file by moving (renaming) it." | |
| 436 | (interactive) | |
| 437 | (let ((org-attach-method 'mv)) (call-interactively 'org-attach-attach))) | |
| 438 | (defun org-attach-attach-ln () | |
| 439 | "Attach a file by creating a hard link to it. | |
| 440 | Beware that this does not work on systems that do not support hard links. | |
| 441 | On some systems, this apparently does copy the file instead." | |
| 442 | (interactive) | |
| 443 | (let ((org-attach-method 'ln)) (call-interactively 'org-attach-attach))) | |
| 444 | (defun org-attach-attach-lns () | |
| 445 | "Attach a file by creating a symbolic link to it. | |
| 446 | ||
| 447 | Beware that this does not work on systems that do not support symbolic links. | |
| 448 | On some systems, this apparently does copy the file instead." | |
| 449 | (interactive) | |
| 450 | (let ((org-attach-method 'lns)) (call-interactively 'org-attach-attach))) | |
| 451 | ||
| 452 | (defun org-attach-new (file) | |
| 453 | "Create a new attachment FILE for the current task. | |
| 454 | The attachment is created as an Emacs buffer." | |
| 455 | (interactive "sCreate attachment named: ") | |
| 456 | (when (and org-attach-file-list-property (not org-attach-inherited)) | |
| 457 | (org-entry-add-to-multivalued-property | |
| 458 | (point) org-attach-file-list-property file)) | |
| 459 | (let ((attach-dir (org-attach-dir t))) | |
| 460 | (org-attach-tag) | |
| 461 | (find-file (expand-file-name file attach-dir)) | |
| 462 | (message "New attachment %s" file))) | |
| 463 | ||
| 464 | (defun org-attach-delete-one (&optional file) | |
| 465 | "Delete a single attachment." | |
| 466 | (interactive) | |
| 467 | (let* ((attach-dir (org-attach-dir t)) | |
| 468 | (files (org-attach-file-list attach-dir)) | |
| 469 | (file (or file | |
| 470 | (completing-read | |
| 471 | "Delete attachment: " | |
| 472 | (mapcar (lambda (f) | |
| 473 | (list (file-name-nondirectory f))) | |
| 474 | files))))) | |
| 475 | (setq file (expand-file-name file attach-dir)) | |
| 476 | (unless (file-exists-p file) | |
| 477 | (error "No such attachment: %s" file)) | |
| 478 | (delete-file file) | |
| 479 | (when org-attach-commit | |
| 480 | (org-attach-commit)))) | |
| 481 | ||
| 482 | (defun org-attach-delete-all (&optional force) | |
| 483 | "Delete all attachments from the current task. | |
| 484 | This actually deletes the entire attachment directory. | |
| 485 | A safer way is to open the directory in dired and delete from there." | |
| 486 | (interactive "P") | |
| 487 | (when (and org-attach-file-list-property (not org-attach-inherited)) | |
| 488 | (org-entry-delete (point) org-attach-file-list-property)) | |
| 489 | (let ((attach-dir (org-attach-dir))) | |
| 490 | (when | |
| 491 | (and attach-dir | |
| 492 | (or force | |
| 493 | (y-or-n-p "Are you sure you want to remove all attachments of this entry? "))) | |
| 494 | (shell-command (format "rm -fr %s" attach-dir)) | |
| 495 | (message "Attachment directory removed") | |
| 496 | (when org-attach-commit | |
| 497 | (org-attach-commit)) | |
| 498 | (org-attach-untag)))) | |
| 499 | ||
| 500 | (defun org-attach-sync () | |
| 501 | "Synchronize the current tasks with its attachments. | |
| 502 | This can be used after files have been added externally." | |
| 503 | (interactive) | |
| 504 | (when org-attach-commit | |
| 505 | (org-attach-commit)) | |
| 506 | (when (and org-attach-file-list-property (not org-attach-inherited)) | |
| 507 | (org-entry-delete (point) org-attach-file-list-property)) | |
| 508 | (let ((attach-dir (org-attach-dir))) | |
| 509 | (when attach-dir | |
| 510 | (let ((files (org-attach-file-list attach-dir))) | |
| 511 | (org-attach-tag (not files)) | |
| 512 | (when org-attach-file-list-property | |
| 513 | (dolist (file files) | |
| 514 | (unless (string-match "^\\.\\.?\\'" file) | |
| 515 | (org-entry-add-to-multivalued-property | |
| 516 | (point) org-attach-file-list-property file)))))))) | |
| 517 | ||
| 518 | (defun org-attach-file-list (dir) | |
| 519 | "Return a list of files in the attachment directory. | |
| 520 | This ignores files ending in \"~\"." | |
| 521 | (delq nil | |
| 522 | (mapcar (lambda (x) (if (string-match "^\\.\\.?\\'" x) nil x)) | |
| 523 | (directory-files dir nil "[^~]\\'")))) | |
| 524 | ||
| 525 | (defun org-attach-reveal (&optional if-exists) | |
| 526 | "Show the attachment directory of the current task. | |
| 527 | This will attempt to use an external program to show the directory." | |
| 528 | (interactive "P") | |
| 529 | (let ((attach-dir (org-attach-dir (not if-exists)))) | |
| 530 | (and attach-dir (org-open-file attach-dir)))) | |
| 531 | ||
| 532 | (defun org-attach-reveal-in-emacs () | |
| 533 | "Show the attachment directory of the current task in dired." | |
| 534 | (interactive) | |
| 535 | (let ((attach-dir (org-attach-dir t))) | |
| 536 | (dired attach-dir))) | |
| 537 | ||
| 538 | (defun org-attach-open (&optional in-emacs) | |
| 539 | "Open an attachment of the current task. | |
| 540 | If there are more than one attachment, you will be prompted for the file name. | |
| 541 | This command will open the file using the settings in `org-file-apps' | |
| 542 | and in the system-specific variants of this variable. | |
| 543 | If IN-EMACS is non-nil, force opening in Emacs." | |
| 544 | (interactive "P") | |
| 545 | (let* ((attach-dir (org-attach-dir t)) | |
| 546 | (files (org-attach-file-list attach-dir)) | |
| 547 | (file (if (= (length files) 1) | |
| 548 | (car files) | |
| 549 | (completing-read "Open attachment: " | |
| 550 | (mapcar #'list files) nil t))) | |
| 551 | (path (expand-file-name file attach-dir))) | |
| 552 | (org-attach-annex-get-maybe path) | |
| 553 | (org-open-file path in-emacs))) | |
| 554 | ||
| 555 | (defun org-attach-open-in-emacs () | |
| 556 | "Open attachment, force opening in Emacs. | |
| 557 | See `org-attach-open'." | |
| 558 | (interactive) | |
| 559 | (org-attach-open 'in-emacs)) | |
| 560 | ||
| 561 | (defun org-attach-expand (file) | |
| 562 | "Return the full path to the current entry's attachment file FILE. | |
| 563 | Basically, this adds the path to the attachment directory." | |
| 564 | (expand-file-name file (org-attach-dir))) | |
| 565 | ||
| 566 | (defun org-attach-expand-link (file) | |
| 567 | "Return a file link pointing to the current entry's attachment file FILE. | |
| 568 | Basically, this adds the path to the attachment directory, and a \"file:\" | |
| 569 | prefix." | |
| 570 | (concat "file:" (org-attach-expand file))) | |
| 571 | ||
| 572 | (defun org-attach-archive-delete-maybe () | |
| 573 | "Maybe delete subtree attachments when archiving. | |
| 574 | This function is called by `org-archive-hook'. The option | |
| 575 | `org-attach-archive-delete' controls its behavior." | |
| 576 | (when (if (eq org-attach-archive-delete 'query) | |
| 577 | (yes-or-no-p "Delete all attachments? ") | |
| 578 | org-attach-archive-delete) | |
| 579 | (org-attach-delete-all t))) | |
| 580 | ||
| 581 | (add-hook 'org-archive-hook 'org-attach-archive-delete-maybe) | |
| 582 | ||
| 583 | (provide 'org-attach) | |
| 584 | ||
| 585 | ;; Local variables: | |
| 586 | ;; generated-autoload-file: "org-loaddefs.el" | |
| 587 | ;; End: | |
| 588 | ||
| 589 | ;;; org-attach.el ends here | |
