org-attach.el (34159B)
1 ;;; org-attach.el --- Manage file attachments to Org outlines -*- lexical-binding: t; -*- 2 3 ;; Copyright (C) 2008-2024 Free Software Foundation, Inc. 4 5 ;; Author: John Wiegley <johnw@newartisans.com> 6 ;; Keywords: org data attachment 7 ;; This file is part of GNU Emacs. 8 ;; 9 ;; GNU Emacs is free software: you can redistribute it and/or modify 10 ;; it under the terms of the GNU General Public License as published by 11 ;; the Free Software Foundation, either version 3 of the License, or 12 ;; (at your option) any later version. 13 14 ;; GNU Emacs is distributed in the hope that it will be useful, 15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 17 ;; GNU General Public License for more details. 18 19 ;; You should have received a copy of the GNU General Public License 20 ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. 21 22 ;;; Commentary: 23 24 ;; See the Org manual for information on how to use it. 25 ;; 26 ;; Attachments are managed either by using a custom property DIR or by 27 ;; using property ID from org-id. When DIR is defined, a location in 28 ;; the filesystem is directly attached to the outline node. When 29 ;; org-id is used, attachments are stored in a folder named after the 30 ;; ID, in a location defined by `org-attach-id-dir'. DIR has 31 ;; precedence over ID when both parameters are defined for the current 32 ;; outline node (also when inherited parameters are taken into 33 ;; account). 34 35 ;;; Code: 36 37 (require 'org-macs) 38 (org-assert-version) 39 40 (require 'cl-lib) 41 (require 'org) 42 (require 'ol) 43 (require 'org-id) 44 45 (declare-function dired-dwim-target-directory "dired-aux") 46 (declare-function dired-get-marked-files "dired" (&optional localp arg filter distinguish-one-marked error)) 47 (declare-function org-element-property "org-element-ast" (property node)) 48 (declare-function org-element-begin "org-element" (node)) 49 (declare-function org-element-end "org-element" (node)) 50 (declare-function org-element-contents-begin "org-element" (node)) 51 (declare-function org-element-contents-end "org-element" (node)) 52 (declare-function org-element-type-p "org-element-ast" (node types)) 53 (declare-function org-inlinetask-goto-beginning "org-inlinetask" ()) 54 (declare-function org-inlinetask-in-task-p "org-inlinetask" ()) 55 56 (defgroup org-attach nil 57 "Options concerning attachments in Org mode." 58 :tag "Org Attach" 59 :group 'org) 60 61 (defcustom org-attach-id-dir "data/" 62 "The directory where attachments are stored. 63 If this is a relative path, it will be interpreted relative to the directory 64 where the Org file lives." 65 :group 'org-attach 66 :type 'directory 67 :safe #'stringp) 68 69 (defcustom org-attach-dir-relative nil 70 "Non-nil means directories in DIR property are added as relative links. 71 Defaults to absolute location." 72 :group 'org-attach 73 :type 'boolean 74 :package-version '(Org . "9.3") 75 :safe #'booleanp) 76 77 (defcustom org-attach-auto-tag "ATTACH" 78 "Tag that will be triggered automatically when an entry has an attachment." 79 :group 'org-attach 80 :type '(choice 81 (const :tag "None" nil) 82 (string :tag "Tag"))) 83 84 (defcustom org-attach-preferred-new-method 'id 85 "Preferred way to attach to nodes without existing ID and DIR property. 86 This choice is used when adding attachments to nodes without ID 87 and DIR properties. 88 89 Allowed values are: 90 91 id Create and use an ID parameter 92 dir Create and use a DIR parameter 93 ask Ask the user for input of which method to choose 94 nil Prefer to not create a new parameter 95 96 nil means that ID or DIR has to be created explicitly 97 before attaching files." 98 :group 'org-attach 99 :package-version '(org . "9.3") 100 :type '(choice 101 (const :tag "ID parameter" id) 102 (const :tag "DIR parameter" dir) 103 (const :tag "Ask user" ask) 104 (const :tag "Don't create" nil))) 105 106 (defcustom org-attach-method 'cp 107 "The preferred method to attach a file. 108 Allowed values are: 109 110 mv rename the file to move it into the attachment directory 111 cp copy the file 112 ln create a hard link. Note that this is not supported 113 on all systems, and then the result is not defined. 114 lns create a symbol link. Note that this is not supported 115 on all systems, and then the result is not defined." 116 :group 'org-attach 117 :type '(choice 118 (const :tag "Copy" cp) 119 (const :tag "Move/Rename" mv) 120 (const :tag "Hard Link" ln) 121 (const :tag "Symbol Link" lns))) 122 123 (defcustom org-attach-expert nil 124 "Non-nil means do not show the splash buffer with the attach dispatcher." 125 :group 'org-attach 126 :type 'boolean) 127 128 (defcustom org-attach-use-inheritance 'selective 129 "Attachment inheritance for the outline. 130 131 Enabling inheritance for `org-attach' implies two things. First, 132 that attachment links will look through all parent headings until 133 it finds the linked attachment. Second, that running `org-attach' 134 inside a node without attachments will make `org-attach' operate on 135 the first parent heading it finds with an attachment. 136 137 Selective means to respect the inheritance setting in 138 `org-use-property-inheritance'." 139 :group 'org-attach 140 :type '(choice 141 (const :tag "Don't use inheritance" nil) 142 (const :tag "Inherit parent node attachments" t) 143 (const :tag "Respect org-use-property-inheritance" selective))) 144 145 (defcustom org-attach-store-link-p 'attached 146 "Non-nil means store a link to a file when attaching it. 147 When t, store the link to original file location. 148 When `file', store link to the attached file location. 149 When `attached', store attach: link to the attached file." 150 :group 'org-attach 151 :package-version '(Org . "9.7") 152 :type '(choice 153 (const :tag "Don't store link" nil) 154 (const :tag "Link to origin location" t) 155 (const :tag "Attachment link to the attach-dir location" attached) 156 (const :tag "File link to the attach-dir location" file))) 157 158 (defcustom org-attach-archive-delete nil 159 "Non-nil means attachments are deleted upon archiving a subtree. 160 When set to `query', ask the user instead." 161 :group 'org-attach 162 :version "26.1" 163 :package-version '(Org . "8.3") 164 :type '(choice 165 (const :tag "Never delete attachments" nil) 166 (const :tag "Always delete attachments" t) 167 (const :tag "Query the user" query))) 168 169 (defun org-attach-id-uuid-folder-format (id) 170 "Translate an UUID ID into a folder-path. 171 Default format for how Org translates ID properties to a path for 172 attachments. Useful if ID is generated with UUID." 173 (and (< 2 (length id)) 174 (format "%s/%s" 175 (substring id 0 2) 176 (substring id 2)))) 177 178 (defun org-attach-id-ts-folder-format (id) 179 "Translate an ID based on a timestamp to a folder-path. 180 Useful way of translation if ID is generated based on ISO8601 181 timestamp. Splits the attachment folder hierarchy into 182 year-month, the rest." 183 (and (< 6 (length id)) 184 (format "%s/%s" 185 (substring id 0 6) 186 (substring id 6)))) 187 188 (defun org-attach-id-fallback-folder-format (id) 189 "Return \"__/X/ID\" folder path as a dumb fallback. 190 X is the first character in the ID string. 191 192 This function may be appended to `org-attach-id-path-function-list' to 193 provide a fallback for non-standard ID values that other functions in 194 `org-attach-id-path-function-list' are unable to handle. For example, 195 when the ID is too short for `org-attach-id-ts-folder-format'. 196 197 However, we recommend to define a more specific function spreading 198 entries over multiple folders. This function may create a large 199 number of entries in a single folder, which may cause issues on some 200 systems." 201 (format "__/%s/%s" (substring id 0 1) id)) 202 203 (defcustom org-attach-id-to-path-function-list 204 '(org-attach-id-uuid-folder-format 205 org-attach-id-ts-folder-format 206 org-attach-id-fallback-folder-format) 207 "List of functions used to derive attachment path from an ID string. 208 The functions are called with a single ID argument until the return 209 value is an existing folder. If no folder has been created yet for 210 the given ID, then the first non-nil value defines the attachment 211 dir to be created. 212 213 Usually, the ID format passed to the functions is defined by 214 `org-id-method'. It is advised that the first function in the list do 215 not generate all the attachment dirs inside the same parent dir. Some 216 file systems may have performance issues in such scenario. 217 218 Care should be taken when customizing this variable. Previously 219 created attachment folders might not be correctly mapped upon removing 220 functions from the list. Then, Org will not be able to detect the 221 existing attachments." 222 :group 'org-attach 223 :package-version '(Org . "9.6") 224 :type '(repeat (function :tag "Function with ID as input"))) 225 226 (defvar org-attach-after-change-hook nil 227 "Hook called when files have been added or removed to the attachment folder.") 228 229 (defvar org-attach-open-hook nil 230 "Hook that is invoked by `org-attach-open'. 231 232 Created mostly to be compatible with org-attach-git after removing 233 git-functionality from this file.") 234 235 (defcustom org-attach-commands 236 '(((?a ?\C-a) org-attach-attach 237 "Select a file and attach it to the task, using `org-attach-method'.") 238 ((?c ?\C-c) org-attach-attach-cp 239 "Attach a file using copy method.") 240 ((?m ?\C-m) org-attach-attach-mv 241 "Attach a file using move method.") 242 ((?l ?\C-l) org-attach-attach-ln 243 "Attach a file using link method.") 244 ((?y ?\C-y) org-attach-attach-lns 245 "Attach a file using symbolic-link method.") 246 ((?u ?\C-u) org-attach-url 247 "Attach a file from URL (downloading it).") 248 ((?b) org-attach-buffer 249 "Select a buffer and attach its contents to the task.") 250 ((?n ?\C-n) org-attach-new 251 "Create a new attachment, as an Emacs buffer.") 252 ((?z ?\C-z) org-attach-sync 253 "Synchronize the current node with its attachment\n directory, in case \ 254 you added attachments yourself.\n") 255 ((?o ?\C-o) org-attach-open 256 "Open current node's attachments.") 257 ((?O) org-attach-open-in-emacs 258 "Like \"o\", but force opening in Emacs.") 259 ((?f ?\C-f) org-attach-reveal 260 "Open current node's attachment directory. Create if missing.") 261 ((?F) org-attach-reveal-in-emacs 262 "Like \"f\", but force using Dired in Emacs.\n") 263 ((?d ?\C-d) org-attach-delete-one 264 "Delete one attachment, you will be prompted for a file name.") 265 ((?D) org-attach-delete-all 266 "Delete all of a node's attachments. A safer way is\n to open the \ 267 directory in dired and delete from there.\n") 268 ((?s ?\C-s) org-attach-set-directory 269 "Set a specific attachment directory for this entry. Sets DIR property.") 270 ((?S ?\C-S) org-attach-unset-directory 271 "Unset the attachment directory for this entry. Removes DIR property.") 272 ((?q) (lambda () (interactive) (message "Abort")) "Abort.")) 273 "The list of commands for the attachment dispatcher. 274 Each entry in this list is a list of three elements: 275 - A list of keys (characters) to select the command (the fist 276 character in the list is shown in the attachment dispatcher's 277 splash buffer and minibuffer prompt). 278 - A command that is called interactively when one of these keys 279 is pressed. 280 - A docstring for this command in the attachment dispatcher's 281 splash buffer." 282 :group 'org-attach 283 :package-version '(Org . "9.3") 284 :type '(repeat (list (repeat :tag "Keys" character) 285 (function :tag "Command") 286 (string :tag "Docstring")))) 287 288 (defcustom org-attach-sync-delete-empty-dir 'query 289 "Determine what to do with an empty attachment directory on sync. 290 When set to nil, don't touch the directory. When set to `query', 291 ask the user instead, else remove without asking." 292 :group 'org-attach 293 :package-version '(Org . "9.5") 294 :type '(choice 295 (const :tag "Never delete" nil) 296 (const :tag "Always delete" t) 297 (const :tag "Query the user" query))) 298 299 ;;;###autoload 300 (defun org-attach () 301 "The dispatcher for attachment commands. 302 Shows a list of commands and prompts for another key to execute a command." 303 (interactive) 304 (let (c marker) 305 (when (eq major-mode 'org-agenda-mode) 306 (setq marker (or (get-text-property (point) 'org-hd-marker) 307 (get-text-property (point) 'org-marker))) 308 (unless marker 309 (error "No item in current line"))) 310 (org-with-point-at marker 311 (let ((dir (org-attach-dir nil 'no-fs-check))) 312 (if (and (featurep 'org-inlinetask) 313 (not (org-inlinetask-in-task-p))) 314 (org-with-limited-levels 315 (org-back-to-heading-or-point-min t)) 316 (if (and (featurep 'org-inlinetask) 317 (org-inlinetask-in-task-p)) 318 (org-inlinetask-goto-beginning) 319 (org-back-to-heading-or-point-min t))) 320 (save-excursion 321 (save-window-excursion 322 (unless org-attach-expert 323 (switch-to-buffer-other-window "*Org Attach*") 324 (erase-buffer) 325 (setq cursor-type nil 326 header-line-format "Use C-v, M-v, C-n or C-p to navigate.") 327 (insert 328 (concat "Attachment folder:\n" 329 (or dir 330 "Can't find an existing attachment-folder") 331 (unless (and dir (file-directory-p dir)) 332 "\n(Not yet created)") 333 "\n\n" 334 (format "Select an Attachment Command:\n\n%s" 335 (mapconcat 336 (lambda (entry) 337 (pcase entry 338 (`((,key . ,_) ,_ ,docstring) 339 (format "%c %s" 340 key 341 (replace-regexp-in-string "\n\\([\t ]*\\)" 342 " " 343 docstring 344 nil nil 1))) 345 (_ 346 (user-error 347 "Invalid `org-attach-commands' item: %S" 348 entry)))) 349 org-attach-commands 350 "\n")))) 351 (goto-char (point-min))) 352 (org-fit-window-to-buffer (get-buffer-window "*Org Attach*")) 353 (unwind-protect 354 (let ((msg (format "Select command: [%s]" 355 (concat (mapcar #'caar org-attach-commands))))) 356 (message msg) 357 (while (and (setq c (read-char-exclusive)) 358 (memq c '(?\C-n ?\C-p ?\C-v ?\M-v))) 359 (org-scroll c t))) 360 (when-let* ((window (get-buffer-window "*Org Attach*" t))) 361 (quit-window 'kill window)) 362 (and (get-buffer "*Org Attach*") (kill-buffer "*Org Attach*"))))) 363 (let ((command (cl-some (lambda (entry) 364 (and (memq c (nth 0 entry)) (nth 1 entry))) 365 org-attach-commands))) 366 (if (commandp command) 367 (command-execute command) 368 (error "No such attachment command: %c" c))))))) 369 370 ;;;###autoload 371 (defun org-attach-dir (&optional create-if-not-exists-p no-fs-check) 372 "Return the directory associated with the current outline node. 373 First check for DIR property, then ID property. 374 `org-attach-use-inheritance' determines whether inherited 375 properties also will be considered. 376 377 If an ID property is found the default mechanism using that ID 378 will be invoked to access the directory for the current entry. 379 Note that this method returns the directory as declared by ID or 380 DIR even if the directory doesn't exist in the filesystem. 381 382 If CREATE-IF-NOT-EXISTS-P is non-nil, `org-attach-dir-get-create' 383 is run. If NO-FS-CHECK is non-nil, the function returns the path 384 to the attachment even if it has not yet been initialized in the 385 filesystem. 386 387 If no attachment directory can be derived, return nil." 388 (let (attach-dir id) 389 (cond 390 (create-if-not-exists-p 391 (setq attach-dir (org-attach-dir-get-create))) 392 ((setq attach-dir (org-entry-get nil "DIR" org-attach-use-inheritance)) 393 (org-attach-check-absolute-path attach-dir)) 394 ;; Deprecated and removed from documentation, but still 395 ;; works. FIXME: Remove after major nr change. 396 ((setq attach-dir (org-entry-get nil "ATTACH_DIR" org-attach-use-inheritance)) 397 (org-attach-check-absolute-path attach-dir)) 398 ((setq id (org-entry-get nil "ID" org-attach-use-inheritance)) 399 (org-attach-check-absolute-path nil) 400 (setq attach-dir (org-attach-dir-from-id id 'existing)))) 401 (if no-fs-check 402 attach-dir 403 (when (and attach-dir (file-directory-p attach-dir)) 404 attach-dir)))) 405 406 (defun org-attach-dir-get-create () 407 "Return existing or new directory associated with the current outline node. 408 `org-attach-preferred-new-method' decides how to attach new 409 directory if neither ID nor DIR property exist. 410 411 If the attachment by some reason cannot be created an error will be raised." 412 (interactive) 413 (let ((attach-dir (org-attach-dir nil 'no-fs-check))) 414 (unless attach-dir 415 (let (answer) 416 (when (eq org-attach-preferred-new-method 'ask) 417 (message "Create new ID [1] property or DIR [2] property for attachments?") 418 (setq answer (read-char-exclusive))) 419 (cond 420 ((or (eq org-attach-preferred-new-method 'id) (eq answer ?1)) 421 (let ((id (org-id-get nil t))) 422 (or (setq attach-dir (org-attach-dir-from-id id)) 423 (error "Failed to get folder for id %s, \ 424 adjust `org-attach-id-to-path-function-list'" 425 id)))) 426 ((or (eq org-attach-preferred-new-method 'dir) (eq answer ?2)) 427 (setq attach-dir (org-attach-set-directory))) 428 ((eq org-attach-preferred-new-method 'nil) 429 (error "No existing directory. DIR or ID property has to be explicitly created"))))) 430 (unless attach-dir 431 (error "No attachment directory is associated with the current node")) 432 (unless (file-directory-p attach-dir) 433 (make-directory attach-dir t)) 434 attach-dir)) 435 436 (defun org-attach-dir-from-id (id &optional existing) 437 "Return a folder path based on `org-attach-id-dir' and ID. 438 Try id-to-path functions in `org-attach-id-to-path-function-list' 439 ignoring nils. If EXISTING is non-nil, then return the first path 440 found in the filesystem. Otherwise return the first non-nil value." 441 (let ((fun-list org-attach-id-to-path-function-list) 442 (base-dir (expand-file-name org-attach-id-dir)) 443 (default-base-dir (expand-file-name "data/")) 444 preferred first) 445 (while (and fun-list 446 (not preferred)) 447 (let* ((name (funcall (car fun-list) id)) 448 (candidate (and name (expand-file-name name base-dir))) 449 ;; Try the default value `org-attach-id-dir' as a fallback. 450 (candidate2 (and name (not (equal base-dir default-base-dir)) 451 (expand-file-name name default-base-dir)))) 452 (setq fun-list (cdr fun-list)) 453 (when candidate 454 (if (or (not existing) (file-directory-p candidate)) 455 (setq preferred candidate) 456 (unless first 457 (setq first candidate))) 458 (when (and existing 459 candidate2 460 (not (file-directory-p candidate)) 461 (file-directory-p candidate2)) 462 (setq preferred candidate2))))) 463 (or preferred first))) 464 465 (defun org-attach-check-absolute-path (dir) 466 "Check if we have enough information to root the attachment directory. 467 When DIR is given, check also if it is already absolute. Otherwise, 468 assume that it will be relative, and check if `org-attach-id-dir' is 469 absolute, or if at least the current buffer has a file name. 470 Throw an error if we cannot root the directory." 471 (or (and dir (file-name-absolute-p dir)) 472 (file-name-absolute-p org-attach-id-dir) 473 (buffer-file-name (buffer-base-buffer)) 474 (error "Need absolute `org-attach-id-dir' to attach in buffers without filename"))) 475 476 (defun org-attach-set-directory () 477 "Set the DIR node property and ask to move files there. 478 The property defines the directory that is used for attachments 479 of the entry. Creates relative links if `org-attach-dir-relative' 480 is non-nil. 481 482 Return the directory." 483 (interactive) 484 (let ((old (org-attach-dir)) 485 (new 486 (let* ((attach-dir (read-directory-name 487 "Attachment directory: " 488 (org-entry-get nil "DIR"))) 489 (current-dir (file-name-directory (or default-directory 490 buffer-file-name))) 491 (attach-dir-relative (file-relative-name attach-dir current-dir))) 492 (org-entry-put nil "DIR" (if org-attach-dir-relative 493 attach-dir-relative 494 attach-dir)) 495 attach-dir))) 496 (unless (or (string= old new) 497 (not old)) 498 (when (yes-or-no-p "Copy over attachments from old directory? ") 499 (copy-directory old new t t t)) 500 (when (yes-or-no-p (concat "Delete " old)) 501 (delete-directory old t))) 502 new)) 503 504 (defun org-attach-unset-directory () 505 "Remove DIR node property. 506 If attachment folder is changed due to removal of DIR-property 507 ask to move attachments to new location and ask to delete old 508 attachment-folder. 509 510 Change of attachment-folder due to unset might be if an ID 511 property is set on the node, or if a separate inherited 512 DIR-property exists (that is different from the unset one)." 513 (interactive) 514 (let ((old (org-attach-dir)) 515 (new 516 (progn 517 (org-entry-delete nil "DIR") 518 ;; ATTACH-DIR is deprecated and removed from documentation, 519 ;; but still works. Remove code for it after major nr change. 520 (org-entry-delete nil "ATTACH_DIR") 521 (org-attach-dir)))) 522 (unless (or (string= old new) 523 (not old)) 524 (when (and new (yes-or-no-p "Copy over attachments from old directory? ")) 525 (copy-directory old new t nil t)) 526 (when (yes-or-no-p (concat "Delete " old)) 527 (delete-directory old t))))) 528 529 (defun org-attach-tag (&optional off) 530 "Turn the autotag on or (if OFF is set) off." 531 (when org-attach-auto-tag 532 ;; FIXME: There is currently no way to set #+FILETAGS 533 ;; programmatically. Do nothing when before first heading 534 ;; (attaching to file) to avoid blocking error. 535 (unless (org-before-first-heading-p) 536 (save-excursion 537 (org-back-to-heading t) 538 (org-toggle-tag org-attach-auto-tag (if off 'off 'on)))))) 539 540 (defun org-attach-untag () 541 "Turn the autotag off." 542 (org-attach-tag 'off)) 543 544 (defun org-attach-url (url) 545 "Attach URL." 546 (interactive "MURL of the file to attach: \n") 547 (let ((org-attach-method 'url) 548 (org-safe-remote-resources ; Assume safety if in an interactive session. 549 (if noninteractive org-safe-remote-resources '("")))) 550 (org-attach-attach url))) 551 552 (defun org-attach-buffer (buffer-name) 553 "Attach BUFFER-NAME's contents to current outline node. 554 BUFFER-NAME is a string. Signals a `file-already-exists' error 555 if it would overwrite an existing filename." 556 (interactive "bBuffer whose contents should be attached: ") 557 (let* ((attach-dir (org-attach-dir 'get-create)) 558 (output (expand-file-name buffer-name attach-dir))) 559 (when (file-exists-p output) 560 (signal 'file-already-exists (list "File exists" output))) 561 (run-hook-with-args 'org-attach-after-change-hook attach-dir) 562 (org-attach-tag) 563 (with-temp-file output 564 (insert-buffer-substring buffer-name)))) 565 566 (defun org-attach-attach (file &optional visit-dir method) 567 "Move/copy/link FILE into the attachment directory of the current outline node. 568 If VISIT-DIR is non-nil, visit the directory with `dired'. 569 METHOD may be `cp', `mv', `ln', `lns' or `url' default taken from 570 `org-attach-method'." 571 (interactive 572 (list 573 (read-file-name "File to keep as an attachment: " 574 (or (progn 575 (require 'dired-aux) 576 (dired-dwim-target-directory)) 577 default-directory)) 578 current-prefix-arg 579 nil)) 580 (setq method (or method org-attach-method)) 581 (when (file-directory-p file) 582 (setq file (directory-file-name file))) 583 (let ((basename (file-name-nondirectory file))) 584 (let* ((attach-dir (org-attach-dir 'get-create)) 585 (attach-file (expand-file-name basename attach-dir))) 586 (cond 587 ((eq method 'mv) (rename-file file attach-file)) 588 ((eq method 'cp) 589 (if (file-directory-p file) 590 (copy-directory file attach-file nil nil t) 591 (copy-file file attach-file))) 592 ((eq method 'ln) (add-name-to-file file attach-file)) 593 ((eq method 'lns) (make-symbolic-link file attach-file 1)) 594 ((eq method 'url) 595 (if (org--should-fetch-remote-resource-p file) 596 (url-copy-file file attach-file) 597 (error "The remote resource %S is considered unsafe, and will not be downloaded" 598 file)))) 599 (run-hook-with-args 'org-attach-after-change-hook attach-dir) 600 (org-attach-tag) 601 (cond ((eq org-attach-store-link-p 'attached) 602 (push (list (concat "attachment:" (file-name-nondirectory attach-file)) 603 (file-name-nondirectory attach-file)) 604 org-stored-links)) 605 ((eq org-attach-store-link-p t) 606 (push (list (concat "file:" file) 607 (file-name-nondirectory file)) 608 org-stored-links)) 609 ((eq org-attach-store-link-p 'file) 610 (push (list (concat "file:" attach-file) 611 (file-name-nondirectory attach-file)) 612 org-stored-links))) 613 (if visit-dir 614 (dired attach-dir) 615 (message "File %S is now an attachment" basename))))) 616 617 (defun org-attach-attach-cp () 618 "Attach a file by copying it." 619 (interactive) 620 (let ((org-attach-method 'cp)) (call-interactively 'org-attach-attach))) 621 (defun org-attach-attach-mv () 622 "Attach a file by moving (renaming) it." 623 (interactive) 624 (let ((org-attach-method 'mv)) (call-interactively 'org-attach-attach))) 625 (defun org-attach-attach-ln () 626 "Attach a file by creating a hard link to it. 627 Beware that this does not work on systems that do not support hard links. 628 On some systems, this apparently does copy the file instead." 629 (interactive) 630 (let ((org-attach-method 'ln)) (call-interactively 'org-attach-attach))) 631 (defun org-attach-attach-lns () 632 "Attach a file by creating a symbolic link to it. 633 634 Beware that this does not work on systems that do not support symbolic links. 635 On some systems, this apparently does copy the file instead." 636 (interactive) 637 (let ((org-attach-method 'lns)) (call-interactively 'org-attach-attach))) 638 639 (defun org-attach-new (file) 640 "Create a new attachment FILE for the current outline node. 641 The attachment is created as an Emacs buffer." 642 (interactive "sCreate attachment named: ") 643 (let ((attach-dir (org-attach-dir 'get-create))) 644 (org-attach-tag) 645 (find-file (expand-file-name file attach-dir)) 646 (message "New attachment %s" file))) 647 648 (defun org-attach-delete-one (&optional attachment) 649 "Delete a single ATTACHMENT." 650 (interactive) 651 (let* ((attach-dir (org-attach-dir)) 652 (files (org-attach-file-list attach-dir)) 653 (attachment (or attachment 654 (completing-read 655 "Delete attachment: " 656 (mapcar (lambda (f) 657 (list (file-name-nondirectory f))) 658 files))))) 659 (setq attachment (expand-file-name attachment attach-dir)) 660 (unless (file-exists-p attachment) 661 (error "No such attachment: %s" attachment)) 662 (delete-file attachment) 663 (run-hook-with-args 'org-attach-after-change-hook attach-dir))) 664 665 (defun org-attach-delete-all (&optional force) 666 "Delete all attachments from the current outline node. 667 This actually deletes the entire attachment directory. 668 A safer way is to open the directory in `dired' and delete from there. 669 670 With prefix argument FORCE, directory will be recursively deleted 671 with no prompts." 672 (interactive "P") 673 (let ((attach-dir (org-attach-dir))) 674 (when (and attach-dir 675 (or force 676 (yes-or-no-p "Really remove all attachments of this entry? "))) 677 (delete-directory attach-dir 678 (or force (yes-or-no-p "Recursive?")) 679 t) 680 (message "Attachment directory removed") 681 (run-hook-with-args 'org-attach-after-change-hook attach-dir) 682 (org-attach-untag)))) 683 684 (defun org-attach-sync () 685 "Synchronize the current outline node with its attachments. 686 Useful after files have been added/removed externally. Option 687 `org-attach-sync-delete-empty-dir' controls the behavior for 688 empty attachment directories." 689 (interactive) 690 (let ((attach-dir (org-attach-dir))) 691 (if (not attach-dir) 692 (org-attach-tag 'off) 693 (run-hook-with-args 'org-attach-after-change-hook attach-dir) 694 (let ((files (org-attach-file-list attach-dir))) 695 (org-attach-tag (not files))) 696 (when org-attach-sync-delete-empty-dir 697 (when (and (org-directory-empty-p attach-dir) 698 (if (eq 'query org-attach-sync-delete-empty-dir) 699 (yes-or-no-p "Attachment directory is empty. Delete?") 700 t)) 701 (delete-directory attach-dir)))))) 702 703 (defun org-attach-file-list (directory) 704 "Return a list of files in the attachment DIRECTORY. 705 This ignores files ending in \"~\"." 706 (delq nil 707 (mapcar (lambda (x) (if (string-match "^\\.\\.?\\'" x) nil x)) 708 (directory-files directory nil "[^~]\\'")))) 709 710 (defun org-attach-reveal () 711 "Show the attachment directory of the current outline node. 712 This will attempt to use an external program to show the 713 directory. Will create an attachment and folder if it doesn't 714 exist yet. Respects `org-attach-preferred-new-method'." 715 (interactive) 716 (org-open-file (org-attach-dir-get-create))) 717 718 (defun org-attach-reveal-in-emacs () 719 "Show the attachment directory of the current outline node in `dired'. 720 Will create an attachment and folder if it doesn't exist yet. 721 Respects `org-attach-preferred-new-method'." 722 (interactive) 723 (dired (org-attach-dir-get-create))) 724 725 (defun org-attach-open (&optional in-emacs) 726 "Open an attachment of the current outline node. 727 If there are more than one attachment, you will be prompted for the file name. 728 This command will open the file using the settings in `org-file-apps' 729 and in the system-specific variants of this variable. 730 If IN-EMACS is non-nil, force opening in Emacs." 731 (interactive "P") 732 (let ((attach-dir (org-attach-dir))) 733 (if attach-dir 734 (let* ((file (pcase (org-attach-file-list attach-dir) 735 (`(,file) file) 736 (files (completing-read "Open attachment: " 737 (mapcar #'list files) nil t)))) 738 (path (expand-file-name file attach-dir))) 739 (run-hook-with-args 'org-attach-open-hook path) 740 (org-open-file path in-emacs)) 741 (error "No attachment directory exist")))) 742 743 (defun org-attach-open-in-emacs () 744 "Open attachment, force opening in Emacs. 745 See `org-attach-open'." 746 (interactive) 747 (org-attach-open 'in-emacs)) 748 749 (defun org-attach-expand (file) 750 "Return the full path to the current entry's attachment file FILE. 751 Basically, this adds the path to the attachment directory." 752 (expand-file-name file (org-attach-dir))) 753 754 (defun org-attach-expand-links (_) 755 "Expand links in current buffer. 756 It is meant to be added to `org-export-before-parsing-hook'." 757 (save-excursion 758 (while (re-search-forward "attachment:" nil t) 759 (let ((link (org-element-context))) 760 (when (and (org-element-type-p link 'link) 761 (string-equal "attachment" 762 (org-element-property :type link))) 763 (let* ((description (and (org-element-contents-begin link) 764 (buffer-substring-no-properties 765 (org-element-contents-begin link) 766 (org-element-contents-end link)))) 767 (file (org-element-property :path link)) 768 (new-link (org-link-make-string 769 (concat "file:" (org-attach-expand file)) 770 description))) 771 (goto-char (org-element-end link)) 772 (skip-chars-backward " \t") 773 (delete-region (org-element-begin link) (point)) 774 (insert new-link))))))) 775 776 (defun org-attach-follow (file arg) 777 "Open FILE attachment. 778 See `org-open-file' for details about ARG." 779 (org-link-open-as-file (org-attach-expand file) arg)) 780 781 (org-link-set-parameters "attachment" 782 :follow #'org-attach-follow 783 :complete #'org-attach-complete-link) 784 785 (defun org-attach-complete-link () 786 "Advise the user with the available files in the attachment directory." 787 (let ((attach-dir (org-attach-dir))) 788 (if attach-dir 789 (let* ((attached-dir (expand-file-name attach-dir)) 790 (file (read-file-name "File: " attached-dir)) 791 (pwd (file-name-as-directory attached-dir)) 792 (pwd-relative (file-name-as-directory 793 (abbreviate-file-name attached-dir)))) 794 (cond 795 ((string-match (concat "^" (regexp-quote pwd-relative) "\\(.+\\)") file) 796 (concat "attachment:" (match-string 1 file))) 797 ((string-match (concat "^" (regexp-quote pwd) "\\(.+\\)") 798 (expand-file-name file)) 799 (concat "attachment:" (match-string 1 (expand-file-name file)))) 800 (t (concat "attachment:" file)))) 801 (error "No attachment directory exist")))) 802 803 (defun org-attach-archive-delete-maybe () 804 "Maybe delete subtree attachments when archiving. 805 This function is called by `org-archive-hook'. The option 806 `org-attach-archive-delete' controls its behavior." 807 (when org-attach-archive-delete 808 (org-attach-delete-all (not (eq org-attach-archive-delete 'query))))) 809 810 811 ;; Attach from dired. 812 813 ;; Add the following lines to the config file to get a binding for 814 ;; dired-mode. 815 816 ;; (add-hook 817 ;; 'dired-mode-hook 818 ;; (lambda () 819 ;; (define-key dired-mode-map (kbd "C-c C-x a") #'org-attach-dired-to-subtree)))) 820 821 ;;;###autoload 822 (defun org-attach-dired-to-subtree (files) 823 "Attach FILES marked or current file in `dired' to subtree in other window. 824 Takes the method given in `org-attach-method' for the attach action. 825 Precondition: Point must be in a `dired' buffer. 826 Idea taken from `gnus-dired-attach'." 827 (interactive 828 (list (dired-get-marked-files))) 829 (unless (eq major-mode 'dired-mode) 830 (user-error "This command must be triggered in a `dired' buffer")) 831 (let ((start-win (selected-window)) 832 (other-win 833 (get-window-with-predicate 834 (lambda (window) 835 (with-current-buffer (window-buffer window) 836 (eq major-mode 'org-mode)))))) 837 (unless other-win 838 (user-error 839 "Can't attach to subtree. No window displaying an Org buffer")) 840 (select-window other-win) 841 (dolist (file files) 842 (org-attach-attach file)) 843 (select-window start-win) 844 (when (eq 'mv org-attach-method) 845 (revert-buffer)))) 846 847 848 849 (add-hook 'org-archive-hook 'org-attach-archive-delete-maybe) 850 (add-hook 'org-export-before-parsing-functions 'org-attach-expand-links) 851 852 (provide 'org-attach) 853 854 ;; Local variables: 855 ;; generated-autoload-file: "org-loaddefs.el" 856 ;; End: 857 858 ;;; org-attach.el ends here