diff options
Diffstat (limited to 'lisp/org/org-attach.el')
| -rw-r--r-- | lisp/org/org-attach.el | 154 |
1 files changed, 72 insertions, 82 deletions
diff --git a/lisp/org/org-attach.el b/lisp/org/org-attach.el index 1ed305c9ff3..e6aa97e0080 100644 --- a/lisp/org/org-attach.el +++ b/lisp/org/org-attach.el @@ -4,7 +4,6 @@ ;; Author: John Wiegley <johnw@newartisans.com> ;; Keywords: org data attachment - ;; This file is part of GNU Emacs. ;; ;; GNU Emacs is free software: you can redistribute it and/or modify @@ -41,6 +40,8 @@ (require 'org-id) (declare-function dired-dwim-target-directory "dired-aux") +(declare-function org-element-property "org-element" (property element)) +(declare-function org-element-type "org-element" (element)) (defgroup org-attach nil "Options concerning attachments in Org mode." @@ -129,8 +130,7 @@ Selective means to respect the inheritance setting in :type '(choice (const :tag "Don't use inheritance" nil) (const :tag "Inherit parent node attachments" t) - (const :tag "Respect org-use-property-inheritance" selective)) - :type 'boolean) + (const :tag "Respect org-use-property-inheritance" selective))) (defcustom org-attach-store-link-p nil "Non-nil means store a link to a file when attaching it." @@ -139,7 +139,8 @@ Selective means to respect the inheritance setting in :type '(choice (const :tag "Don't store link" nil) (const :tag "Link to origin location" t) - (const :tag "Link to the attach-dir location" attached))) + (const :tag "Attachment link to the attach-dir location" attached) + (const :tag "File link to the attach-dir location" file))) (defcustom org-attach-archive-delete nil "Non-nil means attachments are deleted upon archiving a subtree. @@ -254,16 +255,16 @@ Shows a list of commands and prompts for another key to execute a command." (get-text-property (point) 'org-marker))) (unless marker (error "No item in current line"))) - (save-excursion - (when marker - (set-buffer (marker-buffer marker)) - (goto-char marker)) - (org-back-to-heading t) + (org-with-point-at marker + (org-back-to-heading-or-point-min t) (save-excursion (save-window-excursion (unless org-attach-expert - (with-output-to-temp-buffer "*Org Attach*" - (princ + (org-switch-to-buffer-other-window "*Org Attach*") + (erase-buffer) + (setq cursor-type nil + header-line-format "Use C-v, M-v, C-n or C-p to navigate.") + (insert (concat "Attachment folder:\n" (or dir "Can't find an existing attachment-folder") @@ -286,11 +287,14 @@ Shows a list of commands and prompts for another key to execute a command." "Invalid `org-attach-commands' item: %S" entry)))) org-attach-commands - "\n")))))) + "\n"))))) (org-fit-window-to-buffer (get-buffer-window "*Org Attach*")) - (message "Select command: [%s]" - (concat (mapcar #'caar org-attach-commands))) - (setq c (read-char-exclusive)) + (let ((msg (format "Select command: [%s]" + (concat (mapcar #'caar org-attach-commands))))) + (message msg) + (while (and (setq c (read-char-exclusive)) + (memq c '(14 16 22 134217846))) + (org-scroll c t))) (and (get-buffer "*Org Attach*") (kill-buffer "*Org Attach*")))) (let ((command (cl-some (lambda (entry) (and (memq c (nth 0 entry)) (nth 1 entry))) @@ -457,14 +461,6 @@ DIR-property exists (that is different from the unset one)." "Turn the autotag off." (org-attach-tag 'off)) -(defun org-attach-store-link (file) - "Add a link to `org-stored-link' when attaching a file. -Only do this when `org-attach-store-link-p' is non-nil." - (setq org-stored-links - (cons (list (org-attach-expand-link file) - (file-name-nondirectory file)) - org-stored-links))) - (defun org-attach-url (url) (interactive "MURL of the file to attach: \n") (let ((org-attach-method 'url)) @@ -491,7 +487,7 @@ METHOD may be `cp', `mv', `ln', `lns' or `url' default taken from `org-attach-method'." (interactive (list - (read-file-name "File to keep as an attachment:" + (read-file-name "File to keep as an attachment: " (or (progn (require 'dired-aux) (dired-dwim-target-directory)) @@ -501,22 +497,30 @@ METHOD may be `cp', `mv', `ln', `lns' or `url' default taken from (setq method (or method org-attach-method)) (let ((basename (file-name-nondirectory file))) (let* ((attach-dir (org-attach-dir 'get-create)) - (fname (expand-file-name basename attach-dir))) + (attach-file (expand-file-name basename attach-dir))) (cond - ((eq method 'mv) (rename-file file fname)) - ((eq method 'cp) (copy-file file fname)) - ((eq method 'ln) (add-name-to-file file fname)) - ((eq method 'lns) (make-symbolic-link file fname)) - ((eq method 'url) (url-copy-file file fname))) + ((eq method 'mv) (rename-file file attach-file)) + ((eq method 'cp) (copy-file file attach-file)) + ((eq method 'ln) (add-name-to-file file attach-file)) + ((eq method 'lns) (make-symbolic-link file attach-file)) + ((eq method 'url) (url-copy-file file attach-file))) (run-hook-with-args 'org-attach-after-change-hook attach-dir) (org-attach-tag) (cond ((eq org-attach-store-link-p 'attached) - (org-attach-store-link fname)) + (push (list (concat "attachment:" (file-name-nondirectory attach-file)) + (file-name-nondirectory attach-file)) + org-stored-links)) ((eq org-attach-store-link-p t) - (org-attach-store-link file))) + (push (list (concat "file:" file) + (file-name-nondirectory file)) + org-stored-links)) + ((eq org-attach-store-link-p 'file) + (push (list (concat "file:" attach-file) + (file-name-nondirectory attach-file)) + org-stored-links))) (if visit-dir (dired attach-dir) - (message "File %S is now an attachment." basename))))) + (message "File %S is now an attachment" basename))))) (defun org-attach-attach-cp () "Attach a file by copying it." @@ -569,13 +573,18 @@ The attachment is created as an Emacs buffer." (defun org-attach-delete-all (&optional force) "Delete all attachments from the current outline node. This actually deletes the entire attachment directory. -A safer way is to open the directory in dired and delete from there." +A safer way is to open the directory in dired and delete from there. + +With prefix argument FORCE, directory will be recursively deleted +with no prompts." (interactive "P") (let ((attach-dir (org-attach-dir))) (when (and attach-dir (or force (yes-or-no-p "Really remove all attachments of this entry? "))) - (delete-directory attach-dir (yes-or-no-p "Recursive?") t) + (delete-directory attach-dir + (or force (yes-or-no-p "Recursive?")) + t) (message "Attachment directory removed") (run-hook-with-args 'org-attach-after-change-hook attach-dir) (org-attach-untag)))) @@ -642,37 +651,37 @@ See `org-attach-open'." Basically, this adds the path to the attachment directory." (expand-file-name file (org-attach-dir))) -(defun org-attach-expand-link (file) - "Return a file link pointing to the current entry's attachment file FILE. -Basically, this adds the path to the attachment directory, and a \"file:\" -prefix." - (concat "file:" (org-attach-expand file))) +(defun org-attach-expand-links (_) + "Expand links in current buffer. +It is meant to be added to `org-export-before-parsing-hook'." + (save-excursion + (while (re-search-forward "attachment:" nil t) + (let ((link (org-element-context))) + (when (and (eq 'link (org-element-type link)) + (string-equal "attachment" + (org-element-property :type link))) + (let* ((description (and (org-element-property :contents-begin link) + (buffer-substring-no-properties + (org-element-property :contents-begin link) + (org-element-property :contents-end link)))) + (file (org-element-property :path link)) + (new-link (org-link-make-string + (concat "file:" (org-attach-expand file)) + description))) + (goto-char (org-element-property :end link)) + (skip-chars-backward " \t") + (delete-region (org-element-property :begin link) (point)) + (insert new-link))))))) + +(defun org-attach-follow (file arg) + "Open FILE attachment. +See `org-open-file' for details about ARG." + (org-link-open-as-file (org-attach-expand file) arg)) (org-link-set-parameters "attachment" - :follow #'org-attach-open-link - :export #'org-attach-export-link + :follow #'org-attach-follow :complete #'org-attach-complete-link) -(defun org-attach-open-link (link &optional in-emacs) - "Attachment link type LINK is expanded with the attached directory and opened. - -With optional prefix argument IN-EMACS, Emacs will visit the file. -With a double \\[universal-argument] \\[universal-argument] \ -prefix arg, Org tries to avoid opening in Emacs -and to use an external application to visit the file." - (interactive "P") - (let (line search) - (cond - ((string-match "::\\([0-9]+\\)\\'" link) - (setq line (string-to-number (match-string 1 link)) - link (substring link 0 (match-beginning 0)))) - ((string-match "::\\(.+\\)\\'" link) - (setq search (match-string 1 link) - link (substring link 0 (match-beginning 0))))) - (if (string-match "[*?{]" (file-name-nondirectory link)) - (dired (org-attach-expand link)) - (org-open-file (org-attach-expand link) in-emacs line search)))) - (defun org-attach-complete-link () "Advise the user with the available files in the attachment directory." (let ((attach-dir (org-attach-dir))) @@ -691,26 +700,6 @@ and to use an external application to visit the file." (t (concat "attachment:" file)))) (error "No attachment directory exist")))) -(defun org-attach-export-link (link description format) - "Translate attachment LINK from Org mode format to exported FORMAT. -Also includes the DESCRIPTION of the link in the export." - (save-excursion - (let (path desc) - (cond - ((string-match "::\\([0-9]+\\)\\'" link) - (setq link (substring link 0 (match-beginning 0)))) - ((string-match "::\\(.+\\)\\'" link) - (setq link (substring link 0 (match-beginning 0))))) - (setq path (file-relative-name (org-attach-expand link)) - desc (or description link)) - (pcase format - (`html (format "<a target=\"_blank\" href=\"%s\">%s</a>" path desc)) - (`latex (format "\\href{%s}{%s}" path desc)) - (`texinfo (format "@uref{%s,%s}" path desc)) - (`ascii (format "%s (%s)" desc path)) - (`md (format "[%s](%s)" desc path)) - (_ path))))) - (defun org-attach-archive-delete-maybe () "Maybe delete subtree attachments when archiving. This function is called by `org-archive-hook'. The option @@ -758,6 +747,7 @@ Idea taken from `gnus-dired-attach'." (add-hook 'org-archive-hook 'org-attach-archive-delete-maybe) +(add-hook 'org-export-before-parsing-hook 'org-attach-expand-links) (provide 'org-attach) |