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