Re: [O] orgstruct-mode with custom headline prefix

[Carsten Dominik]

Hi Christopher,

I have trouble applying it, can you please send the patch as an attachments 
instead of inline, and make sure it is agains the current master?  Thanks.

- Carsten

On 31 jan. 2013, at 21:06, Christopher Schmidt <address@hidden> wrote:

> Bastien <address@hidden> 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  <address@hidden>
> 
>            * 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.
> --- 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.
> 
>    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/address@hidden (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:
> 
> <Mail Attachment>
>        Christopher


-- 
There is no unscripted life.  Only a badly scripted one. -- Brothers Bloom