emacs-orgmode@gnu.org archives
 help / color / mirror / code / Atom feed
blob 3f37cb87a5c96a06bd8b87e5c961c487b80128b1 17234 bytes (raw)
name: contrib/lisp/org-toc.el 	 # note: path name is non-authoritative(*)

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
 
;;; org-toc.el --- Table of contents for Org-mode buffer

;; Copyright 2007-2012 Free Software Foundation, Inc.
;;
;; Author: Bastien Guerry <bzg AT gnu DOT org>
;; Keywords: Org table of contents
;; Homepage: http://www.cognition.ens.fr/~guerry/u/org-toc.el
;; Version: 0.8

;; This file is not part of GNU Emacs.

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program; if not, write to the Free Software
;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

;;; Commentary:

;; This library implements a browsable table of contents for Org files.

;; Put this file into your load-path and the following into your ~/.emacs:
;;   (require 'org-toc)

;;; Code:

(provide 'org-toc)
(eval-when-compile
  (require 'cl))

;;; Custom variables:
(defvar org-toc-base-buffer nil)
(defvar org-toc-columns-shown nil)
(defvar org-toc-odd-levels-only nil)
(defvar org-toc-config-alist nil)
(defvar org-toc-cycle-global-status nil)
(defalias 'org-show-table-of-contents 'org-toc-show)

(defgroup org-toc nil
  "Options concerning the browsable table of contents of Org-mode."
  :tag "Org TOC"
  :group 'org)

(defcustom org-toc-default-depth 1
  "Default depth when invoking `org-toc-show' without argument."
  :group 'org-toc
  :type '(choice
	  (const :tag "same as base buffer" nil)
	  (integer :tag "level")))

(defcustom org-toc-follow-mode nil
  "Non-nil means navigating through the table of contents will
move the point in the Org buffer accordingly."
  :group 'org-toc
  :type 'boolean)

(defcustom org-toc-info-mode nil
  "Non-nil means navigating through the table of contents will
show the properties for the current headline in the echo-area."
  :group 'org-toc
  :type 'boolean)

(defcustom org-toc-show-subtree-mode nil
  "Non-nil means show subtree when going to headline or following
it while browsing the table of contents."
  :group 'org-toc
  :type '(choice
	  (const :tag "show subtree" t)
	  (const :tag "show entry" nil)))

(defcustom org-toc-recenter-mode t
  "Non-nil means recenter the Org buffer when following the
headlines in the TOC buffer."
  :group 'org-toc
  :type 'boolean)

(defcustom org-toc-recenter 0
  "Where to recenter the Org buffer when unfolding a subtree.
This variable is only used when `org-toc-recenter-mode' is set to
'custom. A value >=1000 will call recenter with no arg."
  :group 'org-toc
  :type 'integer)

(defcustom org-toc-info-exclude '("ALLTAGS")
  "A list of excluded properties when displaying info in the
echo-area. The COLUMNS property is always exluded."
  :group 'org-toc
  :type 'lits)

;;; Org TOC mode:
(defvar org-toc-mode-map (make-sparse-keymap)
  "Keymap for `org-toc-mode'.")

(defun org-toc-mode ()
  "A major mode for browsing the table of contents of an Org buffer.

\\{org-toc-mode-map}"
  (interactive)
  (kill-all-local-variables)
  (use-local-map org-toc-mode-map)
  (setq mode-name "Org TOC")
  (setq major-mode 'org-toc-mode))

;; toggle modes
(define-key org-toc-mode-map "f" 'org-toc-follow-mode)
(define-key org-toc-mode-map "S" 'org-toc-show-subtree-mode)
(define-key org-toc-mode-map "s" 'org-toc-store-config)
(define-key org-toc-mode-map "g" 'org-toc-restore-config)
(define-key org-toc-mode-map "i" 'org-toc-info-mode)
(define-key org-toc-mode-map "r" 'org-toc-recenter-mode)

;; navigation keys
(define-key org-toc-mode-map "p" 'org-toc-previous)
(define-key org-toc-mode-map "n" 'org-toc-next)
(define-key org-toc-mode-map [(left)] 'org-toc-previous)
(define-key org-toc-mode-map [(right)] 'org-toc-next)
(define-key org-toc-mode-map [(up)] 'org-toc-previous)
(define-key org-toc-mode-map [(down)] 'org-toc-next)
(define-key org-toc-mode-map "1" (lambda() (interactive) (org-toc-show 1 (point))))
(define-key org-toc-mode-map "2" (lambda() (interactive) (org-toc-show 2 (point))))
(define-key org-toc-mode-map "3" (lambda() (interactive) (org-toc-show 3 (point))))
(define-key org-toc-mode-map "4" (lambda() (interactive) (org-toc-show 4 (point))))
(define-key org-toc-mode-map " " 'org-toc-goto)
(define-key org-toc-mode-map "q" 'org-toc-quit)
(define-key org-toc-mode-map "x" 'org-toc-quit)
;; go to the location and stay in the base buffer
(define-key org-toc-mode-map [(tab)] 'org-toc-jump)
(define-key org-toc-mode-map "v" 'org-toc-jump)
;; go to the location and delete other windows
(define-key org-toc-mode-map [(return)]
  (lambda() (interactive) (org-toc-jump t)))

;; special keys
(define-key org-toc-mode-map "c" 'org-toc-columns)
(define-key org-toc-mode-map "?" 'org-toc-help)
(define-key org-toc-mode-map ":" 'org-toc-cycle-subtree)
(define-key org-toc-mode-map "\C-c\C-o" 'org-open-at-point)
;; global cycling in the base buffer
(define-key org-toc-mode-map (kbd "C-S-<iso-lefttab>")
  'org-toc-cycle-base-buffer)
;; subtree cycling in the base buffer
(define-key org-toc-mode-map [(control tab)]
  (lambda() (interactive) (org-toc-goto nil t)))

;;; Toggle functions:
(defun org-toc-follow-mode ()
  "Toggle follow mode in a `org-toc-mode' buffer."
  (interactive)
  (setq org-toc-follow-mode (not org-toc-follow-mode))
  (message "Follow mode is %s"
	   (if org-toc-follow-mode "on" "off")))

(defun org-toc-info-mode ()
  "Toggle info mode in a `org-toc-mode' buffer."
  (interactive)
  (setq org-toc-info-mode (not org-toc-info-mode))
  (message "Info mode is %s"
	   (if org-toc-info-mode "on" "off")))

(defun org-toc-show-subtree-mode ()
  "Toggle show subtree mode in a `org-toc-mode' buffer."
  (interactive)
  (setq org-toc-show-subtree-mode (not org-toc-show-subtree-mode))
  (message "Show subtree mode is %s"
	   (if org-toc-show-subtree-mode "on" "off")))

(defun org-toc-recenter-mode (&optional line)
  "Toggle recenter mode in a `org-toc-mode' buffer. If LINE is
specified, then make `org-toc-recenter' use this value."
  (interactive "P")
  (setq org-toc-recenter-mode (not org-toc-recenter-mode))
  (when (numberp line)
    (setq org-toc-recenter-mode t)
    (setq org-toc-recenter line))
  (message "Recenter mode is %s"
	   (if org-toc-recenter-mode
	       (format "on, line %d" org-toc-recenter) "off")))

(defun org-toc-cycle-subtree ()
  "Locally cycle a headline through two states: 'children and
'folded"
  (interactive)
  (let ((beg (point))
	(end (save-excursion (end-of-line) (point)))
	(ov (car (overlays-at (point))))
	status)
    (if ov (setq status (overlay-get ov 'status))
      (setq ov (make-overlay beg end)))
    ;; change the folding status of this headline
    (cond ((or (null status) (eq status 'folded))
	   (show-children)
	   (message "CHILDREN")
	   (overlay-put ov 'status 'children))
	  ((eq status 'children)
	   (show-branches)
	   (message "BRANCHES")
	   (overlay-put ov 'status 'branches))
	  (t (hide-subtree)
	     (message "FOLDED")
	     (overlay-put ov 'status 'folded)))))

;;; Main show function:
;; FIXME name this org-before-first-heading-p?
(defun org-toc-before-first-heading-p ()
  "Before first heading?"
  (save-excursion
    (null (re-search-backward org-outline-regexp-bol nil t))))

;;;###autoload
(defun org-toc-show (&optional depth position)
  "Show the table of contents of the current Org-mode buffer."
  (interactive "P")
  (if (eq major-mode 'org-mode)
      (progn (setq org-toc-base-buffer (current-buffer))
	     (setq org-toc-odd-levels-only org-odd-levels-only))
    (if (eq major-mode 'org-toc-mode)
	(org-pop-to-buffer-same-window org-toc-base-buffer)
      (error "Not in an Org buffer")))
  ;; create the new window display
  (let ((pos (or position
		 (save-excursion
		   (if (org-toc-before-first-heading-p)
		       (progn (re-search-forward org-outline-regexp-bol nil t)
			      (match-beginning 0))
		     (point))))))
    (setq org-toc-cycle-global-status org-cycle-global-status)
    (delete-other-windows)
    (and (get-buffer "*org-toc*") (kill-buffer "*org-toc*"))
    (switch-to-buffer-other-window
     (make-indirect-buffer org-toc-base-buffer "*org-toc*"))
    ;; make content before 1st headline invisible
    (goto-char (point-min))
    (let* ((beg (point-min))
	   (end (and (re-search-forward "^\\*" nil t)
		     (1- (match-beginning 0))))
	   (ov (make-overlay beg end))
	   (help (format "Table of contents for %s (press ? for a quick help):\n"
			 (buffer-name org-toc-base-buffer))))
      (overlay-put ov 'invisible t)
      (overlay-put ov 'before-string help))
    ;; build the browsable TOC
    (cond (depth
	   (let* ((dpth (if org-toc-odd-levels-only
			    (1- (* depth 2)) depth)))
	     (org-content dpth)
	     (setq org-toc-cycle-global-status
		   `(org-content ,dpth))))
	   ((null org-toc-default-depth)
	    (if (eq org-toc-cycle-global-status 'overview)
		(progn (org-overview)
		       (setq org-cycle-global-status 'overview)
		       (run-hook-with-args 'org-cycle-hook 'overview))
	      (progn (org-overview)
		     ;; FIXME org-content to show only headlines?
		     (org-content)
		     (setq org-cycle-global-status 'contents)
		     (run-hook-with-args 'org-cycle-hook 'contents))))
	   (t (let* ((dpth0 org-toc-default-depth)
		     (dpth (if org-toc-odd-levels-only
			       (1- (* dpth0 2)) dpth0)))
		(org-content dpth)
		(setq org-toc-cycle-global-status
		      `(org-content ,dpth)))))
    (goto-char pos))
  (move-beginning-of-line nil)
  (org-toc-mode)
  (shrink-window-if-larger-than-buffer)
  (setq buffer-read-only t))

;;; Navigation functions:
(defun org-toc-goto (&optional jump cycle)
  "From Org TOC buffer, follow the targeted subtree in the Org window.
If JUMP is non-nil, go to the base buffer.
If JUMP is 'delete, go to the base buffer and delete other windows.
If CYCLE is non-nil, cycle the targeted subtree in the Org window."
  (interactive)
  (let ((pos (point))
	(toc-buf (current-buffer)))
    (switch-to-buffer-other-window org-toc-base-buffer)
    (goto-char pos)
    (if cycle (org-cycle)
      (progn (org-overview)
	     (if org-toc-show-subtree-mode
		 (org-show-subtree)
	       (org-show-entry))
	     (org-show-context)))
    (if org-toc-recenter-mode
	(if (>= org-toc-recenter 1000) (recenter)
	  (recenter org-toc-recenter)))
    (cond ((null jump)
	   (switch-to-buffer-other-window toc-buf))
	  ((eq jump 'delete)
	   (delete-other-windows)))))

(defun org-toc-cycle-base-buffer ()
  "Call `org-cycle' with a prefix argument in the base buffer."
  (interactive)
  (switch-to-buffer-other-window org-toc-base-buffer)
  (org-cycle t)
  (other-window 1))

(defun org-toc-jump (&optional delete)
  "From Org TOC buffer, jump to the targeted subtree in the Org window.
If DELETE is non-nil, delete other windows when in the Org buffer."
  (interactive "P")
  (if delete (org-toc-goto 'delete)
    (org-toc-goto t)))

(defun org-toc-previous ()
  "Go to the previous headline of the TOC."
  (interactive)
  (if (save-excursion
	  (beginning-of-line)
	  (re-search-backward "^\\*" nil t))
    (outline-previous-visible-heading 1)
    (message "No previous heading"))
  (if org-toc-info-mode (org-toc-info))
  (if org-toc-follow-mode (org-toc-goto)))

(defun org-toc-next ()
  "Go to the next headline of the TOC."
  (interactive)
  (outline-next-visible-heading 1)
  (if org-toc-info-mode (org-toc-info))
  (if org-toc-follow-mode (org-toc-goto)))

(defun org-toc-quit ()
  "Quit the current Org TOC buffer."
  (interactive)
  (kill-this-buffer)
  (other-window 1)
  (delete-other-windows))

;;; Special functions:
(defun org-toc-columns ()
  "Toggle columns view in the Org buffer from Org TOC."
  (interactive)
  (let ((indirect-buffer (current-buffer)))
    (org-pop-to-buffer-same-window org-toc-base-buffer)
    (if (not org-toc-columns-shown)
	(progn (org-columns)
	       (setq org-toc-columns-shown t))
      (progn (org-columns-remove-overlays)
	     (setq org-toc-columns-shown nil)))
    (org-pop-to-buffer-same-window indirect-buffer)))

(defun org-toc-info ()
  "Show properties of current subtree in the echo-area."
  (interactive)
  (let ((pos (point))
	(indirect-buffer (current-buffer))
	props prop msg)
    (org-pop-to-buffer-same-window org-toc-base-buffer)
    (goto-char pos)
    (setq props (org-entry-properties))
    (while (setq prop (pop props))
      (unless (or (equal (car prop) "COLUMNS")
		  (member (car prop) org-toc-info-exclude))
	(let ((p (car prop))
	      (v (cdr prop)))
	  (if (equal p "TAGS")
	      (setq v (mapconcat 'identity (split-string v ":" t) " ")))
	  (setq p (concat p ":"))
	  (add-text-properties 0 (length p) '(face org-special-keyword) p)
	  (setq msg (concat msg p " " v "  ")))))
    (org-pop-to-buffer-same-window indirect-buffer)
    (message msg)))

;;; Store and restore TOC configuration:
(defun org-toc-store-config ()
  "Store the current status of the tables of contents in
`org-toc-config-alist'."
  (interactive)
  (let ((file (buffer-file-name org-toc-base-buffer))
	(pos (point))
	(hlcfg (org-toc-get-headlines-status)))
    (setq org-toc-config-alist
	  (delete (assoc file org-toc-config-alist)
		  org-toc-config-alist))
    (add-to-list 'org-toc-config-alist
		 `(,file ,pos ,org-toc-cycle-global-status ,hlcfg))
    (message "TOC configuration saved: (%s)"
	     (if (listp org-toc-cycle-global-status)
		 (concat "org-content "
			 (number-to-string
			  (cadr org-toc-cycle-global-status)))
	       (symbol-name org-toc-cycle-global-status)))))

(defun org-toc-restore-config ()
  "Get the stored status in `org-toc-config-alist' and set the
current table of contents to it."
  (interactive)
  (let* ((file (buffer-file-name org-toc-base-buffer))
	 (conf (cdr (assoc file org-toc-config-alist)))
	 (pos (car conf))
	 (status (cadr conf))
	 (hlcfg (caddr conf)) hlcfg0 ov)
    (cond ((listp status)
	   (org-toc-show (cadr status) (point)))
	  ((eq status 'overview)
	   (org-overview)
	   (setq org-cycle-global-status 'overview)
	   (run-hook-with-args 'org-cycle-hook 'overview))
	  (t
	   (org-overview)
	   (org-content)
	   (setq org-cycle-global-status 'contents)
	   (run-hook-with-args 'org-cycle-hook 'contents)))
    (while (setq hlcfg0 (pop hlcfg))
      (save-excursion
	(goto-char (point-min))
	(when (search-forward (car hlcfg0) nil t)
	  (unless (overlays-at (match-beginning 0))
	    (setq ov (make-overlay (match-beginning 0)
				   (match-end 0))))
	  (cond ((eq (cdr hlcfg0) 'children)
		 (show-children)
		 (message "CHILDREN")
		 (overlay-put ov 'status 'children))
		((eq (cdr hlcfg0) 'branches)
		 (show-branches)
		 (message "BRANCHES")
		 (overlay-put ov 'status 'branches))))))
    (goto-char pos)
    (if org-toc-follow-mode (org-toc-goto))
    (message "Last TOC configuration restored")
    (sit-for 1)
    (if org-toc-info-mode (org-toc-info))))

(defun org-toc-get-headlines-status ()
  "Return an alist of headlines and their associated folding
status."
  (let (output ovs)
    (save-excursion
      (goto-char (point-min))
      (while (and (not (eobp))
		  (goto-char (next-overlay-change (point))))
	(when (looking-at org-outline-regexp-bol)
	  (add-to-list
	   'output
	   (cons (buffer-substring-no-properties
		  (match-beginning 0)
		  (save-excursion
		    (end-of-line) (point)))
		 (overlay-get
		  (car (overlays-at (point))) 'status))))))
    ;; return an alist like (("* Headline" . 'status))
    output))

;; In Org TOC buffer, hide headlines below the first level.
(defun org-toc-help ()
  "Display a quick help message in the echo-area for `org-toc-mode'."
  (interactive)
  (let ((st-start 0)
	(help-message
	 "\[space\]   show heading                     \[1-4\] hide headlines below this level
\[TAB\]     jump to heading                  \[f\]   toggle follow mode (currently %s)
\[return\]  jump and delete others windows   \[i\]   toggle info mode (currently %s)
\[S-TAB\]   cycle subtree (in Org)           \[S\]   toggle show subtree mode (currently %s)
\[C-S-TAB\] global cycle (in Org)            \[r\]   toggle recenter mode (currently %s)
\[:\]       cycle subtree (in TOC)           \[c\]   toggle column view (currently %s)
\[n/p\]     next/previous heading            \[s\]   save TOC configuration
\[q\]       quit the TOC                     \[g\]   restore last TOC configuration"))
    (while (string-match "\\[[^]]+\\]" help-message st-start)
      (add-text-properties (match-beginning 0)
                           (match-end 0) '(face bold) help-message)
      (setq st-start (match-end 0)))
  (message help-message
    (if org-toc-follow-mode "on" "off")
    (if org-toc-info-mode "on" "off")
    (if org-toc-show-subtree-mode "on" "off")
    (if org-toc-recenter-mode (format "on, line %s" org-toc-recenter) "off")
    (if org-toc-columns-shown "on" "off"))))

\f
;;;;##########################################################################
;;;;  User Options, Variables
;;;;##########################################################################

;;; org-toc.el ends here

debug log:

solving 3f37cb8 ...
found 3f37cb8 in https://git.savannah.gnu.org/cgit/emacs/org-mode.git

(*) Git path names are given by the tree(s) the blob belongs to.
    Blobs themselves have no identifier aside from the hash of its contents.^

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).