update packages

lisp/org/lisp/org-attach.el

@@ -40,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."
@@ -128,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."
@@ -138,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.
@@ -253,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")
@@ -285,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)))
@@ -456,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))
@@ -500,19 +497,27 @@ 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)))))
@@ -568,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))))
@@ -641,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)))
@@ -690,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
@@ -757,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)