From: Christopher Schmidt <christopher@ch.ristopher.com>
To: emacs-orgmode@gnu.org
Subject: Re: orgstruct-mode with custom headline prefix
Date: Thu, 31 Jan 2013 20:06:26 +0000 (GMT) [thread overview]
Message-ID: <87622d5d8e@ch.ristopher.com> (raw)
In-Reply-To: <87a9rplhue.fsf@bzg.ath.cx> (Bastien's message of "Thu, 31 Jan 2013 12:20:09 +0100")
[-- Attachment #1: Type: text/plain, Size: 1555 bytes --]
Bastien <bzg@altern.org> writes:
> PS: To make things clear: I'm confident the patch is good, but I will
> put it higher on my patch review process if I know the agenda does not
> slow down :)
Here is the patch. Now one just needs
;; Local Variables:
;; eval: (orgstruct-mode 1)
;; orgstruct-heading-prefix-regexp: ";;; "
;; End:
It cannot get any easier than this.
2013-01-31 Christopher Schmidt <christopher@ch.ristopher.com>
* org.el (org-cycle-global-status, org-cycle-subtree-status): Set
state property.
(org-heading-components): Use org-heading-regexp in
orgstruct-mode.
(orgstruct-heading-prefix-regexp, orgstruct-setup-hook): New
options.
(orgstruct-initialized): New variable.
(orgstruct-mode): Simplify implementation.
(orgstruct-setup): Simplify implementation. Translate keys to
their most general equivalent.
(orgstruct-make-binding): Generate index on the fly. Discard
alternative keys. Bind variables according to
orgstruct-heading-prefix-regexp.
(org-get-local-variables): Honour state property.
(org-run-like-in-org-mode): Do not override variables with
non-default values.
(org-forward-heading-same-level): Do not skip to headlines on
another level. Handle negative prefix argument correctly.
(org-backward-heading-same-level): Use
org-forward-heading-same-level.
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: Type: text/x-diff, Size: 16177 bytes --]
--- a/lisp/org.el
+++ b/lisp/org.el
@@ -6223,8 +6223,10 @@ and subscripts."
(defvar org-cycle-global-status nil)
(make-variable-buffer-local 'org-cycle-global-status)
+(put 'org-cycle-global-status 'org-state t)
(defvar org-cycle-subtree-status nil)
(make-variable-buffer-local 'org-cycle-subtree-status)
+(put 'org-cycle-subtree-status 'org-state t)
(defvar org-inlinetask-min-level)
@@ -7403,13 +7405,24 @@ This is a list with the following elements:
- the tags string, or nil."
(save-excursion
(org-back-to-heading t)
- (if (let (case-fold-search) (looking-at org-complex-heading-regexp))
- (list (length (match-string 1))
- (org-reduced-level (length (match-string 1)))
- (org-match-string-no-properties 2)
- (and (match-end 3) (aref (match-string 3) 2))
- (org-match-string-no-properties 4)
- (org-match-string-no-properties 5)))))
+ (if (let (case-fold-search)
+ (looking-at
+ (if orgstruct-mode
+ org-heading-regexp
+ org-complex-heading-regexp)))
+ (if orgstruct-mode
+ (list (length (match-string 1))
+ (org-reduced-level (length (match-string 1)))
+ nil
+ nil
+ (match-string 2)
+ nil)
+ (list (length (match-string 1))
+ (org-reduced-level (length (match-string 1)))
+ (org-match-string-no-properties 2)
+ (and (match-end 3) (aref (match-string 3) 2))
+ (org-match-string-no-properties 4)
+ (org-match-string-no-properties 5))))))
(defun org-get-entry ()
"Get the entry text, after heading, entire subtree."
@@ -8482,12 +8495,19 @@ 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.
-;; Another challenge is that the key binding for TAB can be tab or \C-i,
-;; likewise the binding for RET can be return or \C-m. Orgtbl-mode
-;; addresses this by checking explicitly for both bindings.
+(defcustom orgstruct-heading-prefix-regexp ""
+ "Regexp that matches the custom prefix of Org headlines in
+orgstruct(++)-mode."
+ :group 'org
+ :type 'string)
+;;;###autoload(put 'orgstruct-heading-prefix-regexp 'safe-local-variable 'stringp)
+
+(defcustom orgstruct-setup-hook nil
+ "Hook run after orgstruct-mode-map is filled."
+ :group 'org
+ :type 'hook)
-(defvar orgstruct-mode-map (make-sparse-keymap)
- "Keymap for the minor `orgstruct-mode'.")
+(defvar orgstruct-initialized nil)
(defvar org-local-vars nil
"List of local variables, for use by `orgstruct-mode'.")
@@ -8498,26 +8518,13 @@ If WITH-CASE is non-nil, the sorting will be case-sensitive."
This mode is for using Org-mode structure commands in other
modes. The following keys behave as if Org-mode were active, if
the cursor is on a headline, or on a plain list item (both as
-defined by Org-mode).
-
-M-up Move entry/item up
-M-down Move entry/item down
-M-left Promote
-M-right Demote
-M-S-up Move entry/item up
-M-S-down Move entry/item down
-M-S-left Promote subtree
-M-S-right Demote subtree
-M-q Fill paragraph and items like in Org-mode
-C-c ^ Sort entries
-C-c - Cycle list bullet
-TAB Cycle item visibility
-M-RET Insert new heading/item
-S-M-RET Insert new TODO heading / Checkbox item
-C-c C-c Set tags / toggle checkbox"
- nil " OrgStruct" nil
- (org-load-modules-maybe)
- (and (orgstruct-setup) (defun orgstruct-setup () nil)))
+defined by Org-mode)."
+ nil " OrgStruct" (make-sparse-keymap)
+ (when orgstruct-mode
+ (org-load-modules-maybe)
+ (unless orgstruct-initialized
+ (orgstruct-setup)
+ (setq orgstruct-initialized t))))
;;;###autoload
(defun turn-on-orgstruct ()
@@ -8568,104 +8575,96 @@ buffer. It will also recognize item context in multiline items."
(error "This key has no function outside structure elements"))
(defun orgstruct-setup ()
- "Setup orgstruct keymaps."
- (let ((nfunc 0)
- (bindings
- (list
- '([(meta up)] org-metaup)
- '([(meta down)] org-metadown)
- '([(meta left)] org-metaleft)
- '([(meta right)] org-metaright)
- '([(meta shift up)] org-shiftmetaup)
- '([(meta shift down)] org-shiftmetadown)
- '([(meta shift left)] org-shiftmetaleft)
- '([(meta shift right)] org-shiftmetaright)
- '([?\e (up)] org-metaup)
- '([?\e (down)] org-metadown)
- '([?\e (left)] org-metaleft)
- '([?\e (right)] org-metaright)
- '([?\e (shift up)] org-shiftmetaup)
- '([?\e (shift down)] org-shiftmetadown)
- '([?\e (shift left)] org-shiftmetaleft)
- '([?\e (shift right)] org-shiftmetaright)
- '([(shift up)] org-shiftup)
- '([(shift down)] org-shiftdown)
- '([(shift left)] org-shiftleft)
- '([(shift right)] org-shiftright)
- '("\C-c\C-c" org-ctrl-c-ctrl-c)
- '("\M-q" fill-paragraph)
- '("\C-c^" org-sort)
- '("\C-c-" org-cycle-list-bullet)))
- elt key fun cmd)
- (while (setq elt (pop bindings))
- (setq nfunc (1+ nfunc))
- (setq key (org-key (car elt))
- fun (nth 1 elt)
- cmd (orgstruct-make-binding fun nfunc key))
- (org-defkey orgstruct-mode-map key cmd))
-
- ;; Prevent an error for users who forgot to make autoloads
- (require 'org-element)
-
- ;; Special treatment needed for TAB and RET
- (org-defkey orgstruct-mode-map [(tab)]
- (orgstruct-make-binding 'org-cycle 102 [(tab)] "\C-i"))
- (org-defkey orgstruct-mode-map "\C-i"
- (orgstruct-make-binding 'org-cycle 103 "\C-i" [(tab)]))
-
- (org-defkey orgstruct-mode-map "\M-\C-m"
- (orgstruct-make-binding 'org-insert-heading 105
- "\M-\C-m" [(meta return)]))
- (org-defkey orgstruct-mode-map [(meta return)]
- (orgstruct-make-binding 'org-insert-heading 106
- [(meta return)] "\M-\C-m"))
-
- (org-defkey orgstruct-mode-map [(shift meta return)]
- (orgstruct-make-binding 'org-insert-todo-heading 107
- [(meta return)] "\M-\C-m"))
-
- (org-defkey orgstruct-mode-map "\e\C-m"
- (orgstruct-make-binding 'org-insert-heading 108
- "\e\C-m" [?\e (return)]))
- (org-defkey orgstruct-mode-map [?\e (return)]
- (orgstruct-make-binding 'org-insert-heading 109
- [?\e (return)] "\e\C-m"))
- (org-defkey orgstruct-mode-map [?\e (shift return)]
- (orgstruct-make-binding 'org-insert-todo-heading 110
- [?\e (return)] "\e\C-m"))
-
- (unless org-local-vars
- (setq org-local-vars (org-get-local-variables)))
-
- t))
-
-(defun orgstruct-make-binding (fun n &rest keys)
+ "Setup orgstruct keymap."
+ (dolist (f
+ '("org-meta"
+ "org-shiftmeta"
+ org-shifttab
+ org-backward-element
+ org-backward-heading-same-level
+ org-ctrl-c-ret
+ 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)))
+ (dolist (rep '(("<tab>" . "TAB")
+ ("<ret>" . "RET")
+ ("<esc>" . "ESC")
+ ("<del>" . "DEL")))
+ (setq binding (kbd (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))
+ (org-defkey orgstruct-mode-map
+ binding
+ (orgstruct-make-binding f binding)))))))
+ (run-hooks 'orgstruct-setup-hook))
+
+(defun orgstruct-make-binding (fun key)
"Create a function for binding in the structure minor mode.
-FUN is the command to call inside a table. N is used to create a unique
-command name. KEYS are keys that should be checked in for a command
-to execute outside of tables."
- (eval
- (list 'defun
- (intern (concat "orgstruct-hijacker-command-" (int-to-string n)))
- '(arg)
- (concat "In Structure, run `" (symbol-name fun) "'.\n"
- "Outside of structure, run the binding of `"
- (mapconcat (lambda (x) (format "%s" x)) keys "' or `")
- "'.")
- '(interactive "p")
- (list 'if
- `(org-context-p 'headline 'item
- (and orgstruct-is-++
- ,(and (memq fun '(org-insert-heading org-insert-todo-heading)) t)
- 'item-body))
- (list 'org-run-like-in-org-mode (list 'quote fun))
- (list 'let '(orgstruct-mode)
- (list 'call-interactively
- (append '(or)
- (mapcar (lambda (k)
- (list 'key-binding k))
- keys)
- '('orgstruct-error))))))))
+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."
+ (let ((name (concat "orgstruct-hijacker-" (symbol-name fun))))
+ (let ((nname name)
+ (i 0))
+ (while (fboundp (intern nname))
+ (setq nname (format "%s-%d" name (setq i (1+ i)))))
+ (setq name (intern nname)))
+ (eval
+ `(defun ,name (arg)
+ ,(concat "In Structure, run `" (symbol-name fun) "'.\n"
+ "Outside of structure, run the binding of `"
+ (key-description key) "'.")
+ (interactive "p")
+ (unless
+ (let* ((org-heading-regexp
+ (concat "^"
+ orgstruct-heading-prefix-regexp
+ "\\(\\*+\\)\\(?: +\\(.*?\\)\\)?[ ]*$"))
+ (org-outline-regexp
+ (concat orgstruct-heading-prefix-regexp "\\*+ "))
+ (outline-regexp org-outline-regexp)
+ (org-outline-regexp-bol
+ (concat "^" org-outline-regexp)))
+ (when (org-context-p 'headline 'item
+ ,(when (memq fun '(org-insert-heading))
+ '(when orgstruct-is-++
+ 'item-body)))
+ (org-run-like-in-org-mode ',fun)
+ t))
+ (let ((binding (let ((orgstruct-mode)) (key-binding ,key))))
+ (if (keymapp binding)
+ (set-temporary-overlay-map binding)
+ (call-interactively
+ (or binding 'orgstruct-error)))))))
+ name))
(defun org-contextualize-keys (alist contexts)
"Return valid elements in ALIST depending on CONTEXTS.
@@ -8766,17 +8765,18 @@ Possible values in the list of contexts are `table', `headline', and `item'."
(setq varlist (buffer-local-variables)))
(kill-buffer "*Org tmp*")
(delq nil
- (mapcar
- (lambda (x)
- (setq x
- (if (symbolp x)
- (list x)
- (list (car x) (list 'quote (cdr x)))))
- (if (string-match
- "^\\(org-\\|orgtbl-\\|outline-\\|comment-\\|paragraph-\\|auto-fill\\|normal-auto-fill\\|fill-paragraph\\|indent-\\)"
- (symbol-name (car x)))
- x nil))
- varlist))))
+ (mapcar
+ (lambda (x)
+ (setq x
+ (if (symbolp x)
+ (list x)
+ (list (car x) (cdr x))))
+ (if (and (not (get (car x) 'org-state))
+ (string-match
+ "^\\(org-\\|orgtbl-\\|outline-\\|comment-\\|paragraph-\\|auto-fill\\|normal-auto-fill\\|fill-paragraph\\|indent-\\)"
+ (symbol-name (car x))))
+ x nil))
+ varlist))))
(defun org-clone-local-variables (from-buffer &optional regexp)
"Clone local variables from FROM-BUFFER.
@@ -8799,8 +8799,14 @@ call CMD."
(org-load-modules-maybe)
(unless org-local-vars
(setq org-local-vars (org-get-local-variables)))
- (eval (list 'let org-local-vars
- (list 'call-interactively (list 'quote cmd)))))
+ (let (symbols values)
+ (dolist (var org-local-vars)
+ (when (eq (symbol-value (car var))
+ (default-value (car var)))
+ (push (car var) symbols)
+ (push (cadr var) values)))
+ (progv symbols values
+ (call-interactively cmd))))
;;;; Archiving
@@ -22602,46 +22608,43 @@ clocking lines, and drawers."
(point)))
(defun org-forward-heading-same-level (arg &optional invisible-ok)
- "Move forward to the arg'th subheading at same level as this one.
+ "Move forward to the ARG'th subheading at same level as this one.
Stop at the first and last subheadings of a superior heading.
Normally this only looks at visible headings, but when INVISIBLE-OK is
non-nil it will also look at invisible ones."
(interactive "p")
(if (not (ignore-errors (org-back-to-heading invisible-ok)))
- (outline-next-heading)
+ (if (and arg (< arg 0))
+ (goto-char (point-min))
+ (outline-next-heading))
(org-at-heading-p)
- (let* ((level (- (match-end 0) (match-beginning 0) 1))
- (re (format "^\\*\\{1,%d\\} " level))
- l)
- (forward-char 1)
- (while (> arg 0)
- (while (and (re-search-forward re nil 'move)
- (setq l (- (match-end 0) (match-beginning 0) 1))
- (= l level)
- (not invisible-ok)
- (progn (backward-char 1) (outline-invisible-p)))
- (if (< l level) (setq arg 1)))
- (setq arg (1- arg)))
- (beginning-of-line 1))))
+ (let ((level (- (match-end 0) (match-beginning 0) 1))
+ (f (if (and arg (< arg 0))
+ 're-search-backward
+ 're-search-forward))
+ (count (if arg (abs arg) 1))
+ (result (point)))
+ (forward-char (if (and arg (< arg 0)) -1 1))
+ (while (and (> count 0)
+ (funcall f org-outline-regexp-bol nil 'move))
+ (let ((l (- (match-end 0) (match-beginning 0) 1)))
+ (cond ((< l level) (setq count 0))
+ ((and (= l level)
+ (or invisible-ok
+ (progn
+ (goto-char (line-beginning-position))
+ (not (outline-invisible-p)))))
+ (setq count (1- count))
+ (when (eq l level)
+ (setq result (point)))))))
+ (goto-char result))
+ (beginning-of-line 1)))
(defun org-backward-heading-same-level (arg &optional invisible-ok)
- "Move backward to the arg'th subheading at same level as this one.
+ "Move backward to the ARG'th subheading at same level as this one.
Stop at the first and last subheadings of a superior heading."
(interactive "p")
- (if (not (ignore-errors (org-back-to-heading)))
- (goto-char (point-min))
- (org-at-heading-p)
- (let* ((level (- (match-end 0) (match-beginning 0) 1))
- (re (format "^\\*\\{1,%d\\} " level))
- l)
- (while (> arg 0)
- (while (and (re-search-backward re nil 'move)
- (setq l (- (match-end 0) (match-beginning 0) 1))
- (= l level)
- (not invisible-ok)
- (outline-invisible-p))
- (if (< l level) (setq arg 1)))
- (setq arg (1- arg))))))
+ (org-forward-heading-same-level (if arg (- arg) -1) invisible-ok))
(defun org-forward-element ()
"Move forward by one element.
[-- Attachment #3: Type: text/plain, Size: 4644 bytes --]
set -e
git show-ref HEAD
git stash
make &> /dev/null
emacs -q --batch --eval "(progn (add-to-list 'load-path \"~/.emacs.d/apps/org-mode/lisp\") (find-file \"~/test-agenda.org\") (org-agenda-file-to-front) (profiler-start 'cpu+mem) (let ((f (float-time))) (org-agenda-list) (profiler-report) (message \"================\n%s\n\n\" (- (float-time) f))) (princ (buffer-string)))"
git stash pop
make &> /dev/null
emacs -q --batch --eval "(progn (add-to-list 'load-path \"~/.emacs.d/apps/org-mode/lisp\") (find-file \"~/test-agenda.org\") (org-agenda-file-to-front) (profiler-start 'cpu+mem) (let ((f (float-time))) (org-agenda-list) (profiler-report) (message \"================\n%s\n\n\" (- (float-time) f))) (princ (buffer-string)))"
a2febd210182d9e1a37b0d7fd9ee007a10abc4bc refs/remotes/origin/HEAD
Saved working directory and index state WIP on master: a2febd2 Merge branch 'maint'
HEAD is now at a2febd2 Merge branch 'maint'
OVERVIEW
Setting `org-agenda-files' temporarily since "emacs -q" would overwrite customizations
File added to front of agenda file list
CPU and memory profiler started
================
12.207549810409546
+ normal-top-level 46,533,611 74%
+ command-line-1 6,385,759 10%
+ command-line 5,800,077 9%
+ eval 2,639,778 4%
+ progn 690,611 1%
+ let 70,947 0%
+ apply 20,536 0%
+ org-agenda-get-sexps 12,332 0%
+ load-with-code-conversion 8,188 0%
+ profiler-calltree-walk 8,188 0%
+ org-agenda-prepare 6,482 0%
+ byte-code 4,272 0%
+ diary-font-lock-keywords 4,144 0%
+ org-agenda-list 1,114 0%
+ file-truename 1,100 0%
+ load 1,040 0%
# On branch master
# Changes not staged for commit:
# (use "git add <file>..." to update what will be committed)
# (use "git checkout -- <file>..." to discard changes in working directory)
#
# modified: lisp/org.el
#
no changes added to commit (use "git add" and/or "git commit -a")
Dropped refs/stash@{0} (a8007c5e99e8481d82ec8303c75069e150a81874)
OVERVIEW
Setting `org-agenda-files' temporarily since "emacs -q" would overwrite customizations
File added to front of agenda file list
CPU and memory profiler started
================
12.091503858566284
+ normal-top-level 45,399,311 73%
+ command-line-1 6,522,990 10%
+ command-line 5,875,736 9%
+ eval 3,803,175 6%
+ progn 316,014 0%
+ let 84,388 0%
+ apply 16,376 0%
+ org-agenda-get-sexps 8,188 0%
+ load-with-code-conversion 8,188 0%
+ profiler-calltree-walk 8,188 0%
+ profiler-report-setup-buffer 8,188 0%
+ org-agenda-list 4,296 0%
+ diary-font-lock-keywords 4,144 0%
+ org-agenda-get-day-entries 4,144 0%
+ require 3,120 0%
+ org-agenda-prepare 2,338 0%
+ file-truename 2,156 0%
+ tramp-completion-file-name-handler 1,040 0%
+ byte-code 104 0%
I generated test-agenda.org using this snippet:
[-- Attachment #4: Type: application/emacs-lisp, Size: 871 bytes --]
[-- Attachment #5: Type: text/plain, Size: 21 bytes --]
Christopher
next prev parent reply other threads:[~2013-01-31 20:06 UTC|newest]
Thread overview: 26+ messages / expand[flat|nested] mbox.gz Atom feed top
2013-01-28 17:15 orgstruct-mode with custom headline prefix Christopher Schmidt
2013-01-28 23:22 ` Samuel Wales
2013-01-31 7:35 ` Christopher Schmidt
2013-01-31 7:45 ` Bastien
2013-01-31 8:21 ` Christopher Schmidt
2013-01-31 8:39 ` Bastien
2013-01-31 9:00 ` Christopher Schmidt
2013-01-31 11:20 ` Bastien
2013-01-31 20:06 ` Christopher Schmidt [this message]
2013-01-31 20:12 ` Christopher Schmidt
2013-01-31 20:24 ` Thorsten Jolitz
2013-02-01 16:20 ` Carsten Dominik
2013-02-10 19:11 ` Christopher Schmidt
2013-02-11 15:28 ` Bastien
2013-02-12 19:04 ` Achim Gratz
2013-02-12 20:47 ` Christopher Schmidt
2013-02-12 21:32 ` Bastien
2013-02-13 9:10 ` Christopher Schmidt
2013-02-13 9:43 ` Sebastien Vauban
2013-02-13 20:03 ` Achim Gratz
2013-02-19 10:18 ` Dr Stephen J Eglen
2013-02-22 13:51 ` Bastien
2013-02-26 14:59 ` Stephen Eglen
2013-02-26 16:02 ` Bastien
2013-02-26 18:10 ` Stephen Eglen
2013-02-26 16:55 ` Christopher Schmidt
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://www.orgmode.org/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=87622d5d8e@ch.ristopher.com \
--to=christopher@ch.ristopher.com \
--cc=emacs-orgmode@gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/emacs/org-mode.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).