Browse Source

org.el: Disable {pro,de}motion commands in orgstruct-mode if orgstruct-heading-prefix-regexp is non-nil

* org.el (orgstruct-heading-prefix-regexp): Change default
value to nil.
(orgstruct-error): Use user-error if available.
(orgstruct-setup): Disable bindings of {pro,de}motion commands
if orgstruct-heading-prefix-regexp is non-nil.  Always use
org-outline-level.
(orgstruct-make-binding): New argument
DISABLE-WHEN-HEADING-PREFIX.
Christopher Schmidt 6 years ago
parent
commit
03b1edf3c1
1 changed files with 106 additions and 81 deletions
  1. 106 81
      lisp/org.el

+ 106 - 81
lisp/org.el

@@ -8658,7 +8658,7 @@ If WITH-CASE is non-nil, the sorting will be case-sensitive."
 ;; command.  There might be problems if any of the keys is otherwise
 ;; used as a prefix key.
 
-(defcustom orgstruct-heading-prefix-regexp ""
+(defcustom orgstruct-heading-prefix-regexp nil
   "Regexp that matches the custom prefix of Org headlines in
 orgstruct(++)-mode."
   :group 'org
@@ -8739,76 +8739,87 @@ buffer.  It will also recognize item context in multiline items."
 (defun orgstruct-error ()
   "Error when there is no default binding for a structure key."
   (interactive)
-  (error "This key has no function outside structure elements"))
+  (funcall (if (fboundp 'user-error)
+	       'user-error
+	     'error)
+	   "This key has no function outside structure elements"))
 
 (defun orgstruct-setup ()
   "Setup orgstruct keymap."
-  (dolist (f
-           '("org-meta"
-             "org-shift"
-             "org-shiftmeta"
-             org-shifttab
-             org-backward-element
-             org-backward-heading-same-level
-             org-ctrl-c-ret
-	     org-ctrl-c-minus
-	     org-ctrl-c-star
-             org-cycle
-             org-forward-heading-same-level
-             org-insert-heading
-             org-insert-heading-respect-content
-             org-kill-note-or-show-branches
-             org-mark-subtree
-             org-narrow-to-subtree
-             org-promote-subtree
-             org-reveal
-             org-show-subtree
-             org-sort
-             org-up-element
-             outline-demote
-             outline-next-visible-heading
-             outline-previous-visible-heading
-             outline-promote
-             outline-up-heading
-             show-children))
-    (dolist (f (if (stringp f)
-                   (let ((flist))
-                     (dolist (postfix
-                              '("-return" "tab" "left" "right" "up" "down")
-                              flist)
-                       (let ((f (intern (concat f postfix))))
-                         (when (fboundp f)
-                           (push f flist)))))
-                 (list f)))
-      (dolist (binding (nconc (where-is-internal f org-mode-map)
-                              (where-is-internal f outline-mode-map)))
-        ;; TODO use local-function-key-map
-        (dolist (rep '(("<tab>" . "TAB")
-                       ("<return>" . "RET")
-                       ("<escape>" . "ESC")
-                       ("<delete>" . "DEL")))
-          (setq binding (read-kbd-macro (replace-regexp-in-string
-					 (regexp-quote (car rep))
-					 (cdr rep)
-					 (key-description binding)))))
-        (let ((key (lookup-key orgstruct-mode-map binding)))
-          (when (or (not key) (numberp key))
-	    (condition-case nil
-		(org-defkey orgstruct-mode-map
-			    binding
-			    (orgstruct-make-binding f binding))
-	      (error nil)))))))
+  (dolist (cell '((org-demote . t)
+		  (org-metaleft . t)
+		  (org-metaright . t)
+		  (org-promote . t)
+		  (org-shiftmetaleft . t)
+		  (org-shiftmetaright . t)
+		  org-backward-element
+		  org-backward-heading-same-level
+		  org-ctrl-c-ret
+		  org-ctrl-c-minus
+		  org-ctrl-c-star
+		  org-cycle
+		  org-forward-heading-same-level
+		  org-insert-heading
+		  org-insert-heading-respect-content
+		  org-kill-note-or-show-branches
+		  org-mark-subtree
+		  org-meta-return
+		  org-metadown
+		  org-metaup
+		  org-narrow-to-subtree
+		  org-promote-subtree
+		  org-reveal
+		  org-shiftdown
+		  org-shiftleft
+		  org-shiftmetadown
+		  org-shiftmetaup
+		  org-shiftright
+		  org-shifttab
+		  org-shifttab
+		  org-shiftup
+		  org-show-subtree
+		  org-sort
+		  org-up-element
+		  outline-demote
+		  outline-next-visible-heading
+		  outline-previous-visible-heading
+		  outline-promote
+		  outline-up-heading
+		  show-children))
+    (let ((f (or (car-safe cell) cell))
+	  (disable-when-heading-prefix (cdr-safe cell)))
+      (when (fboundp f)
+	(dolist (binding (nconc (where-is-internal f org-mode-map)
+				(where-is-internal f outline-mode-map)))
+	  ;; TODO use local-function-key-map
+	  (dolist (rep '(("<tab>" . "TAB")
+			 ("<return>" . "RET")
+			 ("<escape>" . "ESC")
+			 ("<delete>" . "DEL")))
+	    (setq binding (read-kbd-macro (replace-regexp-in-string
+					   (regexp-quote (car rep))
+					   (cdr rep)
+					   (key-description binding)))))
+	  (let ((key (lookup-key orgstruct-mode-map binding)))
+	    (when (or (not key) (numberp key))
+	      (condition-case nil
+		  (org-defkey orgstruct-mode-map
+			      binding
+			      (orgstruct-make-binding f binding disable-when-heading-prefix))
+		(error nil))))))))
   (run-hooks 'orgstruct-setup-hook))
 
-(defun orgstruct-make-binding (fun key)
+(defun orgstruct-make-binding (fun key disable-when-heading-prefix)
   "Create a function for binding in the structure minor mode.
 FUN is the command to call inside a table.  KEY is the key that
-should be checked in for a command to execute outside of tables."
+should be checked in for a command to execute outside of tables.
+Non-nil DISABLE-WHEN-HEADING-PREFIX means to disable the command
+if `orgstruct-heading-prefix-regexp' is non-nil."
   (let ((name (concat "orgstruct-hijacker-" (symbol-name fun))))
     (let ((nname name)
-          (i 0))
+	  (i 0))
       (while (fboundp (intern nname))
-        (setq nname (format "%s-%d" name (setq i (1+ i)))))
+	(setq nname (format "%s-%d" name (setq i (1+ i)))))
       (setq name (intern nname)))
     (eval
      (let ((bindings '((org-heading-regexp
@@ -8821,31 +8832,45 @@ should be checked in for a command to execute outside of tables."
 			(concat "^" org-outline-regexp))
 		       (outline-regexp org-outline-regexp)
 		       (outline-heading-end-regexp "\n")
-		       (outline-level 'outline-level)
+		       (outline-level 'org-outline-level)
 		       (outline-heading-alist))))
        `(defun ,name (arg)
 	  ,(concat "In Structure, run `" (symbol-name fun) "'.\n"
 		   "Outside of structure, run the binding of `"
-		   (key-description key) "'.")
+		   (key-description key) "'."
+		   (when disable-when-heading-prefix
+		     (concat
+		      "\nIf `orgstruct-heading-prefix-regexp' is non-nil, this command will always fall\n"
+		      "back to the default binding due to limitations of Org's implementation of\n"
+		      "`" (symbol-name fun) "'.")))
 	  (interactive "p")
-	  (unless
-	      (let* ,bindings
-		(when (org-context-p 'headline 'item
-				     ,(when (memq fun '(org-insert-heading))
-					'(when orgstruct-is-++
-					   'item-body)))
-		  (org-run-like-in-org-mode
-		   (lambda ()
-		     (interactive)
-		     (let* ,bindings
-		       (call-interactively ',fun))))
-		  t))
-	    (let* ((orgstruct-mode)
-		   (binding (key-binding ,key)))
-	      (if (keymapp binding)
-		  (set-temporary-overlay-map binding)
-		(call-interactively
-		 (or binding 'orgstruct-error))))))))
+	  (let* ((disable
+		  ,(when disable-when-heading-prefix
+		     '(and orgstruct-heading-prefix-regexp
+			   (not (string= orgstruct-heading-prefix-regexp "")))))
+		 (fallback
+		  (or disable
+		      (not
+		       (let* ,bindings
+			 (org-context-p 'headline 'item
+					,(when (memq fun '(org-insert-heading))
+					   '(when orgstruct-is-++
+					      'item-body))))))))
+	    (if fallback
+		(let* ((orgstruct-mode)
+		       (binding (key-binding ,key)))
+		  (if (keymapp binding)
+		      (set-temporary-overlay-map binding)
+		    (let ((func (or binding
+				    (unless disable
+				      'orgstruct-error))))
+		      (when func
+			(call-interactively func)))))
+	      (org-run-like-in-org-mode
+	       (lambda ()
+		 (interactive)
+		 (let* ,bindings
+		   (call-interactively ',fun)))))))))
     name))
 
 (defun org-contextualize-keys (alist contexts)