org-capture: Fix freeze when capture templates are ill-defined
* lisp/org-capture.el (org-mks): Do not freeze when there is a missing step in the key hierarchy. Fix docstring. Refactor code for clarity. Reported-by: Roland Everaert <reveatwork@gmail.com> <http://permalink.gmane.org/gmane.emacs.orgmode/111716>
This commit is contained in:
Nicolas Goaziou
parent
f2a5104e45
commit
8194e7b09d
|
|
@ -1437,6 +1437,7 @@ Use PREFIX as a prefix for the name of the indirect buffer."
|
||||||
|
|
||||||
(defun org-mks (table title &optional prompt specials)
|
(defun org-mks (table title &optional prompt specials)
|
||||||
"Select a member of an alist with multiple keys.
|
"Select a member of an alist with multiple keys.
|
||||||
|
|
||||||
TABLE is the alist which should contain entries where the car is a string.
|
TABLE is the alist which should contain entries where the car is a string.
|
||||||
There should be two types of entries.
|
There should be two types of entries.
|
||||||
|
|
||||||
|
|
@ -1444,7 +1445,7 @@ There should be two types of entries.
|
||||||
This indicates that `a' is a prefix key for multi-letter selection, and
|
This indicates that `a' is a prefix key for multi-letter selection, and
|
||||||
that there are entries following with keys like \"ab\", \"ax\"...
|
that there are entries following with keys like \"ab\", \"ax\"...
|
||||||
|
|
||||||
2. Selectable members must have more than two elements, with the first
|
2. Select-able members must have more than two elements, with the first
|
||||||
being the string of keys that lead to selecting it, and the second a
|
being the string of keys that lead to selecting it, and the second a
|
||||||
short description string of the item.
|
short description string of the item.
|
||||||
|
|
||||||
|
|
@ -1455,84 +1456,72 @@ When you press a prefix key, the commands (and maybe further prefixes)
|
||||||
under this key will be shown and offered for selection.
|
under this key will be shown and offered for selection.
|
||||||
|
|
||||||
TITLE will be placed over the selection in the temporary buffer,
|
TITLE will be placed over the selection in the temporary buffer,
|
||||||
PROMPT will be used when prompting for a key. SPECIAL is an alist with
|
PROMPT will be used when prompting for a key. SPECIAL is an
|
||||||
also (\"key\" \"description\") entries. When one of these is selection,
|
alist with (\"key\" \"description\") entries. When one of these
|
||||||
only the bare key is returned."
|
is selected, only the bare key is returned."
|
||||||
(setq prompt (or prompt "Select: "))
|
(save-window-excursion
|
||||||
(let (tbl orig-table dkey ddesc des-keys allowed-keys
|
(let ((inhibit-quit t)
|
||||||
current prefix rtn re pressed buffer (inhibit-quit t))
|
(buffer (org-switch-to-buffer-other-window "*Org Select*"))
|
||||||
(save-window-excursion
|
(prompt (or prompt "Select: "))
|
||||||
(setq buffer (org-switch-to-buffer-other-window "*Org Select*"))
|
current)
|
||||||
(setq orig-table table)
|
(unwind-protect
|
||||||
(catch 'exit
|
(catch 'exit
|
||||||
(while t
|
(while t
|
||||||
(erase-buffer)
|
(erase-buffer)
|
||||||
(insert title "\n\n")
|
(insert title "\n\n")
|
||||||
(setq tbl table
|
(let ((des-keys nil)
|
||||||
des-keys nil
|
(allowed-keys '("\C-g"))
|
||||||
allowed-keys nil
|
(cursor-type nil))
|
||||||
cursor-type nil)
|
;; Populate allowed keys and descriptions keys
|
||||||
(setq prefix (if current (concat current " ") ""))
|
;; available with CURRENT selector.
|
||||||
(while tbl
|
(let ((re (format "\\`%s\\(.\\)\\'"
|
||||||
(cond
|
(if current (regexp-quote current) "")))
|
||||||
((and (= 2 (length (car tbl))) (= (length (caar tbl)) 1))
|
(prefix (if current (concat current " ") "")))
|
||||||
;; This is a description on this level
|
(dolist (entry table)
|
||||||
(setq dkey (caar tbl) ddesc (cl-cadar tbl))
|
(pcase entry
|
||||||
(pop tbl)
|
;; Description.
|
||||||
(push dkey des-keys)
|
(`(,(and key (pred (string-match re))) ,desc)
|
||||||
(push dkey allowed-keys)
|
(let ((k (match-string 1 key)))
|
||||||
(insert prefix "[" dkey "]" "..." " " ddesc "..." "\n")
|
(push k des-keys)
|
||||||
;; Skip keys which are below this prefix
|
(push k allowed-keys)
|
||||||
(setq re (concat "\\`" (regexp-quote dkey)))
|
(insert prefix "[" k "]" "..." " " desc "..." "\n")))
|
||||||
(let (case-fold-search)
|
;; Usable entry.
|
||||||
(while (and tbl (string-match re (caar tbl))) (pop tbl))))
|
(`(,(and key (pred (string-match re))) ,desc . ,_)
|
||||||
((= 2 (length (car tbl)))
|
(let ((k (match-string 1 key)))
|
||||||
;; Not yet a usable description, skip it
|
(insert prefix "[" k "]" " " desc "\n")
|
||||||
)
|
(push k allowed-keys)))
|
||||||
(t
|
(_ nil))))
|
||||||
;; usable entry on this level
|
;; Insert special entries, if any.
|
||||||
(insert prefix "[" (caar tbl) "]" " " (nth 1 (car tbl)) "\n")
|
(when specials
|
||||||
(push (caar tbl) allowed-keys)
|
(insert "----------------------------------------------------\
|
||||||
(pop tbl))))
|
---------------------------\n")
|
||||||
(when specials
|
(pcase-dolist (`(,key ,description) specials)
|
||||||
(insert "-------------------------------------------------------------------------------\n")
|
(insert (format "[%s] %s\n" key description))
|
||||||
(let ((sp specials))
|
(push key allowed-keys)))
|
||||||
(while sp
|
;; Display UI and let user select an entry or
|
||||||
(insert (format "[%s] %s\n"
|
;; a sub-level prefix.
|
||||||
(caar sp) (nth 1 (car sp))))
|
(goto-char (point-min))
|
||||||
(push (caar sp) allowed-keys)
|
(unless (pos-visible-in-window-p (point-max))
|
||||||
(pop sp))))
|
(org-fit-window-to-buffer))
|
||||||
(push "\C-g" allowed-keys)
|
(message prompt)
|
||||||
(goto-char (point-min))
|
(let ((pressed (char-to-string (read-char-exclusive))))
|
||||||
(if (not (pos-visible-in-window-p (point-max)))
|
(while (not (member pressed allowed-keys))
|
||||||
(org-fit-window-to-buffer))
|
(message "Invalid key `%s'" pressed) (sit-for 1)
|
||||||
(message prompt)
|
(message prompt)
|
||||||
(setq pressed (char-to-string (read-char-exclusive)))
|
(setq pressed (char-to-string (read-char-exclusive))))
|
||||||
(while (not (member pressed allowed-keys))
|
(cond
|
||||||
(message "Invalid key `%s'" pressed) (sit-for 1)
|
((equal pressed "\C-g") (user-error "Abort"))
|
||||||
(message prompt)
|
;; Selection is a prefix: open a new menu.
|
||||||
(setq pressed (char-to-string (read-char-exclusive))))
|
((member pressed des-keys)
|
||||||
(when (equal pressed "\C-g")
|
(setq current (concat current pressed)))
|
||||||
(kill-buffer buffer)
|
;; Selection matches an association: return it.
|
||||||
(user-error "Abort"))
|
((let ((entry (assoc pressed table)))
|
||||||
(when (and (not (assoc pressed table))
|
(and entry (throw 'exit entry))))
|
||||||
(not (member pressed des-keys))
|
;; Selection matches a special entry: return the
|
||||||
(assoc pressed specials))
|
;; selection prefix.
|
||||||
(throw 'exit (setq rtn pressed)))
|
((assoc pressed specials) (throw 'exit pressed))
|
||||||
(unless (member pressed des-keys)
|
(t (error "No entry available")))))))
|
||||||
(throw 'exit (setq rtn (rassoc (cdr (assoc pressed table))
|
(when buffer (kill-buffer buffer))))))
|
||||||
orig-table))))
|
|
||||||
(setq current (concat current pressed))
|
|
||||||
(setq table (mapcar
|
|
||||||
(lambda (x)
|
|
||||||
(if (and (> (length (car x)) 1)
|
|
||||||
(equal (substring (car x) 0 1) pressed))
|
|
||||||
(cons (substring (car x) 1) (cdr x))
|
|
||||||
nil))
|
|
||||||
table))
|
|
||||||
(setq table (remove nil table)))))
|
|
||||||
(when buffer (kill-buffer buffer))
|
|
||||||
rtn))
|
|
||||||
|
|
||||||
;;; The template code
|
;;; The template code
|
||||||
(defun org-capture-select-template (&optional keys)
|
(defun org-capture-select-template (&optional keys)
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue