From mboxrd@z Thu Jan 1 00:00:00 1970 From: Christopher Schmidt Subject: Re: orgstruct-mode with custom headline prefix Date: Thu, 31 Jan 2013 20:06:26 +0000 (GMT) Message-ID: <87622d5d8e@ch.ristopher.com> References: <87vcah6xf5@ch.ristopher.com> <8738xh4xfr@ch.ristopher.com> <87y5f994ni.fsf@bzg.ath.cx> <87pq0l3gr2@ch.ristopher.com> <878v79925v.fsf@bzg.ath.cx> <87k3qt3exu@ch.ristopher.com> <87a9rplhue.fsf@bzg.ath.cx> Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" Return-path: Received: from eggs.gnu.org ([208.118.235.92]:48539) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1U10P5-00023A-1y for emacs-orgmode@gnu.org; Thu, 31 Jan 2013 15:06:39 -0500 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1U10P0-0003IQ-7N for emacs-orgmode@gnu.org; Thu, 31 Jan 2013 15:06:34 -0500 Received: from ristopher.com ([146.185.21.93]:52602 helo=saturn.ch.ristopher.com) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1U10Oz-0003IA-N0 for emacs-orgmode@gnu.org; Thu, 31 Jan 2013 15:06:30 -0500 In-Reply-To: <87a9rplhue.fsf@bzg.ath.cx> (Bastien's message of "Thu, 31 Jan 2013 12:20:09 +0100") List-Id: "General discussions about Org-mode." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: emacs-orgmode-bounces+geo-emacs-orgmode=m.gmane.org@gnu.org Sender: emacs-orgmode-bounces+geo-emacs-orgmode=m.gmane.org@gnu.org To: emacs-orgmode@gnu.org --=-=-= Content-Type: text/plain Bastien 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 * 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. --=-=-= Content-Type: text/x-diff Content-Disposition: inline --- 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") + ("" . "RET") + ("" . "ESC") + ("" . "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. --=-=-= Content-Type: text/plain 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 ..." to update what will be committed) # (use "git checkout -- ..." 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: --=-=-= Content-Type: application/emacs-lisp Content-Disposition: inline Content-Transfer-Encoding: quoted-printable (defun generate-string (length) (let ((result "")) (dotimes (i length) (cl-callf concat result (char-to-string (+ ?a (random (- ?z ?a)) )))) result)) (with-current-buffer (get-buffer-create "*dub*") (erase-buffer) (dotimes (i 5000) (insert "* " (if (eq (random 10) 0) "TODO " "") (generate-string 10)) (let ((tags)) (dotimes (i (random 5)) (push (generate-string 5) tags)) (when tags (insert " :" (mapconcat 'identity tags ":") ":"))) (when (eq (random 3) 0) (insert "\n" (cl-case (random 3) (0 "SCHEDULED: ") (1 "DEADLINE: ") (2 "")) "<2001-01-01 Tue" (if (eq (random 3) 0) (concat " .+10w") "") ">")) (insert "\n") (when (eq (random 3) 0) (dotimes (random 10) (insert (generate-string (random 80)) "\n"))))) --=-=-= Content-Type: text/plain Christopher --=-=-=--