Ihor Radchenko <[email protected]> writes:
>
> I am leaning towards (2). We may want an override to be specific menu
> system rather than custom function. Imagine some menu that can only work
> in full using transient, but not alternative menus. We then want to have
> a way to use transient even if global menu system is something else.
>
> As for writing a custom menu system, I think it should be easy to do, if
> we change `org-menu-define' to pass ARGLIST to the menu system, in
> addition to (org-menu--bind-specification bound-arguments ,menu-actions)
> Then, the custom menu system will simply look like
> (defun custom-menu-system (_ _ &rest args)
> (apply #'old-command args))
>
One downside with this is that the custom menu system would only be
available for that specific command, I think it is neat if it can be
used for any menu.
(Also, do I understand things wrong, or would it be a problem for your
approach that org-attach takes no arguments?)
I made a new menu system, `org-menu-attach-style-prompt', which presents
a menu in the same style as the old org-attach command. The drawback
here is that it ignores org-attach-expert, which is not visible from
om.el. Is there something similar to declare-function for variables? In
that case I could special case the org-attach menu.
>> About (interactive) as default body, you are correct - that was not
>> the problem, only forcing org-element-context. Now we have another
>> problem: I think we are required to provide an uneven number of &key
>> and &rest arguments, so the body can not be empty :-( Can we get
>> around this in some way or do we have to specify (interactive) as
>> the body?
>
> I do not fully understand the problem.
> Could you show a simplified macro definition and a macro call that
> causes issues you described?
This was because there was no problem, I misread an answer on
stackoverflow and had an error in my code. Sorry about the
confusion. The body can now be empty, and (interactive) will be added.
What do you think of this version?
Cheers,
Tor-björn
>From e5deeb00d330e4af881658acc414d3f72156bec6 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Tor-bj=C3=B6ron?= <[email protected]>
Date: Thu, 27 Feb 2025 20:30:07 +0200
Subject: [PATCH] lisp/om.el: Org-menu, a simple menu system for org.
* lisp/om.el: Add org-menu.
* lisp/oc-basic.el (require 'om): Pull in om.
(org-cite-basic-follow-actions): New customization option, that
specifies the contents of the transient menu.
(org-cite-basic-follow-default-action): New customization option,
the default action to be taken when following a citation object.
(org-cite-basic--get-key): New function. Get citation key from
citation or citation reference.
(org-cite-basic--get-url): New function. Get URL from citation or
citation reference.
(org-cite-basic--get-doi): New function. Get DOI from citation or
citation reference.
(org-cite-basic--browse): New function. Browse (using browse-url)
the URL or DOI-based URL of a citation or citation reference.
(org-cite-basic-goto): Use org-cite-basic--get-key.
(org-cite-basic-follow): Add a citation follower using org-menu.
(org-cite-register-processor 'basic): Update the basic citation
processor to follow citations using `org-cite-basic-follow'.
This change was co-authored with much support from Ihor Radchenko and
Jonas Bernoulli, thanks!
---
lisp/oc-basic.el | 75 ++++++++--
lisp/om.el | 367 +++++++++++++++++++++++++++++++++++++++++++++++
2 files changed, 433 insertions(+), 9 deletions(-)
create mode 100644 lisp/om.el
diff --git a/lisp/oc-basic.el b/lisp/oc-basic.el
index c57e8761e..8a05a9053 100644
--- a/lisp/oc-basic.el
+++ b/lisp/oc-basic.el
@@ -74,10 +74,12 @@
(require 'map)
(require 'oc)
(require 'seq)
+(require 'om)
(declare-function org-open-at-point "org" (&optional arg))
(declare-function org-open-file "org" (path &optional in-emacs line search))
+(declare-function org-element-context "org-element" (&optional element))
(declare-function org-element-create "org-element-ast" (type &optional props &rest children))
(declare-function org-element-set "org-element-ast" (old new &optional keep-props))
@@ -351,6 +353,41 @@ INFO is the export state, as a property list."
(map-keys entries))
(org-cite-basic--parse-bibliography)))
+(defun org-cite-basic--get-key (citation-or-citation-reference)
+ "Return citation key for CITATION-OR-CITATION-REFERENCE."
+ (if (org-element-type-p citation-or-citation-reference 'citation-reference)
+ (org-element-property :key citation-or-citation-reference)
+ (pcase (org-cite-get-references citation-or-citation-reference t)
+ (`(,key) key)
+ (keys
+ (or (completing-read "Select citation key: " keys nil t)
+ (user-error "Aborted"))))))
+
+(defun org-cite-basic--get-url (citation-or-citation-reference)
+ "Return URL for CITATION-OR-CITATION-REFERENCE."
+ (org-cite-basic--get-field
+ 'url
+ (org-cite-basic--get-key citation-or-citation-reference)))
+
+(defun org-cite-basic--get-doi (citation-or-citation-reference)
+ "Return DOI for CITATION-OR-CITATION-REFERENCE."
+ (org-cite-basic--get-field
+ 'doi
+ (org-cite-basic--get-key citation-or-citation-reference)))
+
+(defun org-cite-basic--browse (citation-or-citation-reference)
+ "Browse (using `browse-url') to the URL or DOI of CITATION-OR-CITATION-REFERENCE."
+ (let ((url (org-cite-basic--get-url citation-or-citation-reference))
+ (doi (org-cite-basic--get-doi citation-or-citation-reference)))
+ (cond ((org-string-nw-p url)
+ (browse-url url))
+ ((org-string-nw-p doi)
+ (if (string-match "^http" doi)
+ (browse-url doi)
+ (browse-url (format "http://dx.doi.org/%s"; doi))))
+ (t (user-error "No URL or DOI for `%s'"
+ (org-cite-basic--get-key citation-or-citation-reference))))))
+
(defun org-cite-basic--get-entry (key &optional info)
"Return BibTeX entry for KEY, as an association list.
When non-nil, INFO is the export state, as a property list."
@@ -830,14 +867,7 @@ export state, as a property list."
When DATUM is a citation reference, open bibliography entry referencing
the citation key. Otherwise, select which key to follow among all keys
present in the citation."
- (let* ((key
- (if (org-element-type-p datum 'citation-reference)
- (org-element-property :key datum)
- (pcase (org-cite-get-references datum t)
- (`(,key) key)
- (keys
- (or (completing-read "Select citation key: " keys nil t)
- (user-error "Aborted"))))))
+ (let* ((key (org-cite-basic--get-key datum))
(file
(pcase (seq-find (pcase-lambda (`(,_ . ,entries))
(gethash key entries))
@@ -857,6 +887,33 @@ present in the citation."
(bibtex-set-dialect)
(bibtex-search-entry key)))))
+(org-menu-define org-cite-basic-follow (citation-object &optional prefix-argument)
+ "Follow citation
+
+Open citations by applying the function in
+`org-cite-basic-follow-default-action'. "
+ :menu [["Open"
+ ("b" "Bibliography entry" (org-cite-basic-goto !citation-object !prefix-argument))
+ ("w" "Browse URL/DOI"
+ (org-cite-basic--browse !citation-object))]
+ ["Copy"
+ ("d" "DOI"
+ (let ((doi (org-cite-basic--get-doi !citation-object)))
+ (if (org-string-nw-p doi)
+ (kill-new doi)
+ (user-error "No DOI for `%s'" (org-cite-basic--get-key !citation-object)))))
+ ("u" "URL"
+ (let ((url (org-cite-basic--get-url !citation-object)))
+ (if (org-string-nw-p url)
+ (kill-new url)
+ (user-error "No URL for `%s'" (org-cite-basic--get-key !citation-object)))))]]
+ :default-action (org-cite-basic-goto !citation-object !prefix-argument)
+ (interactive
+ (list (let ((obj (org-element-context)))
+ (pcase (org-element-type obj)
+ ((or 'citation 'citation-reference) obj)
+ (_ (user-error "Wrong object type")))))))
+
;;; "Insert" capability
(defun org-cite-basic--complete-style (_)
@@ -1006,7 +1063,7 @@ Raise an error when no bibliography is set in the buffer."
:activate #'org-cite-basic-activate
:export-citation #'org-cite-basic-export-citation
:export-bibliography #'org-cite-basic-export-bibliography
- :follow #'org-cite-basic-goto
+ :follow #'org-cite-basic-follow
:insert (org-cite-make-insert-processor #'org-cite-basic--complete-key
#'org-cite-basic--complete-style)
:cite-styles
diff --git a/lisp/om.el b/lisp/om.el
new file mode 100644
index 000000000..b4c02e852
--- /dev/null
+++ b/lisp/om.el
@@ -0,0 +1,367 @@
+;;; om.el --- Org Menu library -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2025 Free Software Foundation, Inc.
+
+;; Author: Tor-björn Claesson <[email protected]>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This library provides facilities for displaying menus in org mode.
+
+;;; Code:
+
+(require 'cl-macs)
+(require 'org-macs)
+(require 'transient)
+(require 'which-key)
+
+(org-assert-version)
+
+
+;;; Configuration variables
+(defgroup org-menu nil
+ "Options concerning menus in Org mode."
+ :group 'org
+ :tag "Org Menu")
+
+(defcustom org-menu-switch '-
+ "Prefix argument that inverts the behaviour of `org-menu-mode'."
+ :group 'org-menu
+ :package-version '(Org . "9.8")
+ :type 'sexp)
+
+(defcustom org-menu-system 'transient
+ "The menu system to use for displaying Org Menus.
+
+Unless equal to transient, it should be a function with the
+signature (specification), where SPECIFICATION is a menu definition as per
+`org-cite-basic-follow-actions'.
+
+org-menu includes the functions `org-menu-popup' and `org-menu-tmm-prompt',
+which are valid options for `org-menu-system'."
+ :group 'org-menu
+ :package-version '(Org . "9.8")
+ :type 'sexp)
+
+(defcustom org-menu-system-overrides '()
+ "An alist of overrides for org-menu menues.
+
+The first member of each pair is the menu to override, the second member is a
+`org-menu-system', which will always be used for the overriden menu. This
+is useful when replacing an old menu with org-menu, to retain the original
+behaviour."
+ :group 'org-menu
+ :package-version '(Org . "9.8")
+ :type 'sexp)
+
+(defcustom org-menu-disable-overrides nil
+ "If this is true, `org-menu-system-overrides' will be ignored."
+ :group 'org-menu
+ :package-version '(Org . "9.8")
+ :type 'boolean)
+
+
+;;; Minor mode
+(define-minor-mode org-menu-mode
+ "Org menu mode.
+When Org menu mode is enabled, a menu prompting the user for an action
+will be presented upon activating certain objects.
+
+New menus can be defined using `org-menu-define'.
+
+The menu system used can be customized in `org-menu-system'.
+
+When `org-menu-mode' is active, it can be transiently deactivated by
+the prefix argument specified in `org-menu-switch', and vice verse
+transiently activated when inactive."
+ :init-value nil
+ :lighter " OM")
+
+
+;;; Helper functions
+(defmacro org-menu--bind-specification (bindings specification)
+ "Make BINDINGS visible to commands in SPECIFICATION.
+
+BINDINGS is a list of the form ((binding value) ...).
+SPECIFICATION is an org menu as per `org-cite-basic-follow-actions'.
+
+This macro returns SPECIFICATION, with each action wrapped in
+a let exposing BINDINGS."
+ `(cl-map
+ 'vector
+ (lambda (group)
+ (cl-map
+ 'vector
+ (lambda (spec)
+ (pcase spec
+ (`(,key ,desc (lambda ,args . ,body) . ,other)
+ `(,key ,desc
+ (lambda ,args
+ ,(unless (and (listp (car body))
+ (equal (caar body)
+ 'interactive))
+ '(interactive))
+ (let ,,bindings
+ ,@body))
+ ,@other))
+ (`(,key ,desc (,fn . ,fn-args) . ,other)
+ `(,key ,desc
+ (lambda ()
+ (interactive)
+ (let ,,bindings
+ (,fn ,@fn-args)))
+ ,@other))
+ (other other)))
+ group))
+ ,specification))
+
+(cl-defmacro org-menu--with-arguments (arg-list &body body)
+ "Make the arguments in ARG-LIST, prefixed with !, visible to BODY."
+ `(dlet ,(mapcar (lambda (arg)
+ `(,(intern (concat "!" (symbol-name arg))) ,arg))
+ arg-list)
+ ,@body))
+
+(defun org-menu--specification-to-menu (description specification)
+ "Make a flattened menu keymap out of an org menu specification.
+SPECIFICATION should be of the form of `org-cite-basic-follow-actions'.
+The title of the menu keymap is DESCRIPTION."
+ (let ((new-map (make-sparse-keymap description))
+ (prev-item-was-header nil))
+ (letrec ((define-menu
+ (lambda (menu)
+ (seq-map
+ (lambda (item)
+ (message "%S" item)
+ (when prev-item-was-header
+ ;; Add separator in all but last header.
+ (setq prev-item-was-header nil)
+ (define-key new-map `[,(gensym "separator-")] '(menu-item "--")))
+ (pcase item
+ ((pred vectorp) (funcall define-menu item))
+ ((pred stringp)
+ ;; FIXME: Use `keymap-set' when we drop Emacs 28 support.
+ (define-key new-map `[,(gensym "header-")] `(menu-item ,item))
+ (setq prev-item-was-header t))
+ (`(,key ,desc ,function)
+ (define-key new-map key `(menu-item ,desc ,function)))))
+ (seq-reverse menu)))))
+ (funcall define-menu specification)
+ new-map)))
+
+
+;;; Menu systems
+(defun org-menu-popup (description specification)
+ "Show an org-menu using a `popup-menu'.
+
+This function is a valid value for `org-menu-system':
+DESCRIPTION is the title for the menu, while SPECIFICATION is an org-menu
+specification as per `org-cite-basic-follow-actions'."
+ (let ((menu-keymap (org-menu--specification-to-menu description specification)))
+ (popup-menu menu-keymap)))
+
+(defun org-menu-tmm-prompt (description specification)
+ "Show an org-menu using a `tmm-prompt'.
+
+This function is a valid value for `org-menu-system':
+DESCRIPTION is the title for the menu, while SPECIFICATION is an org-menu
+specification as per `org-cite-basic-follow-actions'."
+ (let ((menu-keymap (org-menu--specification-to-menu description specification)))
+ (tmm-prompt menu-keymap)))
+
+
+(defmacro org-menu--defcustom-actions (menu-actions value menu-name)
+ "Define MENU-ACTIONS option for MENU-NAME with default VALUE."
+ `(progn (defcustom ,menu-actions ,value
+ ,(concat "Actions in the `" (symbol-name menu-name) "' org menu.
+
+This option uses the same syntax as `transient-define-prefix', see
+Info node `(transient)Binding Suffix and Infix Commands'. In
+addition, it is possible to specify a function call for the COMMAND
+part, where ARGUMENTS can be used to access those values.
+
+For example:
+
+[[\"Open\"
+ (\"b\" \"bibliography entry\"
+ (org-cite-basic-goto !citation-object !prefix-argument))]]
+
+will create an entry labeled \"bibliography entry\", activated with the
+b key, that calls `org-cite-basic-goto' with citation-object and
+prefix-argument as arguments.")
+ :group 'org-menu
+ :type 'sexp)
+ (put ',menu-actions 'definition-name ',menu-name)))
+
+(defmacro org-menu--defcustom-default-action
+ (default-action value menu-name arglist)
+ "Define DEFAULT-ACTION option for MENU-NAME with default VALUE.
+The action will accept ARGLIST arguments."
+ `(progn (defcustom ,default-action ,value
+ ,(concat "Default action for `" (symbol-name menu-name)
+ (if (null arglist)
+ "This should be a function of zero arguments,"
+ "'.
+This should be a function accepting the arguments\n\=")
+ (prin1-to-string arglist)
+ ".")
+ :group 'org-menu
+ :type 'sexp)
+ (put ',default-action 'definition-name ',menu-name)))
+
+(defun org-menu--strip-argument-decorators (arglist)
+ "Return a copy of ARGLIST without &optional or &rest."
+ (seq-filter
+ (lambda (elt)
+ (not (or (eq elt '&optional)
+ (eq elt '&rest))))
+ arglist))
+
+;;; Main macro definition
+(cl-defmacro org-menu-define
+ (name arglist docstring &rest body &key menu default-action (override nil) &allow-other-keys)
+ "Define an org menu NAME.
+
+A function called NAME will be created to activate the menu, as well as
+variables called NAME-actions and NAME-default-action.
+
+ARGLIST is the argument list of the function NAME.
+
+DOCSTRING is the docstring for NAME. The first row is used as title for
+keymaps based on this menu. The rest of the DOCSTRING should describe what
+the default action does. A short description of `org-menu-mode' and the
+customization containing the menu definition will be appended.
+
+Following this, the function accepts the following keyword arguments:
+
+MENU is used to populate the NAME-actions variable. It can be either a
+function, which should return a vector, or a vactor. The vector follows the
+syntax decribed in `(transient)Binding Suffix and Infix Commands',
+with the addition that the arguments in ARGLIST are accessible
+prefixed with !. For an example, see `org-cite-basic-follow-actions'.
+
+DEFAULT-ACTION specifies the action to be taken, if org-menu is
+inactive (as determined by `org-menu-mode' and modified by a
+prefix argument set in `org-menu-switch'.
+It has the form of a function call, where the arguments in
+ARGLIST are accessible prefixed by !. For example, the default action
+of `org-cite-basic-follow', which is defined with n ARGLIST
+\\(citation-object prefix-argument), has the form
+\\(org-cite-basic-goto !citation-object !prefix-argument).
+
+OVERRIDE specifies an `org-menu-system' to use by default. Some examples of
+valid values for this parameter are \='transient or #\='org-menu-popup.
+
+BODY is optional and can be used to set up the interactive
+environment and validate arguments. The body will be evaluated on activation
+of the menu, also when the default action is called."
+ (declare (indent defun))
+ (when override
+ (setq org-menu-system-overrides
+ (cons `(,name . ,override)
+ (assq-delete-all name org-menu-system-overrides))))
+ (let ((menu-default-action
+ (intern (concat (symbol-name name) "-default-action")))
+ (menu-actions
+ (if (functionp menu)
+ `(,menu)
+ (intern (concat (symbol-name name) "-actions")))))
+ `(progn
+ ,(unless (functionp menu)
+ `(org-menu--defcustom-actions
+ ,menu-actions ',menu ,name))
+ (org-menu--defcustom-default-action
+ ,menu-default-action
+ ',default-action
+ ,name
+ ',arglist)
+ (transient-define-prefix
+ ,name ,arglist
+ ,(if (functionp menu)
+ docstring
+ (concat docstring
+ "
+
+If `org-menu-mode' is active, display the menu specified in
+`"
+ (symbol-name menu-actions)
+ "'.
+
+This behaviour can be inverted by giving the prefix argument in
+`org-menu-switch'. See `org-menu-mode' for more information."))
+ [:class
+ transient-columns
+ :setup-children
+ (lambda (_)
+ (transient-parse-suffixes
+ ',name
+ (org-menu--bind-specification
+ (transient-scope)
+ ,menu-actions)))
+ :pad-keys t]
+ ,@(let ((filtered-body (named-let filter-body ((elements body))
+ (cond ((null elements)
+ '())
+ ((member (car elements)
+ '(:menu :default-action :menu-system :override))
+ (filter-body (cddr elements)))
+ (t
+ (cons (car elements)
+ (filter-body (cdr elements))))))))
+ (if filtered-body
+ filtered-body
+ '((interactive))))
+ (let ((bound-arguments
+ (list ,@(mapcar
+ (lambda (param)
+ `(list
+ ',(intern (concat "!" (symbol-name param)))
+ `',,param))
+ (org-menu--strip-argument-decorators arglist)))))
+ ;; Should we display a menu? If so, how?
+ (cond
+ ((and (not org-menu-disable-overrides)
+ (assq ',name org-menu-system-overrides))
+ (funcall
+ (cdr (assq ',name org-menu-system-overrides))
+ ,(car (split-string docstring "[\n]"))
+ (org-menu--bind-specification
+ bound-arguments
+ ,menu-actions)))
+ ((not (xor org-menu-mode
+ (eq current-prefix-arg org-menu-switch)))
+ ;; Call the default action
+ (org-menu--with-arguments
+ ,(org-menu--strip-argument-decorators arglist)
+ (eval ,menu-default-action)))
+ ((eq org-menu-system 'transient)
+ ;; Activate transient
+ (transient-setup
+ (quote ,name) nil nil
+ :scope bound-arguments))
+ (t
+ ;; Use the system specified in `org-menu-system'
+ (funcall
+ org-menu-system
+ ,(car (split-string docstring "[\n]"))
+ (org-menu--bind-specification
+ bound-arguments
+ ,menu-actions)))))))))
+
+(provide 'om)
+;;; om.el ends here
--
2.52.0
>From c4ebe62a965e76cb43a37fce23dc60393be3ca15 Mon Sep 17 00:00:00 2001
From: hepp <tbc@localhost>
Date: Sat, 31 Jan 2026 19:47:51 +0200
Subject: [PATCH] lisp/org-attach.el: Convert org-attach to an org-menu
* lisp/org-attach.el: (require 'om): Pull in om.
(org-attach-at-destination): New macro. Performs an action at the
correct place if we are in org-agenda-mode.
(org-attach--commands-to-transient-specification): New
function. Creates a transient specification suitable for org-menu from
org-attach-commands.
(org-attach): Now implemented as a org-menu.
(org-attach-old): The previous implementation of org-attach.
---
lisp/om.el | 45 +++++++++++++++++++
lisp/org-attach.el | 106 ++++++++++++++++-----------------------------
2 files changed, 82 insertions(+), 69 deletions(-)
diff --git a/lisp/om.el b/lisp/om.el
index b4c02e852..71922d35c 100644
--- a/lisp/om.el
+++ b/lisp/om.el
@@ -184,6 +184,51 @@ specification as per `org-cite-basic-follow-actions'."
(let ((menu-keymap (org-menu--specification-to-menu description specification)))
(tmm-prompt menu-keymap)))
+(defun org-menu-attach-style-prompt (description specification)
+ "Show an org-menu in the style of `org-attach'.
+
+This function is a valid value for `org-menu-system':
+DESCRIPTION is the title for the menu, while SPECIFICATION is an org-menu
+specification as per `org-cite-basic-follow-actions'."
+ (let (c
+ (command-list '())
+ (buffer-name (concat "*" description "*")))
+ (save-excursion
+ (save-window-excursion
+ (switch-to-buffer-other-window
+ buffer-name)
+ (erase-buffer)
+ (setq cursor-type nil
+ header-line-format "Use C-v, M-v, C-n or C-p to navigate.")
+ (insert "Select a Command:\n\n")
+ (cl-loop for submenu across specification do
+ (cl-loop for entry across submenu do
+ (pcase entry
+ (`(,key ,desc ,command)
+ (setq command-list (cons `(,key . ,command) command-list))
+ (insert (format "%s %s\n"
+ key
+ desc)))
+ (header
+ (insert (format "%s:\n" header))))))
+ (goto-char (point-min))
+ (org-fit-window-to-buffer (get-buffer-window buffer-name))
+ (unwind-protect
+ (let ((msg (format "Select command: [%s]"
+ (apply #'concat (mapcar #'car (reverse command-list))))))
+ (message msg)
+ (while (and (setq c (read-char-exclusive))
+ (memq c '(?\C-n ?\C-p ?\C-v ?\M-v)))
+ (org-scroll c t)))
+ (when-let* ((window (get-buffer-window "*Org Attach*" t)))
+ (quit-window 'kill window))
+ (and (get-buffer "*Org Attach*") (kill-buffer "*Org Attach*")))))
+ (let* ((key (string c))
+ (command (cdr (assoc key command-list))))
+ (if (commandp command)
+ (command-execute command)
+ (error "No such command: \"%s\"" key)))))
+
(defmacro org-menu--defcustom-actions (menu-actions value menu-name)
"Define MENU-ACTIONS option for MENU-NAME with default VALUE."
diff --git a/lisp/org-attach.el b/lisp/org-attach.el
index 67b430e71..07b23f658 100644
--- a/lisp/org-attach.el
+++ b/lisp/org-attach.el
@@ -40,6 +40,7 @@
(require 'cl-lib)
(require 'org)
(require 'ol)
+(require 'om)
(require 'org-id)
(declare-function dired-dwim-target-directory "dired-aux")
@@ -296,76 +297,43 @@ ask the user instead, else remove without asking."
(const :tag "Always delete" t)
(const :tag "Query the user" query)))
-;;;###autoload
-(defun org-attach ()
+(cl-defmacro org-attach-at-destination (&body body)
+ "If we are in agenda mode, evaluate BODY at the correct position."
+ `(let (marker)
+ (when (eq major-mode 'org-agenda-mode)
+ (setq marker (or (get-text-property (point) 'org-hd-marker)
+ (get-text-property (point) 'org-marker)))
+ (unless marker
+ (error "No item in current line")))
+ (print marker)
+ (org-with-point-at marker
+ (if (and (featurep 'org-inlinetask)
+ (not (org-inlinetask-in-task-p)))
+ (org-with-limited-levels
+ (org-back-to-heading-or-point-min t))
+ (if (and (featurep 'org-inlinetask)
+ (org-inlinetask-in-task-p))
+ (org-inlinetask-goto-beginning)
+ (org-back-to-heading-or-point-min t)))
+ ,@body)))
+
+(defun org-attach--commands-to-transient-specification ()
+ "Produces a transient menu specification from `org-attach-commands'."
+ `[["Select an Attachment Command:"
+ ,@(seq-map (lambda (item)
+ (pcase item
+ (`(,keys ,command ,docstring)
+ `(,(substring-no-properties (prin1-char (car keys)) 1)
+ ,docstring
+ (org-attach-at-destination (command-execute #',command))))))
+ org-attach-commands)]])
+
+(org-menu-define org-attach ()
"The dispatcher for attachment commands.
-Shows a list of commands and prompts for another key to execute a command."
- (interactive)
- (let (c marker)
- (when (eq major-mode 'org-agenda-mode)
- (setq marker (or (get-text-property (point) 'org-hd-marker)
- (get-text-property (point) 'org-marker)))
- (unless marker
- (error "No item in current line")))
- (org-with-point-at marker
- (let ((dir (org-attach-dir nil 'no-fs-check)))
- (if (and (featurep 'org-inlinetask)
- (not (org-inlinetask-in-task-p)))
- (org-with-limited-levels
- (org-back-to-heading-or-point-min t))
- (if (and (featurep 'org-inlinetask)
- (org-inlinetask-in-task-p))
- (org-inlinetask-goto-beginning)
- (org-back-to-heading-or-point-min t)))
- (save-excursion
- (save-window-excursion
- (unless org-attach-expert
- (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")
- (unless (and dir (file-directory-p dir))
- "\n(Not yet created)")
- "\n\n"
- (format "Select an Attachment Command:\n\n%s"
- (mapconcat
- (lambda (entry)
- (pcase entry
- (`((,key . ,_) ,_ ,docstring)
- (format "%c %s"
- key
- (replace-regexp-in-string "\n\\([\t ]*\\)"
- " "
- docstring
- nil nil 1)))
- (_
- (user-error
- "Invalid `org-attach-commands' item: %S"
- entry))))
- org-attach-commands
- "\n"))))
- (goto-char (point-min)))
- (org-fit-window-to-buffer (get-buffer-window "*Org Attach*"))
- (unwind-protect
- (let ((msg (format "Select command: [%s]"
- (concat (mapcar #'caar org-attach-commands)))))
- (message msg)
- (while (and (setq c (read-char-exclusive))
- (memq c '(?\C-n ?\C-p ?\C-v ?\M-v)))
- (org-scroll c t)))
- (when-let* ((window (get-buffer-window "*Org Attach*" t)))
- (quit-window 'kill window))
- (and (get-buffer "*Org Attach*") (kill-buffer "*Org Attach*")))))
- (let ((command (cl-some (lambda (entry)
- (and (memq c (nth 0 entry)) (nth 1 entry)))
- org-attach-commands)))
- (if (commandp command)
- (command-execute command)
- (error "No such attachment command: %c" c)))))))
+Shows a list of commands defined in `org-attach-commands' using `org-menu'."
+ :menu org-attach--commands-to-transient-specification
+ :default-action (org-attach-at-destination (command-execute #'org-attach-attach))
+ :override org-menu-attach-style-prompt)
;;;###autoload
(defun org-attach-dir (&optional create-if-not-exists-p no-fs-check)
--
2.52.0
