Mention `read-file-name-completion-ignore-case'.
[emacs.git] / lisp / allout.el
blob903574e4aded0b6fd905c3fe5c4a3c6dfb371114
1 ;;; allout.el --- extensive outline mode for use alone and with other modes
3 ;; Copyright (C) 1992, 93, 94, 2001, 02, 2004 Free Software Foundation, Inc.
5 ;; Author: Ken Manheimer <klm@zope.com>
6 ;; Maintainer: Ken Manheimer <klm@zope.com>
7 ;; Created: Dec 1991 - first release to usenet
8 ;; Keywords: outlines mode wp languages
10 ;; This file is part of GNU Emacs.
12 ;; GNU Emacs is free software; you can redistribute it and/or modify
13 ;; it under the terms of the GNU General Public License as published by
14 ;; the Free Software Foundation; either version 2, or (at your option)
15 ;; any later version.
17 ;; GNU Emacs is distributed in the hope that it will be useful,
18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 ;; GNU General Public License for more details.
22 ;; You should have received a copy of the GNU General Public License
23 ;; along with GNU Emacs; see the file COPYING. If not, write to the
24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
25 ;; Boston, MA 02111-1307, USA.
27 ;;; Commentary:
29 ;; Allout outline mode provides extensive outline formatting and
30 ;; and manipulation beyond standard emacs outline mode. It provides
31 ;; for structured editing of outlines, as well as navigation and
32 ;; exposure. It also provides for syntax-sensitive text like
33 ;; programming languages. (For an example, see the allout code
34 ;; itself, which is organized in ;; an outline framework.)
36 ;; In addition to outline navigation and exposure, allout includes:
38 ;; - topic-oriented repositioning, cut, and paste
39 ;; - integral outline exposure-layout
40 ;; - incremental search with dynamic exposure and reconcealment of hidden text
41 ;; - automatic topic-number maintenance
42 ;; - "Hot-spot" operation, for single-keystroke maneuvering and
43 ;; exposure control. (See the `allout-mode' docstring.)
45 ;; and many other features.
47 ;; The outline menubar additions provide quick reference to many of
48 ;; the features, and see the docstring of the function `allout-init'
49 ;; for instructions on priming your Emacs session for automatic
50 ;; activation of `allout-mode'.
52 ;; See the docstring of the variables `allout-layout' and
53 ;; `allout-auto-activation' for details on automatic activation of
54 ;; allout `allout-mode' as a minor mode. (It has changed since allout
55 ;; 3.x, for those of you that depend on the old method.)
57 ;; Note - the lines beginning with `;;;_' are outline topic headers.
58 ;; Just `ESC-x eval-current-buffer' to give it a whirl.
60 ;; Ken Manheimer klm@zope.com
62 ;;; Code:
64 ;;;_* Provide
65 (provide 'allout)
67 ;;;_* USER CUSTOMIZATION VARIABLES:
68 (defgroup allout nil
69 "Extensive outline mode for use alone and with other modes."
70 :prefix "allout-"
71 :group 'editing)
73 ;;;_ + Layout, Mode, and Topic Header Configuration
75 ;;;_ = allout-auto-activation
76 (defcustom allout-auto-activation nil
77 "*Regulates auto-activation modality of allout outlines - see `allout-init'.
79 Setq-default by `allout-init' to regulate whether or not allout
80 outline mode is automatically activated when the buffer-specific
81 variable `allout-layout' is non-nil, and whether or not the layout
82 dictated by `allout-layout' should be imposed on mode activation.
84 With value t, auto-mode-activation and auto-layout are enabled.
85 \(This also depends on `allout-find-file-hook' being installed in
86 `find-file-hook', which is also done by `allout-init'.)
88 With value `ask', auto-mode-activation is enabled, and endorsement for
89 performing auto-layout is asked of the user each time.
91 With value `activate', only auto-mode-activation is enabled,
92 auto-layout is not.
94 With value nil, neither auto-mode-activation nor auto-layout are
95 enabled.
97 See the docstring for `allout-init' for the proper interface to
98 this variable."
99 :type '(choice (const :tag "On" t)
100 (const :tag "Ask about layout" "ask")
101 (const :tag "Mode only" "activate")
102 (const :tag "Off" nil))
103 :group 'allout)
104 ;;;_ = allout-layout
105 (defvar allout-layout nil
106 "*Layout specification and provisional mode trigger for allout outlines.
108 Buffer-specific.
110 A list value specifies a default layout for the current buffer, to be
111 applied upon activation of `allout-mode'. Any non-nil value will
112 automatically trigger `allout-mode', provided `allout-init'
113 has been called to enable it.
115 See the docstring for `allout-init' for details on setting up for
116 auto-mode-activation, and for `allout-expose-topic' for the format of
117 the layout specification.
119 You can associate a particular outline layout with a file by setting
120 this var via the file's local variables. For example, the following
121 lines at the bottom of an Emacs Lisp file:
123 ;;;Local variables:
124 ;;;allout-layout: \(0 : -1 -1 0)
125 ;;;End:
127 will, modulo the above-mentioned conditions, cause the mode to be
128 activated when the file is visited, followed by the equivalent of
129 `\(allout-expose-topic 0 : -1 -1 0)'. \(This is the layout used for
130 the allout.el, itself.)
132 Also, allout's mode-specific provisions will make topic prefixes default
133 to the comment-start string, if any, of the language of the file. This
134 is modulo the setting of `allout-use-mode-specific-leader', which see.")
135 (make-variable-buffer-local 'allout-layout)
136 ;;;_ = allout-show-bodies
137 (defcustom allout-show-bodies nil
138 "*If non-nil, show entire body when exposing a topic, rather than
139 just the header."
140 :type 'boolean
141 :group 'allout)
142 (make-variable-buffer-local 'allout-show-bodies)
144 ;;;_ = allout-header-prefix
145 (defcustom allout-header-prefix "."
146 "*Leading string which helps distinguish topic headers.
148 Outline topic header lines are identified by a leading topic
149 header prefix, which mostly have the value of this var at their front.
150 \(Level 1 topics are exceptions. They consist of only a single
151 character, which is typically set to the `allout-primary-bullet'. Many
152 outlines start at level 2 to avoid this discrepancy."
153 :type 'string
154 :group 'allout)
155 (make-variable-buffer-local 'allout-header-prefix)
156 ;;;_ = allout-primary-bullet
157 (defcustom allout-primary-bullet "*"
158 "Bullet used for top-level outline topics.
160 Outline topic header lines are identified by a leading topic header
161 prefix, which is concluded by bullets that includes the value of this
162 var and the respective allout-*-bullets-string vars.
164 The value of an asterisk (`*') provides for backwards compatibility
165 with the original Emacs outline mode. See `allout-plain-bullets-string'
166 and `allout-distinctive-bullets-string' for the range of available
167 bullets."
168 :type 'string
169 :group 'allout)
170 (make-variable-buffer-local 'allout-primary-bullet)
171 ;;;_ = allout-plain-bullets-string
172 (defcustom allout-plain-bullets-string ".:,;"
173 "*The bullets normally used in outline topic prefixes.
175 See `allout-distinctive-bullets-string' for the other kind of
176 bullets.
178 DO NOT include the close-square-bracket, `]', as a bullet.
180 Outline mode has to be reactivated in order for changes to the value
181 of this var to take effect."
182 :type 'string
183 :group 'allout)
184 (make-variable-buffer-local 'allout-plain-bullets-string)
185 ;;;_ = allout-distinctive-bullets-string
186 (defcustom allout-distinctive-bullets-string "*+-=>([{}&!?#%\"X@$~_\\"
187 "*Persistent outline header bullets used to distinguish special topics.
189 These bullets are used to distinguish topics from the run-of-the-mill
190 ones. They are not used in the standard topic headers created by
191 the topic-opening, shifting, and rebulleting \(eg, on topic shift,
192 topic paste, blanket rebulleting) routines, but are offered among the
193 choices for rebulleting. They are not altered by the above automatic
194 rebulleting, so they can be used to characterize topics, eg:
196 `?' question topics
197 `\(' parenthetic comment \(with a matching close paren inside)
198 `[' meta-note \(with a matching close ] inside)
199 `\"' a quote
200 `=' value settings
201 `~' \"more or less\"
203 ... just for example. (`#' typically has a special meaning to the
204 software, according to the value of `allout-numbered-bullet'.)
206 See `allout-plain-bullets-string' for the selection of
207 alternating bullets.
209 You must run `set-allout-regexp' in order for outline mode to
210 reconcile to changes of this value.
212 DO NOT include the close-square-bracket, `]', on either of the bullet
213 strings."
214 :type 'string
215 :group 'allout)
216 (make-variable-buffer-local 'allout-distinctive-bullets-string)
218 ;;;_ = allout-use-mode-specific-leader
219 (defcustom allout-use-mode-specific-leader t
220 "*When non-nil, use mode-specific topic-header prefixes.
222 Allout outline mode will use the mode-specific `allout-mode-leaders'
223 and/or comment-start string, if any, to lead the topic prefix string,
224 so topic headers look like comments in the programming language.
226 String values are used as they stand.
228 Value t means to first check for assoc value in `allout-mode-leaders'
229 alist, then use comment-start string, if any, then use default \(`.').
230 \(See note about use of comment-start strings, below.)
232 Set to the symbol for either of `allout-mode-leaders' or
233 `comment-start' to use only one of them, respectively.
235 Value nil means to always use the default \(`.').
237 comment-start strings that do not end in spaces are tripled, and an
238 `_' underscore is tacked on the end, to distinguish them from regular
239 comment strings. comment-start strings that do end in spaces are not
240 tripled, but an underscore is substituted for the space. [This
241 presumes that the space is for appearance, not comment syntax. You
242 can use `allout-mode-leaders' to override this behavior, when
243 incorrect.]"
244 :type '(choice (const t) (const nil) string
245 (const allout-mode-leaders)
246 (const comment-start))
247 :group 'allout)
248 ;;;_ = allout-mode-leaders
249 (defvar allout-mode-leaders '()
250 "Specific allout-prefix leading strings per major modes.
252 Entries will be used instead or in lieu of mode-specific
253 comment-start strings. See also `allout-use-mode-specific-leader'.
255 If you're constructing a string that will comment-out outline
256 structuring so it can be included in program code, append an extra
257 character, like an \"_\" underscore, to distinguish the lead string
258 from regular comments that start at bol.")
260 ;;;_ = allout-old-style-prefixes
261 (defcustom allout-old-style-prefixes nil
262 "*When non-nil, use only old-and-crusty `outline-mode' `*' topic prefixes.
264 Non-nil restricts the topic creation and modification
265 functions to asterix-padded prefixes, so they look exactly
266 like the original Emacs-outline style prefixes.
268 Whatever the setting of this variable, both old and new style prefixes
269 are always respected by the topic maneuvering functions."
270 :type 'boolean
271 :group 'allout)
272 (make-variable-buffer-local 'allout-old-style-prefixes)
273 ;;;_ = allout-stylish-prefixes - alternating bullets
274 (defcustom allout-stylish-prefixes t
275 "*Do fancy stuff with topic prefix bullets according to level, etc.
277 Non-nil enables topic creation, modification, and repositioning
278 functions to vary the topic bullet char (the char that marks the topic
279 depth) just preceding the start of the topic text) according to level.
280 Otherwise, only asterisks (`*') and distinctive bullets are used.
282 This is how an outline can look (but sans indentation) with stylish
283 prefixes:
285 * Top level
286 .* A topic
287 . + One level 3 subtopic
288 . . One level 4 subtopic
289 . . A second 4 subtopic
290 . + Another level 3 subtopic
291 . #1 A numbered level 4 subtopic
292 . #2 Another
293 . ! Another level 4 subtopic with a different distinctive bullet
294 . #4 And another numbered level 4 subtopic
296 This would be an outline with stylish prefixes inhibited (but the
297 numbered and other distinctive bullets retained):
299 * Top level
300 .* A topic
301 . * One level 3 subtopic
302 . * One level 4 subtopic
303 . * A second 4 subtopic
304 . * Another level 3 subtopic
305 . #1 A numbered level 4 subtopic
306 . #2 Another
307 . ! Another level 4 subtopic with a different distinctive bullet
308 . #4 And another numbered level 4 subtopic
310 Stylish and constant prefixes (as well as old-style prefixes) are
311 always respected by the topic maneuvering functions, regardless of
312 this variable setting.
314 The setting of this var is not relevant when `allout-old-style-prefixes'
315 is non-nil."
316 :type 'boolean
317 :group 'allout)
318 (make-variable-buffer-local 'allout-stylish-prefixes)
320 ;;;_ = allout-numbered-bullet
321 (defcustom allout-numbered-bullet "#"
322 "*String designating bullet of topics that have auto-numbering; nil for none.
324 Topics having this bullet have automatic maintenance of a sibling
325 sequence-number tacked on, just after the bullet. Conventionally set
326 to \"#\", you can set it to a bullet of your choice. A nil value
327 disables numbering maintenance."
328 :type '(choice (const nil) string)
329 :group 'allout)
330 (make-variable-buffer-local 'allout-numbered-bullet)
331 ;;;_ = allout-file-xref-bullet
332 (defcustom allout-file-xref-bullet "@"
333 "*Bullet signifying file cross-references, for `allout-resolve-xref'.
335 Set this var to the bullet you want to use for file cross-references."
336 :type '(choice (const nil) string)
337 :group 'allout)
339 ;;;_ = allout-presentation-padding
340 (defcustom allout-presentation-padding 2
341 "*Presentation-format white-space padding factor, for greater indent."
342 :type 'integer
343 :group 'allout)
345 (make-variable-buffer-local 'allout-presentation-padding)
347 ;;;_ = allout-abbreviate-flattened-numbering
348 (defcustom allout-abbreviate-flattened-numbering nil
349 "*If non-nil, `allout-flatten-exposed-to-buffer' abbreviates topic
350 numbers to minimal amount with some context. Otherwise, entire
351 numbers are always used."
352 :type 'boolean
353 :group 'allout)
355 ;;;_ + LaTeX formatting
356 ;;;_ - allout-number-pages
357 (defcustom allout-number-pages nil
358 "*Non-nil turns on page numbering for LaTeX formatting of an outline."
359 :type 'boolean
360 :group 'allout)
361 ;;;_ - allout-label-style
362 (defcustom allout-label-style "\\large\\bf"
363 "*Font and size of labels for LaTeX formatting of an outline."
364 :type 'string
365 :group 'allout)
366 ;;;_ - allout-head-line-style
367 (defcustom allout-head-line-style "\\large\\sl "
368 "*Font and size of entries for LaTeX formatting of an outline."
369 :type 'string
370 :group 'allout)
371 ;;;_ - allout-body-line-style
372 (defcustom allout-body-line-style " "
373 "*Font and size of entries for LaTeX formatting of an outline."
374 :type 'string
375 :group 'allout)
376 ;;;_ - allout-title-style
377 (defcustom allout-title-style "\\Large\\bf"
378 "*Font and size of titles for LaTeX formatting of an outline."
379 :type 'string
380 :group 'allout)
381 ;;;_ - allout-title
382 (defcustom allout-title '(or buffer-file-name (current-buffer-name))
383 "*Expression to be evaluated to determine the title for LaTeX
384 formatted copy."
385 :type 'sexp
386 :group 'allout)
387 ;;;_ - allout-line-skip
388 (defcustom allout-line-skip ".05cm"
389 "*Space between lines for LaTeX formatting of an outline."
390 :type 'string
391 :group 'allout)
392 ;;;_ - allout-indent
393 (defcustom allout-indent ".3cm"
394 "*LaTeX formatted depth-indent spacing."
395 :type 'string
396 :group 'allout)
398 ;;;_ + Miscellaneous customization
400 ;;;_ = allout-command-prefix
401 (defcustom allout-command-prefix "\C-c"
402 "*Key sequence to be used as prefix for outline mode command key bindings."
403 :type 'string
404 :group 'allout)
406 ;;;_ = allout-keybindings-list
407 ;;; You have to reactivate allout-mode - `(allout-mode t)' - to
408 ;;; institute changes to this var.
409 (defvar allout-keybindings-list ()
410 "*List of `allout-mode' key / function bindings, for `allout-mode-map'.
412 String or vector key will be prefaced with `allout-command-prefix',
413 unless optional third, non-nil element is present.")
414 (setq allout-keybindings-list
416 ; Motion commands:
417 ("\C-n" allout-next-visible-heading)
418 ("\C-p" allout-previous-visible-heading)
419 ("\C-u" allout-up-current-level)
420 ("\C-f" allout-forward-current-level)
421 ("\C-b" allout-backward-current-level)
422 ("\C-a" allout-beginning-of-current-entry)
423 ("\C-e" allout-end-of-current-entry)
424 ; Exposure commands:
425 ("\C-i" allout-show-children)
426 ("\C-s" allout-show-current-subtree)
427 ("\C-h" allout-hide-current-subtree)
428 ("\C-o" allout-show-current-entry)
429 ("!" allout-show-all)
430 ; Alteration commands:
431 (" " allout-open-sibtopic)
432 ("." allout-open-subtopic)
433 ("," allout-open-supertopic)
434 ("'" allout-shift-in)
435 (">" allout-shift-in)
436 ("<" allout-shift-out)
437 ("\C-m" allout-rebullet-topic)
438 ("*" allout-rebullet-current-heading)
439 ("#" allout-number-siblings)
440 ("\C-k" allout-kill-line t)
441 ("\C-y" allout-yank t)
442 ("\M-y" allout-yank-pop t)
443 ("\C-k" allout-kill-topic)
444 ; Miscellaneous commands:
445 ;([?\C-\ ] allout-mark-topic)
446 ("@" allout-resolve-xref)
447 ("=c" allout-copy-exposed-to-buffer)
448 ("=i" allout-indented-exposed-to-buffer)
449 ("=t" allout-latexify-exposed)
450 ("=p" allout-flatten-exposed-to-buffer)))
452 ;;;_ = allout-isearch-dynamic-expose
453 (defcustom allout-isearch-dynamic-expose t
454 "*Non-nil enable dynamic exposure of hidden incremental-search
455 targets as they're encountered."
456 :type 'boolean
457 :group 'allout)
458 (make-variable-buffer-local 'allout-isearch-dynamic-expose)
460 ;;;_ = allout-use-hanging-indents
461 (defcustom allout-use-hanging-indents t
462 "*If non-nil, topic body text auto-indent defaults to indent of the header.
463 Ie, it is indented to be just past the header prefix. This is
464 relevant mostly for use with indented-text-mode, or other situations
465 where auto-fill occurs.
467 \[This feature no longer depends in any way on the `filladapt.el'
468 lisp-archive package.\]"
469 :type 'boolean
470 :group 'allout)
471 (make-variable-buffer-local 'allout-use-hanging-indents)
473 ;;;_ = allout-reindent-bodies
474 (defcustom allout-reindent-bodies (if allout-use-hanging-indents
475 'text)
476 "*Non-nil enables auto-adjust of topic body hanging indent with depth shifts.
478 When active, topic body lines that are indented even with or beyond
479 their topic header are reindented to correspond with depth shifts of
480 the header.
482 A value of t enables reindent in non-programming-code buffers, ie
483 those that do not have the variable `comment-start' set. A value of
484 `force' enables reindent whether or not `comment-start' is set."
485 :type '(choice (const nil) (const t) (const text) (const force))
486 :group 'allout)
488 (make-variable-buffer-local 'allout-reindent-bodies)
490 ;;;_ = allout-inhibit-protection
491 (defcustom allout-inhibit-protection nil
492 "*Non-nil disables warnings and confirmation-checks for concealed-text edits.
494 Outline mode uses Emacs change-triggered functions to detect unruly
495 changes to concealed regions. Set this var non-nil to disable the
496 protection, potentially increasing text-entry responsiveness a bit.
498 This var takes effect at `allout-mode' activation, so you may have to
499 deactivate and then reactivate the mode if you want to toggle the
500 behavior."
501 :type 'boolean
502 :group 'allout)
504 ;;;_* CODE - no user customizations below.
506 ;;;_ #1 Internal Outline Formatting and Configuration
507 ;;;_ : Version
508 ;;;_ = allout-version
509 (defvar allout-version
510 (let ((rcs-rev "$Revision: 1.49 $"))
511 (condition-case err
512 (save-match-data
513 (string-match "Revision: \\([0-9]+\\.[0-9]+\\)" rcs-rev)
514 (substring rcs-rev (match-beginning 1) (match-end 1)))
515 ('error rcs-rev)))
516 "Revision number of currently loaded outline package. \(allout.el)")
517 ;;;_ > allout-version
518 (defun allout-version (&optional here)
519 "Return string describing the loaded outline version."
520 (interactive "P")
521 (let ((msg (concat "Allout Outline Mode v " allout-version)))
522 (if here (insert msg))
523 (message "%s" msg)
524 msg))
525 ;;;_ : Topic header format
526 ;;;_ = allout-regexp
527 (defvar allout-regexp ""
528 "*Regular expression to match the beginning of a heading line.
530 Any line whose beginning matches this regexp is considered a
531 heading. This var is set according to the user configuration vars
532 by `set-allout-regexp'.")
533 (make-variable-buffer-local 'allout-regexp)
534 ;;;_ = allout-bullets-string
535 (defvar allout-bullets-string ""
536 "A string dictating the valid set of outline topic bullets.
538 This var should *not* be set by the user - it is set by `set-allout-regexp',
539 and is produced from the elements of `allout-plain-bullets-string'
540 and `allout-distinctive-bullets-string'.")
541 (make-variable-buffer-local 'allout-bullets-string)
542 ;;;_ = allout-bullets-string-len
543 (defvar allout-bullets-string-len 0
544 "Length of current buffers' `allout-plain-bullets-string'.")
545 (make-variable-buffer-local 'allout-bullets-string-len)
546 ;;;_ = allout-line-boundary-regexp
547 (defvar allout-line-boundary-regexp ()
548 "`allout-regexp' with outline style beginning-of-line anchor.
550 \(Ie, C-j, *or* C-m, for prefixes of hidden topics). This is properly
551 set when `allout-regexp' is produced by `set-allout-regexp', so
552 that (match-beginning 2) and (match-end 2) delimit the prefix.")
553 (make-variable-buffer-local 'allout-line-boundary-regexp)
554 ;;;_ = allout-bob-regexp
555 (defvar allout-bob-regexp ()
556 "Like `allout-line-boundary-regexp', for headers at beginning of buffer.
557 \(match-beginning 2) and \(match-end 2) delimit the prefix.")
558 (make-variable-buffer-local 'allout-bob-regexp)
559 ;;;_ = allout-header-subtraction
560 (defvar allout-header-subtraction (1- (length allout-header-prefix))
561 "Allout-header prefix length to subtract when computing topic depth.")
562 (make-variable-buffer-local 'allout-header-subtraction)
563 ;;;_ = allout-plain-bullets-string-len
564 (defvar allout-plain-bullets-string-len (length allout-plain-bullets-string)
565 "Length of `allout-plain-bullets-string', updated by `set-allout-regexp'.")
566 (make-variable-buffer-local 'allout-plain-bullets-string-len)
569 ;;;_ X allout-reset-header-lead (header-lead)
570 (defun allout-reset-header-lead (header-lead)
571 "*Reset the leading string used to identify topic headers."
572 (interactive "sNew lead string: ")
573 (setq allout-header-prefix header-lead)
574 (setq allout-header-subtraction (1- (length allout-header-prefix)))
575 (set-allout-regexp))
576 ;;;_ X allout-lead-with-comment-string (header-lead)
577 (defun allout-lead-with-comment-string (&optional header-lead)
578 "*Set the topic-header leading string to specified string.
580 Useful when for encapsulating outline structure in programming
581 language comments. Returns the leading string."
583 (interactive "P")
584 (if (not (stringp header-lead))
585 (setq header-lead (read-string
586 "String prefix for topic headers: ")))
587 (setq allout-reindent-bodies nil)
588 (allout-reset-header-lead header-lead)
589 header-lead)
590 ;;;_ > allout-infer-header-lead ()
591 (defun allout-infer-header-lead ()
592 "Determine appropriate `allout-header-prefix'.
594 Works according to settings of:
596 `comment-start'
597 `allout-header-prefix' (default)
598 `allout-use-mode-specific-leader'
599 and `allout-mode-leaders'.
601 Apply this via \(re)activation of `allout-mode', rather than
602 invoking it directly."
603 (let* ((use-leader (and (boundp 'allout-use-mode-specific-leader)
604 (if (or (stringp allout-use-mode-specific-leader)
605 (memq allout-use-mode-specific-leader
606 '(allout-mode-leaders
607 comment-start
608 t)))
609 allout-use-mode-specific-leader
610 ;; Oops - garbled value, equate with effect of 't:
611 t)))
612 (leader
613 (cond
614 ((not use-leader) nil)
615 ;; Use the explicitly designated leader:
616 ((stringp use-leader) use-leader)
617 (t (or (and (memq use-leader '(t allout-mode-leaders))
618 ;; Get it from outline mode leaders?
619 (cdr (assq major-mode allout-mode-leaders)))
620 ;; ... didn't get from allout-mode-leaders...
621 (and (memq use-leader '(t comment-start))
622 comment-start
623 ;; Use comment-start, maybe tripled, and with
624 ;; underscore:
625 (concat
626 (if (string= " "
627 (substring comment-start
628 (1- (length comment-start))))
629 ;; Use comment-start, sans trailing space:
630 (substring comment-start 0 -1)
631 (concat comment-start comment-start comment-start))
632 ;; ... and append underscore, whichever:
633 "_")))))))
634 (if (not leader)
636 (if (string= leader allout-header-prefix)
637 nil ; no change, nothing to do.
638 (setq allout-header-prefix leader)
639 allout-header-prefix))))
640 ;;;_ > allout-infer-body-reindent ()
641 (defun allout-infer-body-reindent ()
642 "Determine proper setting for `allout-reindent-bodies'.
644 Depends on default setting of `allout-reindent-bodies' \(which see)
645 and presence of setting for `comment-start', to tell whether the
646 file is programming code."
647 (if (and allout-reindent-bodies
648 comment-start
649 (not (eq 'force allout-reindent-bodies)))
650 (setq allout-reindent-bodies nil)))
651 ;;;_ > set-allout-regexp ()
652 (defun set-allout-regexp ()
653 "Generate proper topic-header regexp form for outline functions.
655 Works with respect to `allout-plain-bullets-string' and
656 `allout-distinctive-bullets-string'."
658 (interactive)
659 ;; Derive allout-bullets-string from user configured components:
660 (setq allout-bullets-string "")
661 (let ((strings (list 'allout-plain-bullets-string
662 'allout-distinctive-bullets-string
663 'allout-primary-bullet))
664 cur-string
665 cur-len
666 cur-char
667 cur-char-string
668 index
669 new-string)
670 (while strings
671 (setq new-string "") (setq index 0)
672 (setq cur-len (length (setq cur-string (symbol-value (car strings)))))
673 (while (< index cur-len)
674 (setq cur-char (aref cur-string index))
675 (setq allout-bullets-string
676 (concat allout-bullets-string
677 (cond
678 ; Single dash would denote a
679 ; sequence, repeated denotes
680 ; a dash:
681 ((eq cur-char ?-) "--")
682 ; literal close-square-bracket
683 ; doesn't work right in the
684 ; expr, exclude it:
685 ((eq cur-char ?\]) "")
686 (t (regexp-quote (char-to-string cur-char))))))
687 (setq index (1+ index)))
688 (setq strings (cdr strings)))
690 ;; Derive next for repeated use in allout-pending-bullet:
691 (setq allout-plain-bullets-string-len (length allout-plain-bullets-string))
692 (setq allout-header-subtraction (1- (length allout-header-prefix)))
693 ;; Produce the new allout-regexp:
694 (setq allout-regexp (concat "\\(\\"
695 allout-header-prefix
696 "[ \t]*["
697 allout-bullets-string
698 "]\\)\\|\\"
699 allout-primary-bullet
700 "+\\|\^l"))
701 (setq allout-line-boundary-regexp
702 (concat "\\([\n\r]\\)\\(" allout-regexp "\\)"))
703 (setq allout-bob-regexp
704 (concat "\\(\\`\\)\\(" allout-regexp "\\)"))
706 ;;;_ : Key bindings
707 ;;;_ = allout-mode-map
708 (defvar allout-mode-map nil "Keybindings for (allout) outline minor mode.")
709 ;;;_ > produce-allout-mode-map (keymap-alist &optional base-map)
710 (defun produce-allout-mode-map (keymap-list &optional base-map)
711 "Produce keymap for use as allout-mode-map, from KEYMAP-LIST.
713 Built on top of optional BASE-MAP, or empty sparse map if none specified.
714 See doc string for allout-keybindings-list for format of binding list."
715 (let ((map (or base-map (make-sparse-keymap)))
716 (pref (list allout-command-prefix)))
717 (mapcar (function
718 (lambda (cell)
719 (let ((add-pref (null (cdr (cdr cell))))
720 (key-suff (list (car cell))))
721 (apply 'define-key
722 (list map
723 (apply 'concat (if add-pref
724 (append pref key-suff)
725 key-suff))
726 (car (cdr cell)))))))
727 keymap-list)
728 map))
730 ;;;_ : Menu bar
731 (defvar allout-mode-exposure-menu)
732 (defvar allout-mode-editing-menu)
733 (defvar allout-mode-navigation-menu)
734 (defvar allout-mode-misc-menu)
735 (defun produce-allout-mode-menubar-entries ()
736 (require 'easymenu)
737 (easy-menu-define allout-mode-exposure-menu
738 allout-mode-map
739 "Allout outline exposure menu."
740 '("Exposure"
741 ["Show Entry" allout-show-current-entry t]
742 ["Show Children" allout-show-children t]
743 ["Show Subtree" allout-show-current-subtree t]
744 ["Hide Subtree" allout-hide-current-subtree t]
745 ["Hide Leaves" allout-hide-current-leaves t]
746 "----"
747 ["Show All" allout-show-all t]))
748 (easy-menu-define allout-mode-editing-menu
749 allout-mode-map
750 "Allout outline editing menu."
751 '("Headings"
752 ["Open Sibling" allout-open-sibtopic t]
753 ["Open Subtopic" allout-open-subtopic t]
754 ["Open Supertopic" allout-open-supertopic t]
755 "----"
756 ["Shift Topic In" allout-shift-in t]
757 ["Shift Topic Out" allout-shift-out t]
758 ["Rebullet Topic" allout-rebullet-topic t]
759 ["Rebullet Heading" allout-rebullet-current-heading t]
760 ["Number Siblings" allout-number-siblings t]))
761 (easy-menu-define allout-mode-navigation-menu
762 allout-mode-map
763 "Allout outline navigation menu."
764 '("Navigation"
765 ["Next Visible Heading" allout-next-visible-heading t]
766 ["Previous Visible Heading"
767 allout-previous-visible-heading t]
768 "----"
769 ["Up Level" allout-up-current-level t]
770 ["Forward Current Level" allout-forward-current-level t]
771 ["Backward Current Level"
772 allout-backward-current-level t]
773 "----"
774 ["Beginning of Entry"
775 allout-beginning-of-current-entry t]
776 ["End of Entry" allout-end-of-current-entry t]
777 ["End of Subtree" allout-end-of-current-subtree t]))
778 (easy-menu-define allout-mode-misc-menu
779 allout-mode-map
780 "Allout outlines miscellaneous bindings."
781 '("Misc"
782 ["Version" allout-version t]
783 "----"
784 ["Duplicate Exposed" allout-copy-exposed-to-buffer t]
785 ["Duplicate Exposed, numbered"
786 allout-flatten-exposed-to-buffer t]
787 ["Duplicate Exposed, indented"
788 allout-indented-exposed-to-buffer t]
789 "----"
790 ["Set Header Lead" allout-reset-header-lead t]
791 ["Set New Exposure" allout-expose-topic t])))
792 ;;;_ : Mode-Specific Variable Maintenance Utilities
793 ;;;_ = allout-mode-prior-settings
794 (defvar allout-mode-prior-settings nil
795 "Internal `allout-mode' use; settings to be resumed on mode deactivation.")
796 (make-variable-buffer-local 'allout-mode-prior-settings)
797 ;;;_ > allout-resumptions (name &optional value)
798 (defun allout-resumptions (name &optional value)
800 "Registers or resumes settings over `allout-mode' activation/deactivation.
802 First arg is NAME of variable affected. Optional second arg is list
803 containing allout-mode-specific VALUE to be imposed on named
804 variable, and to be registered. (It's a list so you can specify
805 registrations of null values.) If no value is specified, the
806 registered value is returned (encapsulated in the list, so the caller
807 can distinguish nil vs no value), and the registration is popped
808 from the list."
810 (let ((on-list (assq name allout-mode-prior-settings))
811 prior-capsule ; By `capsule' i mean a list
812 ; containing a value, so we can
813 ; distinguish nil from no value.
816 (if value
818 ;; Registering:
819 (progn
820 (if on-list
821 nil ; Already preserved prior value - don't mess with it.
822 ;; Register the old value, or nil if previously unbound:
823 (setq allout-mode-prior-settings
824 (cons (list name
825 (if (boundp name) (list (symbol-value name))))
826 allout-mode-prior-settings)))
827 ; And impose the new value, locally:
828 (progn (make-local-variable name)
829 (set name (car value))))
831 ;; Relinquishing:
832 (if (not on-list)
834 ;; Oops, not registered - leave it be:
837 ;; Some registration:
838 ; reestablish it:
839 (setq prior-capsule (car (cdr on-list)))
840 (if prior-capsule
841 (set name (car prior-capsule)) ; Some prior value - reestablish it.
842 (makunbound name)) ; Previously unbound - demolish var.
843 ; Remove registration:
844 (let (rebuild)
845 (while allout-mode-prior-settings
846 (if (not (eq (car allout-mode-prior-settings)
847 on-list))
848 (setq rebuild
849 (cons (car allout-mode-prior-settings)
850 rebuild)))
851 (setq allout-mode-prior-settings
852 (cdr allout-mode-prior-settings)))
853 (setq allout-mode-prior-settings rebuild)))))
855 ;;;_ : Mode-specific incidentals
856 ;;;_ = allout-during-write-cue nil
857 (defvar allout-during-write-cue nil
858 "Used to inhibit outline change-protection during file write.
860 See also `allout-post-command-business', `allout-write-file-hook',
861 `allout-before-change-protect', and `allout-post-command-business'
862 functions.")
863 ;;;_ = allout-pre-was-isearching nil
864 (defvar allout-pre-was-isearching nil
865 "Cue for isearch-dynamic-exposure mechanism, implemented in
866 allout-pre- and -post-command-hooks.")
867 (make-variable-buffer-local 'allout-pre-was-isearching)
868 ;;;_ = allout-isearch-prior-pos nil
869 (defvar allout-isearch-prior-pos nil
870 "Cue for isearch-dynamic-exposure tracking, used by allout-isearch-expose.")
871 (make-variable-buffer-local 'allout-isearch-prior-pos)
872 ;;;_ = allout-isearch-did-quit
873 (defvar allout-isearch-did-quit nil
874 "Distinguishes isearch conclusion and cancellation.
876 Maintained by `allout-isearch-abort' \(which is wrapped around the real
877 isearch-abort), and monitored by `allout-isearch-expose' for action.")
878 (make-variable-buffer-local 'allout-isearch-did-quit)
879 ;;;_ = allout-override-protect nil
880 (defvar allout-override-protect nil
881 "Used in `allout-mode' for regulate of concealed-text protection mechanism.
883 Allout outline mode regulates alteration of concealed text to protect
884 against inadvertent, unnoticed changes. This is for use by specific,
885 native outline functions to temporarily override that protection.
886 It's automatically reset to nil after every buffer modification.")
887 (make-variable-buffer-local 'allout-override-protect)
888 ;;;_ > allout-unprotected (expr)
889 (defmacro allout-unprotected (expr)
890 "Evaluate EXPRESSION with `allout-override-protect' let-bound t."
891 `(let ((allout-override-protect t))
892 ,expr))
893 ;;;_ = allout-undo-aggregation
894 (defvar allout-undo-aggregation 30
895 "Amount of successive self-insert actions to bunch together per undo.
897 This is purely a kludge variable, regulating the compensation for a bug in
898 the way that before-change-functions and undo interact.")
899 (make-variable-buffer-local 'allout-undo-aggregation)
900 ;;;_ = file-var-bug hack
901 (defvar allout-v18/19-file-var-hack nil
902 "Horrible hack used to prevent invalid multiple triggering of outline
903 mode from prop-line file-var activation. Used by `allout-mode' function
904 to track repeats.")
905 ;;;_ > allout-write-file-hook ()
906 (defun allout-write-file-hook ()
907 "In `allout-mode', run as a `write-contents-functions' activity.
909 Currently just sets `allout-during-write-cue', so outline change-protection
910 knows to keep inactive during file write."
911 (setq allout-during-write-cue t)
912 nil)
914 ;;;_ #2 Mode activation
915 ;;;_ = allout-mode
916 (defvar allout-mode () "Allout outline mode minor-mode flag.")
917 (make-variable-buffer-local 'allout-mode)
918 ;;;_ > allout-mode-p ()
919 (defmacro allout-mode-p ()
920 "Return t if `allout-mode' is active in current buffer."
921 'allout-mode)
922 ;;;_ = allout-explicitly-deactivated
923 (defvar allout-explicitly-deactivated nil
924 "Non-nil if `allout-mode' was last deliberately deactivated.
925 So `allout-post-command-business' should not reactivate it...")
926 (make-variable-buffer-local 'allout-explicitly-deactivated)
927 ;;;_ > allout-init (&optional mode)
928 ;;;###autoload
929 (defun allout-init (&optional mode)
930 "Prime `allout-mode' to enable/disable auto-activation, wrt `allout-layout'.
932 MODE is one of the following symbols:
934 - nil \(or no argument) deactivate auto-activation/layout;
935 - `activate', enable auto-activation only;
936 - `ask', enable auto-activation, and enable auto-layout but with
937 confirmation for layout operation solicited from user each time;
938 - `report', just report and return the current auto-activation state;
939 - anything else \(eg, t) for auto-activation and auto-layout, without
940 any confirmation check.
942 Use this function to setup your Emacs session for automatic activation
943 of allout outline mode, contingent to the buffer-specific setting of
944 the `allout-layout' variable. (See `allout-layout' and
945 `allout-expose-topic' docstrings for more details on auto layout).
947 `allout-init' works by setting up (or removing)
948 `allout-find-file-hook' in `find-file-hook', and giving
949 `allout-auto-activation' a suitable setting.
951 To prime your Emacs session for full auto-outline operation, include
952 the following two lines in your Emacs init file:
954 \(require 'allout)
955 \(allout-init t)"
957 (interactive)
958 (if (interactive-p)
959 (progn
960 (setq mode
961 (completing-read
962 (concat "Select outline auto setup mode "
963 "(empty for report, ? for options) ")
964 '(("nil")("full")("activate")("deactivate")
965 ("ask") ("report") (""))
968 (if (string= mode "")
969 (setq mode 'report)
970 (setq mode (intern-soft mode)))))
971 (let
972 ;; convenience aliases, for consistent ref to respective vars:
973 ((hook 'allout-find-file-hook)
974 (curr-mode 'allout-auto-activation))
976 (cond ((not mode)
977 (setq find-file-hook (delq hook find-file-hook))
978 (if (interactive-p)
979 (message "Allout outline mode auto-activation inhibited.")))
980 ((eq mode 'report)
981 (if (memq hook find-file-hook)
982 ;; Just punt and use the reports from each of the modes:
983 (allout-init (symbol-value curr-mode))
984 (allout-init nil)
985 (message "Allout outline mode auto-activation inhibited.")))
986 (t (add-hook 'find-file-hook hook)
987 (set curr-mode ; `set', not `setq'!
988 (cond ((eq mode 'activate)
989 (message
990 "Outline mode auto-activation enabled.")
991 'activate)
992 ((eq mode 'report)
993 ;; Return the current mode setting:
994 (allout-init mode))
995 ((eq mode 'ask)
996 (message
997 (concat "Outline mode auto-activation and "
998 "-layout \(upon confirmation) enabled."))
999 'ask)
1000 ((message
1001 "Outline mode auto-activation and -layout enabled.")
1002 'full)))))))
1004 ;;;_ > allout-setup-menubar ()
1005 (defun allout-setup-menubar ()
1006 "Populate the current buffer's menubar with `allout-mode' stuff."
1007 (let ((menus (list allout-mode-exposure-menu
1008 allout-mode-editing-menu
1009 allout-mode-navigation-menu
1010 allout-mode-misc-menu))
1011 cur)
1012 (while menus
1013 (setq cur (car menus)
1014 menus (cdr menus))
1015 (easy-menu-add cur))))
1016 ;;;_ > allout-mode (&optional toggle)
1017 ;;;_ : Defun:
1018 (defun allout-mode (&optional toggle)
1019 ;;;_ . Doc string:
1020 "Toggle minor mode for controlling exposure and editing of text outlines.
1022 Optional arg forces mode to re-initialize iff arg is positive num or
1023 symbol. Allout outline mode always runs as a minor mode.
1025 Allout outline mode provides extensive outline oriented formatting and
1026 manipulation. It enables structural editing of outlines, as well as
1027 navigation and exposure. It also is specifically aimed at
1028 accommodating syntax-sensitive text like programming languages. \(For
1029 an example, see the allout code itself, which is organized as an allout
1030 outline.)
1032 In addition to outline navigation and exposure, allout includes:
1034 - topic-oriented repositioning, cut, and paste
1035 - integral outline exposure-layout
1036 - incremental search with dynamic exposure and reconcealment of hidden text
1037 - automatic topic-number maintenance
1038 - \"Hot-spot\" operation, for single-keystroke maneuvering and
1039 exposure control. \(See the allout-mode docstring.)
1041 and many other features.
1043 Below is a description of the bindings, and then explanation of
1044 special `allout-mode' features and terminology. See also the outline
1045 menubar additions for quick reference to many of the features, and see
1046 the docstring of the function `allout-init' for instructions on
1047 priming your Emacs session for automatic activation of `allout-mode'.
1050 The bindings are dictated by the `allout-keybindings-list' and
1051 `allout-command-prefix' variables.
1053 Navigation: Exposure Control:
1054 ---------- ----------------
1055 C-c C-n allout-next-visible-heading | C-c C-h allout-hide-current-subtree
1056 C-c C-p allout-previous-visible-heading | C-c C-i allout-show-children
1057 C-c C-u allout-up-current-level | C-c C-s allout-show-current-subtree
1058 C-c C-f allout-forward-current-level | C-c C-o allout-show-current-entry
1059 C-c C-b allout-backward-current-level | ^U C-c C-s allout-show-all
1060 C-c C-e allout-end-of-current-entry | allout-hide-current-leaves
1061 C-c C-a allout-beginning-of-current-entry, alternately, goes to hot-spot
1063 Topic Header Production:
1064 -----------------------
1065 C-c<SP> allout-open-sibtopic Create a new sibling after current topic.
1066 C-c . allout-open-subtopic ... an offspring of current topic.
1067 C-c , allout-open-supertopic ... a sibling of the current topic's parent.
1069 Topic Level and Prefix Adjustment:
1070 ---------------------------------
1071 C-c > allout-shift-in Shift current topic and all offspring deeper.
1072 C-c < allout-shift-out ... less deep.
1073 C-c<CR> allout-rebullet-topic Reconcile bullets of topic and its offspring
1074 - distinctive bullets are not changed, others
1075 alternated according to nesting depth.
1076 C-c * allout-rebullet-current-heading Prompt for alternate bullet for
1077 current topic.
1078 C-c # allout-number-siblings Number bullets of topic and siblings - the
1079 offspring are not affected. With repeat
1080 count, revoke numbering.
1082 Topic-oriented Killing and Yanking:
1083 ----------------------------------
1084 C-c C-k allout-kill-topic Kill current topic, including offspring.
1085 C-k allout-kill-line Like kill-line, but reconciles numbering, etc.
1086 C-y allout-yank Yank, adjusting depth of yanked topic to
1087 depth of heading if yanking into bare topic
1088 heading (ie, prefix sans text).
1089 M-y allout-yank-pop Is to allout-yank as yank-pop is to yank
1091 Misc commands:
1092 -------------
1093 M-x outlineify-sticky Activate outline mode for current buffer,
1094 and establish a default file-var setting
1095 for `allout-layout'.
1096 C-c C-SPC allout-mark-topic
1097 C-c = c allout-copy-exposed-to-buffer
1098 Duplicate outline, sans concealed text, to
1099 buffer with name derived from derived from
1100 that of current buffer - \"*XXX exposed*\".
1101 C-c = p allout-flatten-exposed-to-buffer
1102 Like above 'copy-exposed', but convert topic
1103 prefixes to section.subsection... numeric
1104 format.
1105 ESC ESC (allout-init t) Setup Emacs session for outline mode
1106 auto-activation.
1108 HOT-SPOT Operation
1110 Hot-spot operation provides a means for easy, single-keystroke outline
1111 navigation and exposure control.
1113 \\<allout-mode-map>
1114 When the text cursor is positioned directly on the bullet character of
1115 a topic, regular characters (a to z) invoke the commands of the
1116 corresponding allout-mode keymap control chars. For example, \"f\"
1117 would invoke the command typically bound to \"C-c C-f\"
1118 \(\\[allout-forward-current-level] `allout-forward-current-level').
1120 Thus, by positioning the cursor on a topic bullet, you can execute
1121 the outline navigation and manipulation commands with a single
1122 keystroke. Non-literal chars never get this special translation, so
1123 you can use them to get away from the hot-spot, and back to normal
1124 operation.
1126 Note that the command `allout-beginning-of-current-entry' \(\\[allout-beginning-of-current-entry]\)
1127 will move to the hot-spot when the cursor is already located at the
1128 beginning of the current entry, so you can simply hit \\[allout-beginning-of-current-entry]
1129 twice in a row to get to the hot-spot.
1131 Terminology
1133 Topic hierarchy constituents - TOPICS and SUBTOPICS:
1135 TOPIC: A basic, coherent component of an Emacs outline. It can
1136 contain other topics, and it can be subsumed by other topics,
1137 CURRENT topic:
1138 The visible topic most immediately containing the cursor.
1139 DEPTH: The degree of nesting of a topic; it increases with
1140 containment. Also called the:
1141 LEVEL: The same as DEPTH.
1143 ANCESTORS:
1144 The topics that contain a topic.
1145 PARENT: A topic's immediate ancestor. It has a depth one less than
1146 the topic.
1147 OFFSPRING:
1148 The topics contained by a topic;
1149 SUBTOPIC:
1150 An immediate offspring of a topic;
1151 CHILDREN:
1152 The immediate offspring of a topic.
1153 SIBLINGS:
1154 Topics having the same parent and depth.
1156 Topic text constituents:
1158 HEADER: The first line of a topic, include the topic PREFIX and header
1159 text.
1160 PREFIX: The leading text of a topic which which distinguishes it from
1161 normal text. It has a strict form, which consists of a
1162 prefix-lead string, padding, and a bullet. The bullet may be
1163 followed by a number, indicating the ordinal number of the
1164 topic among its siblings, a space, and then the header text.
1166 The relative length of the PREFIX determines the nesting depth
1167 of the topic.
1168 PREFIX-LEAD:
1169 The string at the beginning of a topic prefix, normally a `.'.
1170 It can be customized by changing the setting of
1171 `allout-header-prefix' and then reinitializing `allout-mode'.
1173 By setting the prefix-lead to the comment-string of a
1174 programming language, you can embed outline structuring in
1175 program code without interfering with the language processing
1176 of that code. See `allout-use-mode-specific-leader'
1177 docstring for more detail.
1178 PREFIX-PADDING:
1179 Spaces or asterisks which separate the prefix-lead and the
1180 bullet, according to the depth of the topic.
1181 BULLET: A character at the end of the topic prefix, it must be one of
1182 the characters listed on `allout-plain-bullets-string' or
1183 `allout-distinctive-bullets-string'. (See the documentation
1184 for these variables for more details.) The default choice of
1185 bullet when generating varies in a cycle with the depth of the
1186 topic.
1187 ENTRY: The text contained in a topic before any offspring.
1188 BODY: Same as ENTRY.
1191 EXPOSURE:
1192 The state of a topic which determines the on-screen visibility
1193 of its offspring and contained text.
1194 CONCEALED:
1195 Topics and entry text whose display is inhibited. Contiguous
1196 units of concealed text is represented by `...' ellipses.
1197 (Ref the `selective-display' var.)
1199 Concealed topics are effectively collapsed within an ancestor.
1200 CLOSED: A topic whose immediate offspring and body-text is concealed.
1201 OPEN: A topic that is not closed, though its offspring or body may be."
1202 ;;;_ . Code
1203 (interactive "P")
1205 (let* ((active (and (not (equal major-mode 'outline))
1206 (allout-mode-p)))
1207 ; Massage universal-arg `toggle' val:
1208 (toggle (and toggle
1209 (or (and (listp toggle)(car toggle))
1210 toggle)))
1211 ; Activation specifically demanded?
1212 (explicit-activation (or
1214 (and toggle
1215 (or (symbolp toggle)
1216 (and (natnump toggle)
1217 (not (zerop toggle)))))))
1218 ;; allout-mode already called once during this complex command?
1219 (same-complex-command (eq allout-v18/19-file-var-hack
1220 (car command-history)))
1221 do-layout
1224 ; See comments below re v19.18,.19 bug.
1225 (setq allout-v18/19-file-var-hack (car command-history))
1227 (cond
1229 ;; Provision for v19.18, 19.19 bug -
1230 ;; Emacs v 19.18, 19.19 file-var code invokes prop-line-designated
1231 ;; modes twice when file is visited. We have to avoid toggling mode
1232 ;; off on second invocation, so we detect it as best we can, and
1233 ;; skip everything.
1234 ((and same-complex-command ; Still in same complex command
1235 ; as last time `allout-mode' invoked.
1236 active ; Already activated.
1237 (not explicit-activation) ; Prop-line file-vars don't have args.
1238 (string-match "^19.1[89]" ; Bug only known to be in v19.18 and
1239 emacs-version)); 19.19.
1242 ;; Deactivation:
1243 ((and (not explicit-activation)
1244 (or active toggle))
1245 ; Activation not explicitly
1246 ; requested, and either in
1247 ; active state or *de*activation
1248 ; specifically requested:
1249 (setq allout-explicitly-deactivated t)
1251 (if allout-old-style-prefixes
1252 (progn
1253 (allout-resumptions 'allout-primary-bullet)
1254 (allout-resumptions 'allout-old-style-prefixes)))
1255 (allout-resumptions 'selective-display)
1256 (if (and (boundp 'before-change-functions) before-change-functions)
1257 (allout-resumptions 'before-change-functions))
1258 (setq write-contents-functions
1259 (delq 'allout-write-file-hook
1260 write-contents-functions))
1261 (allout-resumptions 'paragraph-start)
1262 (allout-resumptions 'paragraph-separate)
1263 (allout-resumptions (if (string-match "^18" emacs-version)
1264 'auto-fill-hook
1265 'auto-fill-function))
1266 (allout-resumptions 'allout-former-auto-filler)
1267 (setq allout-mode nil))
1269 ;; Activation:
1270 ((not active)
1271 (setq allout-explicitly-deactivated nil)
1272 (if allout-old-style-prefixes
1273 (progn ; Inhibit all the fancy formatting:
1274 (allout-resumptions 'allout-primary-bullet '("*"))
1275 (allout-resumptions 'allout-old-style-prefixes '(()))))
1277 (allout-infer-header-lead)
1278 (allout-infer-body-reindent)
1280 (set-allout-regexp)
1282 ; Produce map from current version
1283 ; of allout-keybindings-list:
1284 (if (boundp 'minor-mode-map-alist)
1286 (progn ; V19, and maybe lucid and
1287 ; epoch, minor-mode key bindings:
1288 (setq allout-mode-map
1289 (produce-allout-mode-map allout-keybindings-list))
1290 (produce-allout-mode-menubar-entries)
1291 (fset 'allout-mode-map allout-mode-map)
1292 ; Include on minor-mode-map-alist,
1293 ; if not already there:
1294 (if (not (member '(allout-mode . allout-mode-map)
1295 minor-mode-map-alist))
1296 (setq minor-mode-map-alist
1297 (cons '(allout-mode . allout-mode-map)
1298 minor-mode-map-alist))))
1300 ; and add them:
1301 (use-local-map (produce-allout-mode-map allout-keybindings-list
1302 (current-local-map)))
1305 ; selective-display is the
1306 ; Emacs conditional exposure
1307 ; mechanism:
1308 (allout-resumptions 'selective-display '(t))
1309 (if allout-inhibit-protection
1311 (allout-resumptions 'before-change-functions
1312 '(allout-before-change-protect)))
1313 (add-hook 'pre-command-hook 'allout-pre-command-business)
1314 (add-hook 'post-command-hook 'allout-post-command-business)
1315 ; Temporarily set by any outline
1316 ; functions that can be trusted to
1317 ; deal properly with concealed text.
1318 (add-hook 'write-contents-functions 'allout-write-file-hook)
1319 ; Custom auto-fill func, to support
1320 ; respect for topic headline,
1321 ; hanging-indents, etc:
1322 (let* ((fill-func-var (if (string-match "^18" emacs-version)
1323 'auto-fill-hook
1324 'auto-fill-function))
1325 (fill-func (symbol-value fill-func-var)))
1326 ;; Register prevailing fill func for use by allout-auto-fill:
1327 (allout-resumptions 'allout-former-auto-filler (list fill-func))
1328 ;; Register allout-auto-fill to be used if filling is active:
1329 (allout-resumptions fill-func-var '(allout-auto-fill)))
1330 ;; Paragraphs are broken by topic headlines.
1331 (make-local-variable 'paragraph-start)
1332 (allout-resumptions 'paragraph-start
1333 (list (concat paragraph-start "\\|^\\("
1334 allout-regexp "\\)")))
1335 (make-local-variable 'paragraph-separate)
1336 (allout-resumptions 'paragraph-separate
1337 (list (concat paragraph-separate "\\|^\\("
1338 allout-regexp "\\)")))
1340 (or (assq 'allout-mode minor-mode-alist)
1341 (setq minor-mode-alist
1342 (cons '(allout-mode " Allout") minor-mode-alist)))
1344 (allout-setup-menubar)
1346 (if allout-layout
1347 (setq do-layout t))
1349 (if (and allout-isearch-dynamic-expose
1350 (not (fboundp 'allout-real-isearch-abort)))
1351 (allout-enwrap-isearch))
1353 (run-hooks 'allout-mode-hook)
1354 (setq allout-mode t))
1356 ;; Reactivation:
1357 ((setq do-layout t)
1358 (allout-infer-body-reindent))
1359 ) ; cond
1361 (if (and do-layout
1362 allout-auto-activation
1363 (listp allout-layout)
1364 (and (not (eq allout-auto-activation 'activate))
1365 (if (eq allout-auto-activation 'ask)
1366 (if (y-or-n-p (format "Expose %s with layout '%s'? "
1367 (buffer-name)
1368 allout-layout))
1370 (message "Skipped %s layout." (buffer-name))
1371 nil)
1372 t)))
1373 (save-excursion
1374 (message "Adjusting '%s' exposure..." (buffer-name))
1375 (goto-char 0)
1376 (allout-this-or-next-heading)
1377 (condition-case err
1378 (progn
1379 (apply 'allout-expose-topic (list allout-layout))
1380 (message "Adjusting '%s' exposure... done." (buffer-name)))
1381 ;; Problem applying exposure - notify user, but don't
1382 ;; interrupt, eg, file visit:
1383 (error (message "%s" (car (cdr err)))
1384 (sit-for 1)))))
1385 allout-mode
1386 ) ; let*
1387 ) ; defun
1388 ;;;_ > allout-minor-mode
1389 ;;; XXX released verion doesn't do this?
1390 (defalias 'allout-minor-mode 'allout-mode)
1392 ;;;_ #3 Internal Position State-Tracking - "allout-recent-*" funcs
1393 ;;; All the basic outline functions that directly do string matches to
1394 ;;; evaluate heading prefix location set the variables
1395 ;;; `allout-recent-prefix-beginning' and `allout-recent-prefix-end'
1396 ;;; when successful. Functions starting with `allout-recent-' all
1397 ;;; use this state, providing the means to avoid redundant searches
1398 ;;; for just-established data. This optimization can provide
1399 ;;; significant speed improvement, but it must be employed carefully.
1400 ;;;_ = allout-recent-prefix-beginning
1401 (defvar allout-recent-prefix-beginning 0
1402 "Buffer point of the start of the last topic prefix encountered.")
1403 (make-variable-buffer-local 'allout-recent-prefix-beginning)
1404 ;;;_ = allout-recent-prefix-end
1405 (defvar allout-recent-prefix-end 0
1406 "Buffer point of the end of the last topic prefix encountered.")
1407 (make-variable-buffer-local 'allout-recent-prefix-end)
1408 ;;;_ = allout-recent-end-of-subtree
1409 (defvar allout-recent-end-of-subtree 0
1410 "Buffer point last returned by `allout-end-of-current-subtree'.")
1411 (make-variable-buffer-local 'allout-recent-end-of-subtree)
1412 ;;;_ > allout-prefix-data (beg end)
1413 (defmacro allout-prefix-data (beg end)
1414 "Register allout-prefix state data - BEGINNING and END of prefix.
1416 For reference by `allout-recent' funcs. Returns BEGINNING."
1417 `(setq allout-recent-prefix-end ,end
1418 allout-recent-prefix-beginning ,beg))
1419 ;;;_ > allout-recent-depth ()
1420 (defmacro allout-recent-depth ()
1421 "Return depth of last heading encountered by an outline maneuvering function.
1423 All outline functions which directly do string matches to assess
1424 headings set the variables `allout-recent-prefix-beginning' and
1425 `allout-recent-prefix-end' if successful. This function uses those settings
1426 to return the current depth."
1428 '(max 1 (- allout-recent-prefix-end
1429 allout-recent-prefix-beginning
1430 allout-header-subtraction)))
1431 ;;;_ > allout-recent-prefix ()
1432 (defmacro allout-recent-prefix ()
1433 "Like `allout-recent-depth', but returns text of last encountered prefix.
1435 All outline functions which directly do string matches to assess
1436 headings set the variables `allout-recent-prefix-beginning' and
1437 `allout-recent-prefix-end' if successful. This function uses those settings
1438 to return the current depth."
1439 '(buffer-substring allout-recent-prefix-beginning
1440 allout-recent-prefix-end))
1441 ;;;_ > allout-recent-bullet ()
1442 (defmacro allout-recent-bullet ()
1443 "Like allout-recent-prefix, but returns bullet of last encountered prefix.
1445 All outline functions which directly do string matches to assess
1446 headings set the variables `allout-recent-prefix-beginning' and
1447 `allout-recent-prefix-end' if successful. This function uses those settings
1448 to return the current depth of the most recently matched topic."
1449 '(buffer-substring (1- allout-recent-prefix-end)
1450 allout-recent-prefix-end))
1452 ;;;_ #4 Navigation
1454 ;;;_ - Position Assessment
1455 ;;;_ : Location Predicates
1456 ;;;_ > allout-on-current-heading-p ()
1457 (defun allout-on-current-heading-p ()
1458 "Return non-nil if point is on current visible topics' header line.
1460 Actually, returns prefix beginning point."
1461 (save-excursion
1462 (beginning-of-line)
1463 (and (looking-at allout-regexp)
1464 (allout-prefix-data (match-beginning 0) (match-end 0)))))
1465 ;;;_ > allout-on-heading-p ()
1466 (defalias 'allout-on-heading-p 'allout-on-current-heading-p)
1467 ;;;_ > allout-e-o-prefix-p ()
1468 (defun allout-e-o-prefix-p ()
1469 "True if point is located where current topic prefix ends, heading begins."
1470 (and (save-excursion (beginning-of-line)
1471 (looking-at allout-regexp))
1472 (= (point)(save-excursion (allout-end-of-prefix)(point)))))
1473 ;;;_ > allout-hidden-p ()
1474 (defmacro allout-hidden-p ()
1475 "True if point is in hidden text."
1476 '(save-excursion
1477 (and (re-search-backward "[\n\r]" () t)
1478 (= ?\r (following-char)))))
1479 ;;;_ > allout-visible-p ()
1480 (defmacro allout-visible-p ()
1481 "True if point is not in hidden text."
1482 (interactive)
1483 '(not (allout-hidden-p)))
1484 ;;;_ : Location attributes
1485 ;;;_ > allout-depth ()
1486 (defsubst allout-depth ()
1487 "Like `allout-current-depth', but respects hidden as well as visible topics."
1488 (save-excursion
1489 (if (allout-goto-prefix)
1490 (allout-recent-depth)
1491 (progn
1492 ;; Oops, no prefix, zero prefix data:
1493 (allout-prefix-data (point)(point))
1494 ;; ... and return 0:
1495 0))))
1496 ;;;_ > allout-current-depth ()
1497 (defmacro allout-current-depth ()
1498 "Return nesting depth of visible topic most immediately containing point."
1499 '(save-excursion
1500 (if (allout-back-to-current-heading)
1501 (max 1
1502 (- allout-recent-prefix-end
1503 allout-recent-prefix-beginning
1504 allout-header-subtraction))
1505 0)))
1506 ;;;_ > allout-get-current-prefix ()
1507 (defun allout-get-current-prefix ()
1508 "Topic prefix of the current topic."
1509 (save-excursion
1510 (if (allout-goto-prefix)
1511 (allout-recent-prefix))))
1512 ;;;_ > allout-get-bullet ()
1513 (defun allout-get-bullet ()
1514 "Return bullet of containing topic (visible or not)."
1515 (save-excursion
1516 (and (allout-goto-prefix)
1517 (allout-recent-bullet))))
1518 ;;;_ > allout-current-bullet ()
1519 (defun allout-current-bullet ()
1520 "Return bullet of current (visible) topic heading, or none if none found."
1521 (condition-case err
1522 (save-excursion
1523 (allout-back-to-current-heading)
1524 (buffer-substring (- allout-recent-prefix-end 1)
1525 allout-recent-prefix-end))
1526 ;; Quick and dirty provision, ostensibly for missing bullet:
1527 ('args-out-of-range nil))
1529 ;;;_ > allout-get-prefix-bullet (prefix)
1530 (defun allout-get-prefix-bullet (prefix)
1531 "Return the bullet of the header prefix string PREFIX."
1532 ;; Doesn't make sense if we're old-style prefixes, but this just
1533 ;; oughtn't be called then, so forget about it...
1534 (if (string-match allout-regexp prefix)
1535 (substring prefix (1- (match-end 0)) (match-end 0))))
1536 ;;;_ > allout-sibling-index (&optional depth)
1537 (defun allout-sibling-index (&optional depth)
1538 "Item number of this prospective topic among its siblings.
1540 If optional arg DEPTH is greater than current depth, then we're
1541 opening a new level, and return 0.
1543 If less than this depth, ascend to that depth and count..."
1545 (save-excursion
1546 (cond ((and depth (<= depth 0) 0))
1547 ((or (not depth) (= depth (allout-depth)))
1548 (let ((index 1))
1549 (while (allout-previous-sibling (allout-recent-depth) nil)
1550 (setq index (1+ index)))
1551 index))
1552 ((< depth (allout-recent-depth))
1553 (allout-ascend-to-depth depth)
1554 (allout-sibling-index))
1555 (0))))
1556 ;;;_ > allout-topic-flat-index ()
1557 (defun allout-topic-flat-index ()
1558 "Return a list indicating point's numeric section.subsect.subsubsect...
1559 Outermost is first."
1560 (let* ((depth (allout-depth))
1561 (next-index (allout-sibling-index depth))
1562 (rev-sibls nil))
1563 (while (> next-index 0)
1564 (setq rev-sibls (cons next-index rev-sibls))
1565 (setq depth (1- depth))
1566 (setq next-index (allout-sibling-index depth)))
1567 rev-sibls)
1570 ;;;_ - Navigation macros
1571 ;;;_ > allout-next-heading ()
1572 (defsubst allout-next-heading ()
1573 "Move to the heading for the topic \(possibly invisible) before this one.
1575 Returns the location of the heading, or nil if none found."
1577 (if (and (bobp) (not (eobp)))
1578 (forward-char 1))
1580 (if (re-search-forward allout-line-boundary-regexp nil 0)
1581 (allout-prefix-data ; Got valid location state - set vars:
1582 (goto-char (or (match-beginning 2)
1583 allout-recent-prefix-beginning))
1584 (or (match-end 2) allout-recent-prefix-end))))
1585 ;;;_ : allout-this-or-next-heading
1586 (defun allout-this-or-next-heading ()
1587 "Position cursor on current or next heading."
1588 ;; A throwaway non-macro that is defined after allout-next-heading
1589 ;; and usable by allout-mode.
1590 (if (not (allout-goto-prefix)) (allout-next-heading)))
1591 ;;;_ > allout-previous-heading ()
1592 (defmacro allout-previous-heading ()
1593 "Move to the prior \(possibly invisible) heading line.
1595 Return the location of the beginning of the heading, or nil if not found."
1597 '(if (bobp)
1599 (allout-goto-prefix)
1601 ;; searches are unbounded and return nil if failed:
1602 (or (re-search-backward allout-line-boundary-regexp nil 0)
1603 (looking-at allout-bob-regexp))
1604 (progn ; Got valid location state - set vars:
1605 (allout-prefix-data
1606 (goto-char (or (match-beginning 2)
1607 allout-recent-prefix-beginning))
1608 (or (match-end 2) allout-recent-prefix-end))))))
1610 ;;;_ - Subtree Charting
1611 ;;;_ " These routines either produce or assess charts, which are
1612 ;;; nested lists of the locations of topics within a subtree.
1614 ;;; Use of charts enables efficient navigation of subtrees, by
1615 ;;; requiring only a single regexp-search based traversal, to scope
1616 ;;; out the subtopic locations. The chart then serves as the basis
1617 ;;; for assessment or adjustment of the subtree, without redundant
1618 ;;; traversal of the structure.
1620 ;;;_ > allout-chart-subtree (&optional levels orig-depth prev-depth)
1621 (defun allout-chart-subtree (&optional levels orig-depth prev-depth)
1622 "Produce a location \"chart\" of subtopics of the containing topic.
1624 Optional argument LEVELS specifies the depth \(relative to start
1625 depth) for the chart.
1627 Charts are used to capture outline structure, so that outline altering
1628 routines need assess the structure only once, and then use the chart
1629 for their elaborate manipulations.
1631 Topics are entered in the chart so the last one is at the car.
1632 The entry for each topic consists of an integer indicating the point
1633 at the beginning of the topic. Charts for offspring consists of a
1634 list containing, recursively, the charts for the respective subtopics.
1635 The chart for a topics' offspring precedes the entry for the topic
1636 itself.
1638 \(fn &optional levels)"
1640 ;; The other function parameters are for internal recursion, and should
1641 ;; not be specified by external callers. ORIG-DEPTH is depth of topic at
1642 ;; starting point, and PREV-DEPTH is depth of prior topic."
1644 (let ((original (not orig-depth)) ; `orig-depth' set only in recursion.
1645 chart curr-depth)
1647 (if original ; Just starting?
1648 ; Register initial settings and
1649 ; position to first offspring:
1650 (progn (setq orig-depth (allout-depth))
1651 (or prev-depth (setq prev-depth (1+ orig-depth)))
1652 (allout-next-heading)))
1654 ;; Loop over the current levels' siblings. Besides being more
1655 ;; efficient than tail-recursing over a level, it avoids exceeding
1656 ;; the typically quite constrained Emacs max-lisp-eval-depth.
1658 ;; Probably would speed things up to implement loop-based stack
1659 ;; operation rather than recursing for lower levels. Bah.
1661 (while (and (not (eobp))
1662 ; Still within original topic?
1663 (< orig-depth (setq curr-depth (allout-recent-depth)))
1664 (cond ((= prev-depth curr-depth)
1665 ;; Register this one and move on:
1666 (setq chart (cons (point) chart))
1667 (if (and levels (<= levels 1))
1668 ;; At depth limit - skip sublevels:
1669 (or (allout-next-sibling curr-depth)
1670 ;; or no more siblings - proceed to
1671 ;; next heading at lesser depth:
1672 (while (and (<= curr-depth
1673 (allout-recent-depth))
1674 (allout-next-heading))))
1675 (allout-next-heading)))
1677 ((and (< prev-depth curr-depth)
1678 (or (not levels)
1679 (> levels 0)))
1680 ;; Recurse on deeper level of curr topic:
1681 (setq chart
1682 (cons (allout-chart-subtree (and levels
1683 (1- levels))
1684 orig-depth
1685 curr-depth)
1686 chart))
1687 ;; ... then continue with this one.
1690 ;; ... else nil if we've ascended back to prev-depth.
1694 (if original ; We're at the last sibling on
1695 ; the original level. Position
1696 ; to the end of it:
1697 (progn (and (not (eobp)) (forward-char -1))
1698 (and (memq (preceding-char) '(?\n ?\r))
1699 (memq (aref (buffer-substring (max 1 (- (point) 3))
1700 (point))
1702 '(?\n ?\r))
1703 (forward-char -1))
1704 (setq allout-recent-end-of-subtree (point))))
1706 chart ; (nreverse chart) not necessary,
1707 ; and maybe not preferable.
1709 ;;;_ > allout-chart-siblings (&optional start end)
1710 (defun allout-chart-siblings (&optional start end)
1711 "Produce a list of locations of this and succeeding sibling topics.
1712 Effectively a top-level chart of siblings. See `allout-chart-subtree'
1713 for an explanation of charts."
1714 (save-excursion
1715 (if (allout-goto-prefix)
1716 (let ((chart (list (point))))
1717 (while (allout-next-sibling)
1718 (setq chart (cons (point) chart)))
1719 (if chart (setq chart (nreverse chart)))))))
1720 ;;;_ > allout-chart-to-reveal (chart depth)
1721 (defun allout-chart-to-reveal (chart depth)
1723 "Return a flat list of hidden points in subtree CHART, up to DEPTH.
1725 Note that point can be left at any of the points on chart, or at the
1726 start point."
1728 (let (result here)
1729 (while (and (or (eq depth t) (> depth 0))
1730 chart)
1731 (setq here (car chart))
1732 (if (listp here)
1733 (let ((further (allout-chart-to-reveal here (or (eq depth t)
1734 (1- depth)))))
1735 ;; We're on the start of a subtree - recurse with it, if there's
1736 ;; more depth to go:
1737 (if further (setq result (append further result)))
1738 (setq chart (cdr chart)))
1739 (goto-char here)
1740 (if (= (preceding-char) ?\r)
1741 (setq result (cons here result)))
1742 (setq chart (cdr chart))))
1743 result))
1744 ;;;_ X allout-chart-spec (chart spec &optional exposing)
1745 ;; (defun allout-chart-spec (chart spec &optional exposing)
1746 ;; "Not yet \(if ever) implemented.
1748 ;; Produce exposure directives given topic/subtree CHART and an exposure SPEC.
1750 ;; Exposure spec indicates the locations to be exposed and the prescribed
1751 ;; exposure status. Optional arg EXPOSING is an integer, with 0
1752 ;; indicating pending concealment, anything higher indicating depth to
1753 ;; which subtopic headers should be exposed, and negative numbers
1754 ;; indicating (negative of) the depth to which subtopic headers and
1755 ;; bodies should be exposed.
1757 ;; The produced list can have two types of entries. Bare numbers
1758 ;; indicate points in the buffer where topic headers that should be
1759 ;; exposed reside.
1761 ;; - bare negative numbers indicates that the topic starting at the
1762 ;; point which is the negative of the number should be opened,
1763 ;; including their entries.
1764 ;; - bare positive values indicate that this topic header should be
1765 ;; opened.
1766 ;; - Lists signify the beginning and end points of regions that should
1767 ;; be flagged, and the flag to employ. (For concealment: `\(\?r\)', and
1768 ;; exposure:"
1769 ;; (while spec
1770 ;; (cond ((listp spec)
1771 ;; )
1772 ;; )
1773 ;; (setq spec (cdr spec)))
1774 ;; )
1776 ;;;_ - Within Topic
1777 ;;;_ > allout-goto-prefix ()
1778 (defun allout-goto-prefix ()
1779 "Put point at beginning of immediately containing outline topic.
1781 Goes to most immediate subsequent topic if none immediately containing.
1783 Not sensitive to topic visibility.
1785 Returns the point at the beginning of the prefix, or nil if none."
1787 (let (done)
1788 (while (and (not done)
1789 (re-search-backward "[\n\r]" nil 1))
1790 (forward-char 1)
1791 (if (looking-at allout-regexp)
1792 (setq done (allout-prefix-data (match-beginning 0)
1793 (match-end 0)))
1794 (forward-char -1)))
1795 (if (bobp)
1796 (cond ((looking-at allout-regexp)
1797 (allout-prefix-data (match-beginning 0)(match-end 0)))
1798 ((allout-next-heading))
1799 (done))
1800 done)))
1801 ;;;_ > allout-end-of-prefix ()
1802 (defun allout-end-of-prefix (&optional ignore-decorations)
1803 "Position cursor at beginning of header text.
1805 If optional IGNORE-DECORATIONS is non-nil, put just after bullet,
1806 otherwise skip white space between bullet and ensuing text."
1808 (if (not (allout-goto-prefix))
1810 (let ((match-data (match-data)))
1811 (goto-char (match-end 0))
1812 (if ignore-decorations
1814 (while (looking-at "[0-9]") (forward-char 1))
1815 (if (and (not (eolp)) (looking-at "\\s-")) (forward-char 1)))
1816 (store-match-data match-data))
1817 ;; Reestablish where we are:
1818 (allout-current-depth)))
1819 ;;;_ > allout-current-bullet-pos ()
1820 (defun allout-current-bullet-pos ()
1821 "Return position of current \(visible) topic's bullet."
1823 (if (not (allout-current-depth))
1825 (1- (match-end 0))))
1826 ;;;_ > allout-back-to-current-heading ()
1827 (defun allout-back-to-current-heading ()
1828 "Move to heading line of current topic, or beginning if already on the line."
1830 (beginning-of-line)
1831 (prog1 (or (allout-on-current-heading-p)
1832 (and (re-search-backward (concat "^\\(" allout-regexp "\\)")
1834 'move)
1835 (allout-prefix-data (match-beginning 1)(match-end 1))))
1836 (if (interactive-p) (allout-end-of-prefix))))
1837 ;;;_ > allout-back-to-heading ()
1838 (defalias 'allout-back-to-heading 'allout-back-to-current-heading)
1839 ;;;_ > allout-pre-next-preface ()
1840 (defun allout-pre-next-preface ()
1841 "Skip forward to just before the next heading line.
1843 Returns that character position."
1845 (if (re-search-forward allout-line-boundary-regexp nil 'move)
1846 (prog1 (goto-char (match-beginning 0))
1847 (allout-prefix-data (match-beginning 2)(match-end 2)))))
1848 ;;;_ > allout-end-of-current-subtree ()
1849 (defun allout-end-of-current-subtree ()
1850 "Put point at the end of the last leaf in the currently visible topic."
1851 (interactive)
1852 (allout-back-to-current-heading)
1853 (let ((level (allout-recent-depth)))
1854 (allout-next-heading)
1855 (while (and (not (eobp))
1856 (> (allout-recent-depth) level))
1857 (allout-next-heading))
1858 (and (not (eobp)) (forward-char -1))
1859 (and (memq (preceding-char) '(?\n ?\r))
1860 (memq (aref (buffer-substring (max 1 (- (point) 3)) (point)) 1)
1861 '(?\n ?\r))
1862 (forward-char -1))
1863 (setq allout-recent-end-of-subtree (point))))
1864 ;;;_ > allout-beginning-of-current-entry ()
1865 (defun allout-beginning-of-current-entry ()
1866 "When not already there, position point at beginning of current topic's body.
1868 If already there, move cursor to bullet for hot-spot operation.
1869 \(See `allout-mode' doc string for details on hot-spot operation.)"
1870 (interactive)
1871 (let ((start-point (point)))
1872 (allout-end-of-prefix)
1873 (if (and (interactive-p)
1874 (= (point) start-point))
1875 (goto-char (allout-current-bullet-pos)))))
1876 ;;;_ > allout-end-of-current-entry ()
1877 (defun allout-end-of-current-entry ()
1878 "Position the point at the end of the current topics' entry."
1879 (interactive)
1880 (allout-show-entry)
1881 (prog1 (allout-pre-next-preface)
1882 (if (and (not (bobp))(looking-at "^$"))
1883 (forward-char -1))))
1884 ;;;_ > allout-end-of-current-heading ()
1885 (defun allout-end-of-current-heading ()
1886 (interactive)
1887 (allout-beginning-of-current-entry)
1888 (forward-line -1)
1889 (end-of-line))
1890 (defalias 'allout-end-of-heading 'allout-end-of-current-heading)
1892 ;;;_ - Depth-wise
1893 ;;;_ > allout-ascend-to-depth (depth)
1894 (defun allout-ascend-to-depth (depth)
1895 "Ascend to depth DEPTH, returning depth if successful, nil if not."
1896 (if (and (> depth 0)(<= depth (allout-depth)))
1897 (let ((last-good (point)))
1898 (while (and (< depth (allout-depth))
1899 (setq last-good (point))
1900 (allout-beginning-of-level)
1901 (allout-previous-heading)))
1902 (if (= (allout-recent-depth) depth)
1903 (progn (goto-char allout-recent-prefix-beginning)
1904 depth)
1905 (goto-char last-good)
1906 nil))
1907 (if (interactive-p) (allout-end-of-prefix))))
1908 ;;;_ > allout-ascend ()
1909 (defun allout-ascend ()
1910 "Ascend one level, returning t if successful, nil if not."
1911 (prog1
1912 (if (allout-beginning-of-level)
1913 (allout-previous-heading))
1914 (if (interactive-p) (allout-end-of-prefix))))
1915 ;;;_ > allout-descend-to-depth (depth)
1916 (defun allout-descend-to-depth (depth)
1917 "Descend to depth DEPTH within current topic.
1919 Returning depth if successful, nil if not."
1920 (let ((start-point (point))
1921 (start-depth (allout-depth)))
1922 (while
1923 (and (> (allout-depth) 0)
1924 (not (= depth (allout-recent-depth))) ; ... not there yet
1925 (allout-next-heading) ; ... go further
1926 (< start-depth (allout-recent-depth)))) ; ... still in topic
1927 (if (and (> (allout-depth) 0)
1928 (= (allout-recent-depth) depth))
1929 depth
1930 (goto-char start-point)
1931 nil))
1933 ;;;_ > allout-up-current-level (arg &optional dont-complain)
1934 (defun allout-up-current-level (arg &optional dont-complain)
1935 "Move out ARG levels from current visible topic.
1937 Positions on heading line of containing topic. Error if unable to
1938 ascend that far, or nil if unable to ascend but optional arg
1939 DONT-COMPLAIN is non-nil."
1940 (interactive "p")
1941 (allout-back-to-current-heading)
1942 (let ((present-level (allout-recent-depth))
1943 (last-good (point))
1944 failed
1945 return)
1946 ;; Loop for iterating arg:
1947 (while (and (> (allout-recent-depth) 1)
1948 (> arg 0)
1949 (not (bobp))
1950 (not failed))
1951 (setq last-good (point))
1952 ;; Loop for going back over current or greater depth:
1953 (while (and (not (< (allout-recent-depth) present-level))
1954 (or (allout-previous-visible-heading 1)
1955 (not (setq failed present-level)))))
1956 (setq present-level (allout-current-depth))
1957 (setq arg (- arg 1)))
1958 (if (or failed
1959 (> arg 0))
1960 (progn (goto-char last-good)
1961 (if (interactive-p) (allout-end-of-prefix))
1962 (if (not dont-complain)
1963 (error "Can't ascend past outermost level")
1964 (if (interactive-p) (allout-end-of-prefix))
1965 nil))
1966 (if (interactive-p) (allout-end-of-prefix))
1967 allout-recent-prefix-beginning)))
1969 ;;;_ - Linear
1970 ;;;_ > allout-next-sibling (&optional depth backward)
1971 (defun allout-next-sibling (&optional depth backward)
1972 "Like `allout-forward-current-level', but respects invisible topics.
1974 Traverse at optional DEPTH, or current depth if none specified.
1976 Go backward if optional arg BACKWARD is non-nil.
1978 Return depth if successful, nil otherwise."
1980 (if (and backward (bobp))
1982 (let ((start-depth (or depth (allout-depth)))
1983 (start-point (point))
1984 last-depth)
1985 (while (and (not (if backward (bobp) (eobp)))
1986 (if backward (allout-previous-heading)
1987 (allout-next-heading))
1988 (> (setq last-depth (allout-recent-depth)) start-depth)))
1989 (if (and (not (eobp))
1990 (and (> (or last-depth (allout-depth)) 0)
1991 (= (allout-recent-depth) start-depth)))
1992 allout-recent-prefix-beginning
1993 (goto-char start-point)
1994 (if depth (allout-depth) start-depth)
1995 nil))))
1996 ;;;_ > allout-previous-sibling (&optional depth backward)
1997 (defun allout-previous-sibling (&optional depth backward)
1998 "Like `allout-forward-current-level', but backwards & respect invisible topics.
2000 Optional DEPTH specifies depth to traverse, default current depth.
2002 Optional BACKWARD reverses direction.
2004 Return depth if successful, nil otherwise."
2005 (allout-next-sibling depth (not backward))
2007 ;;;_ > allout-snug-back ()
2008 (defun allout-snug-back ()
2009 "Position cursor at end of previous topic
2011 Presumes point is at the start of a topic prefix."
2012 (if (or (bobp) (eobp))
2014 (forward-char -1))
2015 (if (or (bobp) (not (memq (preceding-char) '(?\n ?\r))))
2017 (forward-char -1)
2018 (if (or (bobp) (not (memq (preceding-char) '(?\n ?\r))))
2019 (forward-char -1)))
2020 (point))
2021 ;;;_ > allout-beginning-of-level ()
2022 (defun allout-beginning-of-level ()
2023 "Go back to the first sibling at this level, visible or not."
2024 (allout-end-of-level 'backward))
2025 ;;;_ > allout-end-of-level (&optional backward)
2026 (defun allout-end-of-level (&optional backward)
2027 "Go to the last sibling at this level, visible or not."
2029 (let ((depth (allout-depth)))
2030 (while (allout-previous-sibling depth nil))
2031 (prog1 (allout-recent-depth)
2032 (if (interactive-p) (allout-end-of-prefix)))))
2033 ;;;_ > allout-next-visible-heading (arg)
2034 (defun allout-next-visible-heading (arg)
2035 "Move to the next ARG'th visible heading line, backward if arg is negative.
2037 Move as far as possible in indicated direction \(beginning or end of
2038 buffer) if headings are exhausted."
2040 (interactive "p")
2041 (let* ((backward (if (< arg 0) (setq arg (* -1 arg))))
2042 (step (if backward -1 1))
2043 (start-point (point))
2044 prev got)
2046 (while (> arg 0) ; limit condition
2047 (while (and (not (if backward (bobp)(eobp))) ; boundary condition
2048 ;; Move, skipping over all those concealed lines:
2049 (< -1 (forward-line step))
2050 (not (setq got (looking-at allout-regexp)))))
2051 ;; Register this got, it may be the last:
2052 (if got (setq prev got))
2053 (setq arg (1- arg)))
2054 (cond (got ; Last move was to a prefix:
2055 (allout-prefix-data (match-beginning 0) (match-end 0))
2056 (allout-end-of-prefix))
2057 (prev ; Last move wasn't, but prev was:
2058 (allout-prefix-data (match-beginning 0) (match-end 0)))
2059 ((not backward) (end-of-line) nil))))
2060 ;;;_ > allout-previous-visible-heading (arg)
2061 (defun allout-previous-visible-heading (arg)
2062 "Move to the previous heading line.
2064 With argument, repeats or can move forward if negative.
2065 A heading line is one that starts with a `*' (or that `allout-regexp'
2066 matches)."
2067 (interactive "p")
2068 (allout-next-visible-heading (- arg)))
2069 ;;;_ > allout-forward-current-level (arg)
2070 (defun allout-forward-current-level (arg)
2071 "Position point at the next heading of the same level.
2073 Takes optional repeat-count, goes backward if count is negative.
2075 Returns resulting position, else nil if none found."
2076 (interactive "p")
2077 (let ((start-depth (allout-current-depth))
2078 (start-point (point))
2079 (start-arg arg)
2080 (backward (> 0 arg))
2081 last-depth
2082 (last-good (point))
2083 at-boundary)
2084 (if (= 0 start-depth)
2085 (error "No siblings, not in a topic..."))
2086 (if backward (setq arg (* -1 arg)))
2087 (while (not (or (zerop arg)
2088 at-boundary))
2089 (while (and (not (if backward (bobp) (eobp)))
2090 (if backward (allout-previous-visible-heading 1)
2091 (allout-next-visible-heading 1))
2092 (> (setq last-depth (allout-recent-depth)) start-depth)))
2093 (if (and last-depth (= last-depth start-depth)
2094 (not (if backward (bobp) (eobp))))
2095 (setq last-good (point)
2096 arg (1- arg))
2097 (setq at-boundary t)))
2098 (if (and (not (eobp))
2099 (= arg 0)
2100 (and (> (or last-depth (allout-depth)) 0)
2101 (= (allout-recent-depth) start-depth)))
2102 allout-recent-prefix-beginning
2103 (goto-char last-good)
2104 (if (not (interactive-p))
2106 (allout-end-of-prefix)
2107 (error "Hit %s level %d topic, traversed %d of %d requested"
2108 (if backward "first" "last")
2109 (allout-recent-depth)
2110 (- (abs start-arg) arg)
2111 (abs start-arg))))))
2112 ;;;_ > allout-backward-current-level (arg)
2113 (defun allout-backward-current-level (arg)
2114 "Inverse of `allout-forward-current-level'."
2115 (interactive "p")
2116 (if (interactive-p)
2117 (let ((current-prefix-arg (* -1 arg)))
2118 (call-interactively 'allout-forward-current-level))
2119 (allout-forward-current-level (* -1 arg))))
2121 ;;;_ #5 Alteration
2123 ;;;_ - Fundamental
2124 ;;;_ > allout-before-change-protect (beg end)
2125 (defun allout-before-change-protect (beg end)
2126 "Outline before-change hook, regulates changes to concealed text.
2128 Reveal concealed text that would be changed by current command, and
2129 offer user choice to commit or forego the change. Unchanged text is
2130 reconcealed. User has option to have changed text reconcealed.
2132 Undo commands are specially treated - the user is not prompted for
2133 choice, the undoes are always committed (based on presumption that the
2134 things being undone were already subject to this regulation routine),
2135 and undoes always leave the changed stuff exposed.
2137 Changes to concealed regions are ignored while file is being written.
2138 \(This is for the sake of functions that do change the file during
2139 writes, like crypt and zip modes.)
2141 Locally bound in outline buffers to `before-change-functions', which
2142 in Emacs 19 is run before any change to the buffer.
2144 Any functions which set [`this-command' to `undo', or which set]
2145 `allout-override-protect' non-nil (as does, eg, allout-flag-chars)
2146 are exempt from this restriction."
2147 (if (and (allout-mode-p)
2148 ; allout-override-protect
2149 ; set by functions that know what
2150 ; they're doing, eg outline internals:
2151 (not allout-override-protect)
2152 (not allout-during-write-cue)
2153 (save-match-data ; Preserve operation position state.
2154 ; Both beginning and end chars must
2155 ; be exposed:
2156 (save-excursion (if (memq this-command '(newline open-line))
2157 ;; Compensate for stupid Emacs {new,
2158 ;; open-}line display optimization:
2159 (setq beg (1+ beg)
2160 end (1+ end)))
2161 (goto-char beg)
2162 (or (allout-hidden-p)
2163 (and (not (= beg end))
2164 (goto-char end)
2165 (allout-hidden-p))))))
2166 (save-match-data
2167 (if (equal this-command 'undo)
2168 ;; Allow undo without inhibition.
2169 ;; - Undoing new and open-line hits stupid Emacs redisplay
2170 ;; optimization (em 19 cmds.c, ~ line 200).
2171 ;; - Presumably, undoing what was properly protected when
2172 ;; done.
2173 ;; - Undo may be users' only recourse in protection faults.
2174 ;; So, expose what getting changed:
2175 (progn (message "Undo! - exposing concealed target...")
2176 (if (allout-hidden-p)
2177 (allout-show-children))
2178 (message "Undo!"))
2179 (let (response
2180 (rehide-completely (save-excursion (allout-goto-prefix)
2181 (allout-hidden-p)))
2182 rehide-place)
2184 (save-excursion
2185 (if (condition-case err
2186 ;; Condition case to catch keyboard quits during reads.
2187 (progn
2188 ; Give them a peek where
2189 (save-excursion
2190 (if (eolp) (setq rehide-place
2191 (allout-goto-prefix)))
2192 (allout-show-entry))
2193 ; Present the message, but...
2194 ; leave the cursor at the location
2195 ; until they respond:
2196 ; Then interpret the response:
2197 (while
2198 (progn
2199 (message (concat "Change inside concealed"
2200 " region - do it? "
2201 "(n or 'y'/'r'eclose)"))
2202 (setq response (read-char))
2203 (not
2204 (cond ((memq response '(?r ?R))
2205 (setq response 'reclose))
2206 ((memq response '(?y ?Y ? ))
2207 (setq response t))
2208 ((memq response '(?n ?N 127))
2209 (setq response nil)
2211 ((eq response ??)
2212 (message
2213 "`r' means `yes, then reclose'")
2214 nil)
2215 (t (message "Please answer y, n, or r")
2216 (sit-for 1)
2217 nil)))))
2218 response)
2219 ('quit nil))
2220 ; Continue:
2221 (if (eq response 'reclose)
2222 (save-excursion
2223 (if rehide-place (goto-char rehide-place))
2224 (if rehide-completely
2225 (allout-hide-current-entry-completely)
2226 (allout-hide-current-entry)))
2227 (if (allout-ascend-to-depth (1- (allout-recent-depth)))
2228 (allout-show-children)
2229 (allout-show-to-offshoot)))
2230 ; Prevent:
2231 (if rehide-completely
2232 (save-excursion
2233 (if rehide-place (goto-char rehide-place))
2234 (allout-hide-current-entry-completely))
2235 (allout-hide-current-entry))
2236 (error (concat
2237 "Change within concealed region prevented.")))))))
2238 ) ; if
2239 ) ; defun
2240 ;;;_ = allout-post-goto-bullet
2241 (defvar allout-post-goto-bullet nil
2242 "Outline internal var, for `allout-pre-command-business' hot-spot operation.
2244 When set, tells post-processing to reposition on topic bullet, and
2245 then unset it. Set by `allout-pre-command-business' when implementing
2246 hot-spot operation, where literal characters typed over a topic bullet
2247 are mapped to the command of the corresponding control-key on the
2248 `allout-mode-map'.")
2249 (make-variable-buffer-local 'allout-post-goto-bullet)
2250 ;;;_ > allout-post-command-business ()
2251 (defun allout-post-command-business ()
2252 "Outline `post-command-hook' function.
2254 - Null `allout-override-protect', so it's not left open.
2256 - Implement (and clear) `allout-post-goto-bullet', for hot-spot
2257 outline commands.
2259 - Massages buffer-undo-list so successive, standard character self-inserts are
2260 aggregated. This kludge compensates for lack of undo bunching when
2261 `before-change-functions' is used."
2263 ; Apply any external change func:
2264 (if (not (allout-mode-p)) ; In allout-mode.
2266 (setq allout-override-protect nil)
2267 (if allout-isearch-dynamic-expose
2268 (allout-isearch-rectification))
2269 (if allout-during-write-cue
2270 ;; Was used by allout-before-change-protect, done with it now:
2271 (setq allout-during-write-cue nil))
2272 ;; Undo bunching business:
2273 (if (and (listp buffer-undo-list) ; Undo history being kept.
2274 (equal this-command 'self-insert-command)
2275 (equal last-command 'self-insert-command))
2276 (let* ((prev-stuff (cdr buffer-undo-list))
2277 (before-prev-stuff (cdr (cdr prev-stuff)))
2278 cur-cell cur-from cur-to
2279 prev-cell prev-from prev-to)
2280 (if (and before-prev-stuff ; Goes back far enough to bother,
2281 (not (car prev-stuff)) ; and break before current,
2282 (not (car before-prev-stuff)) ; !and break before prev!
2283 (setq prev-cell (car (cdr prev-stuff))) ; contents now,
2284 (setq cur-cell (car buffer-undo-list)) ; contents prev.
2286 ;; cur contents denote a single char insertion:
2287 (numberp (setq cur-from (car cur-cell)))
2288 (numberp (setq cur-to (cdr cur-cell)))
2289 (= 1 (- cur-to cur-from))
2291 ;; prev contents denote fewer than aggregate-limit
2292 ;; insertions:
2293 (numberp (setq prev-from (car prev-cell)))
2294 (numberp (setq prev-to (cdr prev-cell)))
2295 ; Below threshold:
2296 (> allout-undo-aggregation (- prev-to prev-from)))
2297 (setq buffer-undo-list
2298 (cons (cons prev-from cur-to)
2299 (cdr (cdr (cdr buffer-undo-list))))))))
2300 ;; Implement -post-goto-bullet, if set: (must be after undo business)
2301 (if (and allout-post-goto-bullet
2302 (allout-current-bullet-pos))
2303 (progn (goto-char (allout-current-bullet-pos))
2304 (setq allout-post-goto-bullet nil)))
2306 ;;;_ > allout-pre-command-business ()
2307 (defun allout-pre-command-business ()
2308 "Outline `pre-command-hook' function for outline buffers.
2309 Implements special behavior when cursor is on bullet character.
2311 When the cursor is on the bullet character, self-insert characters are
2312 reinterpreted as the corresponding control-character in the
2313 `allout-mode-map'. The `allout-mode' `post-command-hook' insures that
2314 the cursor which has moved as a result of such reinterpretation is
2315 positioned on the bullet character of the destination topic.
2317 The upshot is that you can get easy, single (ie, unmodified) key
2318 outline maneuvering operations by positioning the cursor on the bullet
2319 char. When in this mode you can use regular cursor-positioning
2320 command/keystrokes to relocate the cursor off of a bullet character to
2321 return to regular interpretation of self-insert characters."
2322 (if (not (allout-mode-p))
2323 ;; Shouldn't be invoked if not in allout allout-mode, but just in case:
2325 ;; Register isearch status:
2326 (if (and (boundp 'isearch-mode) isearch-mode)
2327 (setq allout-pre-was-isearching t)
2328 (setq allout-pre-was-isearching nil))
2329 ;; Hot-spot navigation provisions:
2330 (if (and (eq this-command 'self-insert-command)
2331 (eq (point)(allout-current-bullet-pos)))
2332 (let* ((this-key-num (cond
2333 ((numberp last-command-char)
2334 last-command-char)
2335 ;; XXX Only XEmacs has characterp.
2336 ((and (fboundp 'characterp)
2337 (characterp last-command-char))
2338 (char-to-int last-command-char))
2339 (t 0)))
2340 mapped-binding)
2341 (if (zerop this-key-num)
2343 ; Map upper-register literals
2344 ; to lower register:
2345 (if (<= 96 this-key-num)
2346 (setq this-key-num (- this-key-num 32)))
2347 ; Check if we have a literal:
2348 (if (and (<= 64 this-key-num)
2349 (>= 96 this-key-num))
2350 (setq mapped-binding
2351 (lookup-key 'allout-mode-map
2352 (concat allout-command-prefix
2353 (char-to-string (- this-key-num
2354 64))))))
2355 (if mapped-binding
2356 (setq allout-post-goto-bullet t
2357 this-command mapped-binding)))))))
2358 ;;;_ > allout-find-file-hook ()
2359 (defun allout-find-file-hook ()
2360 "Activate `allout-mode' when `allout-auto-activation' & `allout-layout' are non-nil.
2362 See `allout-init' for setup instructions."
2363 (if (and allout-auto-activation
2364 (not (allout-mode-p))
2365 allout-layout)
2366 (allout-mode t)))
2367 ;;;_ > allout-isearch-rectification
2368 (defun allout-isearch-rectification ()
2369 "Rectify outline exposure before, during, or after isearch.
2371 Called as part of `allout-post-command-business'."
2373 (let ((isearching (and (boundp 'isearch-mode) isearch-mode)))
2374 (cond ((and isearching (not allout-pre-was-isearching))
2375 (allout-isearch-expose 'start))
2376 ((and isearching allout-pre-was-isearching)
2377 (allout-isearch-expose 'continue))
2378 ((and (not isearching) allout-pre-was-isearching)
2379 (allout-isearch-expose 'final))
2380 ;; Not and wasn't isearching:
2381 (t (setq allout-isearch-prior-pos nil)
2382 (setq allout-isearch-did-quit nil)))))
2383 ;;;_ = allout-isearch-was-font-lock
2384 (defvar allout-isearch-was-font-lock
2385 (and (boundp 'font-lock-mode) font-lock-mode))
2387 ;;;_ > allout-flag-region (from to flag)
2388 (defmacro allout-flag-region (from to flag)
2389 "Hide or show lines from FROM to TO, via Emacs selective-display FLAG char.
2390 Ie, text following flag C-m \(carriage-return) is hidden until the
2391 next C-j (newline) char.
2393 Returns the endpoint of the region."
2394 `(let ((buffer-read-only nil)
2395 (allout-override-protect t))
2396 (subst-char-in-region ,from ,to
2397 (if (= ,flag ?\n) ?\r ?\n)
2398 ,flag t)))
2400 ;;;_ > allout-isearch-expose (mode)
2401 (defun allout-isearch-expose (mode)
2402 "MODE is either 'clear, 'start, 'continue, or 'final."
2403 ;; allout-isearch-prior-pos encodes exposure status of prior pos:
2404 ;; (pos was-vis header-pos end-pos)
2405 ;; pos - point of concern
2406 ;; was-vis - t, else 'topic if entire topic was exposed, 'entry otherwise
2407 ;; Do reclosure or prior pos, as necessary:
2408 (if (eq mode 'start)
2409 (setq allout-isearch-was-font-lock (and (boundp 'font-lock-mode)
2410 font-lock-mode)
2411 font-lock-mode nil)
2412 (if (eq mode 'final)
2413 (setq font-lock-mode allout-isearch-was-font-lock))
2414 (if (and allout-isearch-prior-pos
2415 (listp allout-isearch-prior-pos))
2416 ;; Conceal prior peek:
2417 (allout-flag-region (car (cdr allout-isearch-prior-pos))
2418 (car (cdr (cdr allout-isearch-prior-pos)))
2419 ?\r)))
2420 (if (allout-visible-p)
2421 (setq allout-isearch-prior-pos nil)
2422 (if (not (eq mode 'final))
2423 (setq allout-isearch-prior-pos (cons (point) (allout-show-entry)))
2424 (if allout-isearch-did-quit
2426 (setq allout-isearch-prior-pos nil)
2427 (allout-show-children))))
2428 (setq allout-isearch-did-quit nil))
2429 ;;;_ > allout-enwrap-isearch ()
2430 (defun allout-enwrap-isearch ()
2431 "Impose `allout-mode' isearch-abort wrapper for dynamic exposure in isearch.
2433 The function checks to ensure that the rebinding is done only once."
2435 (add-hook 'isearch-mode-end-hook 'allout-isearch-rectification)
2436 (if (fboundp 'allout-real-isearch-abort)
2439 ; Ensure load of isearch-mode:
2440 (if (or (and (fboundp 'isearch-mode)
2441 (fboundp 'isearch-abort))
2442 (condition-case error
2443 (load-library "isearch-mode")
2444 ('file-error (message
2445 "Skipping isearch-mode provisions - %s '%s'"
2446 (car (cdr error))
2447 (car (cdr (cdr error))))
2448 (sit-for 1)
2449 ;; Inhibit subsequent tries and return nil:
2450 (setq allout-isearch-dynamic-expose nil))))
2451 ;; Isearch-mode loaded, encapsulate specific entry points for
2452 ;; outline dynamic-exposure business:
2453 (progn
2454 ;; stash crucial isearch-mode funcs under known, private
2455 ;; names, then register wrapper functions under the old
2456 ;; names, in their stead:
2457 (fset 'allout-real-isearch-abort (symbol-function 'isearch-abort))
2458 (fset 'isearch-abort 'allout-isearch-abort)))))
2459 ;;;_ > allout-isearch-abort ()
2460 (defun allout-isearch-abort ()
2461 "Wrapper for `allout-real-isearch-abort' \(which see), to register
2462 actual quits."
2463 (interactive)
2464 (setq allout-isearch-did-quit nil)
2465 (condition-case what
2466 (allout-real-isearch-abort)
2467 ('quit (setq allout-isearch-did-quit t)
2468 (signal 'quit nil))))
2470 ;;; Prevent unnecessary font-lock while isearching!
2471 (defvar isearch-was-font-locking nil)
2472 (defun isearch-inhibit-font-lock ()
2473 "Inhibit `font-lock-mode' while isearching - for use on `isearch-mode-hook'."
2474 (if (and (allout-mode-p) (boundp 'font-lock-mode) font-lock-mode)
2475 (setq isearch-was-font-locking t
2476 font-lock-mode nil)))
2477 (add-hook 'isearch-mode-hook 'isearch-inhibit-font-lock)
2478 (defun isearch-reenable-font-lock ()
2479 "Reenable font-lock after isearching - for use on isearch-mode-end-hook."
2480 (if (and (boundp 'font-lock-mode) font-lock-mode)
2481 (if (and (allout-mode-p) isearch-was-font-locking)
2482 (setq isearch-was-font-locking nil
2483 font-lock-mode t))))
2484 (add-hook 'isearch-mode-end-hook 'isearch-reenable-font-lock)
2486 ;;;_ - Topic Format Assessment
2487 ;;;_ > allout-solicit-alternate-bullet (depth &optional current-bullet)
2488 (defun allout-solicit-alternate-bullet (depth &optional current-bullet)
2490 "Prompt for and return a bullet char as an alternative to the current one.
2492 Offer one suitable for current depth DEPTH as default."
2494 (let* ((default-bullet (or (and (stringp current-bullet) current-bullet)
2495 (allout-bullet-for-depth depth)))
2496 (sans-escapes (regexp-sans-escapes allout-bullets-string))
2497 choice)
2498 (save-excursion
2499 (goto-char (allout-current-bullet-pos))
2500 (setq choice (solicit-char-in-string
2501 (format "Select bullet: %s ('%s' default): "
2502 sans-escapes
2503 default-bullet)
2504 sans-escapes
2505 t)))
2506 (message "")
2507 (if (string= choice "") default-bullet choice))
2509 ;;;_ > allout-distinctive-bullet (bullet)
2510 (defun allout-distinctive-bullet (bullet)
2511 "True if BULLET is one of those on `allout-distinctive-bullets-string'."
2512 (string-match (regexp-quote bullet) allout-distinctive-bullets-string))
2513 ;;;_ > allout-numbered-type-prefix (&optional prefix)
2514 (defun allout-numbered-type-prefix (&optional prefix)
2515 "True if current header prefix bullet is numbered bullet."
2516 (and allout-numbered-bullet
2517 (string= allout-numbered-bullet
2518 (if prefix
2519 (allout-get-prefix-bullet prefix)
2520 (allout-get-bullet)))))
2521 ;;;_ > allout-bullet-for-depth (&optional depth)
2522 (defun allout-bullet-for-depth (&optional depth)
2523 "Return outline topic bullet suited to optional DEPTH, or current depth."
2524 ;; Find bullet in plain-bullets-string modulo DEPTH.
2525 (if allout-stylish-prefixes
2526 (char-to-string (aref allout-plain-bullets-string
2527 (% (max 0 (- depth 2))
2528 allout-plain-bullets-string-len)))
2529 allout-primary-bullet)
2532 ;;;_ - Topic Production
2533 ;;;_ > allout-make-topic-prefix (&optional prior-bullet
2534 (defun allout-make-topic-prefix (&optional prior-bullet
2536 depth
2537 solicit
2538 number-control
2539 index)
2540 ;; Depth null means use current depth, non-null means we're either
2541 ;; opening a new topic after current topic, lower or higher, or we're
2542 ;; changing level of current topic.
2543 ;; Solicit dominates specified bullet-char.
2544 ;;;_ . Doc string:
2545 "Generate a topic prefix suitable for optional arg DEPTH, or current depth.
2547 All the arguments are optional.
2549 PRIOR-BULLET indicates the bullet of the prefix being changed, or
2550 nil if none. This bullet may be preserved (other options
2551 notwithstanding) if it is on the `allout-distinctive-bullets-string',
2552 for instance.
2554 Second arg NEW indicates that a new topic is being opened after the
2555 topic at point, if non-nil. Default bullet for new topics, eg, may
2556 be set (contingent to other args) to numbered bullets if previous
2557 sibling is one. The implication otherwise is that the current topic
2558 is being adjusted - shifted or rebulleted - and we don't consider
2559 bullet or previous sibling.
2561 Third arg DEPTH forces the topic prefix to that depth, regardless of
2562 the current topics' depth.
2564 If SOLICIT is non-nil, then the choice of bullet is solicited from
2565 user. If it's a character, then that character is offered as the
2566 default, otherwise the one suited to the context \(according to
2567 distinction or depth) is offered. \(This overrides other options,
2568 including, eg, a distinctive PRIOR-BULLET.) If non-nil, then the
2569 context-specific bullet is used.
2571 Fifth arg, NUMBER-CONTROL, matters only if `allout-numbered-bullet'
2572 is non-nil *and* soliciting was not explicitly invoked. Then
2573 NUMBER-CONTROL non-nil forces prefix to either numbered or
2574 denumbered format, depending on the value of the sixth arg, INDEX.
2576 \(Note that NUMBER-CONTROL does *not* apply to level 1 topics. Sorry...)
2578 If NUMBER-CONTROL is non-nil and sixth arg INDEX is non-nil then
2579 the prefix of the topic is forced to be numbered. Non-nil
2580 NUMBER-CONTROL and nil INDEX forces non-numbered format on the
2581 bullet. Non-nil NUMBER-CONTROL and non-nil, non-number INDEX means
2582 that the index for the numbered prefix will be derived, by counting
2583 siblings back to start of level. If INDEX is a number, then that
2584 number is used as the index for the numbered prefix (allowing, eg,
2585 sequential renumbering to not require this function counting back the
2586 index for each successive sibling)."
2587 ;;;_ . Code:
2588 ;; The options are ordered in likely frequence of use, most common
2589 ;; highest, least lowest. Ie, more likely to be doing prefix
2590 ;; adjustments than soliciting, and yet more than numbering.
2591 ;; Current prefix is least dominant, but most likely to be commonly
2592 ;; specified...
2594 (let* (body
2595 numbering
2596 denumbering
2597 (depth (or depth (allout-depth)))
2598 (header-lead allout-header-prefix)
2599 (bullet-char
2601 ;; Getting value for bullet char is practically the whole job:
2603 (cond
2604 ; Simplest situation - level 1:
2605 ((<= depth 1) (setq header-lead "") allout-primary-bullet)
2606 ; Simple, too: all asterisks:
2607 (allout-old-style-prefixes
2608 ;; Cheat - make body the whole thing, null out header-lead and
2609 ;; bullet-char:
2610 (setq body (make-string depth
2611 (string-to-char allout-primary-bullet)))
2612 (setq header-lead "")
2615 ;; (Neither level 1 nor old-style, so we're space padding.
2616 ;; Sneak it in the condition of the next case, whatever it is.)
2618 ;; Solicitation overrides numbering and other cases:
2619 ((progn (setq body (make-string (- depth 2) ?\ ))
2620 ;; The actual condition:
2621 solicit)
2622 (let* ((got (allout-solicit-alternate-bullet depth solicit)))
2623 ;; Gotta check whether we're numbering and got a numbered bullet:
2624 (setq numbering (and allout-numbered-bullet
2625 (not (and number-control (not index)))
2626 (string= got allout-numbered-bullet)))
2627 ;; Now return what we got, regardless:
2628 got))
2630 ;; Numbering invoked through args:
2631 ((and allout-numbered-bullet number-control)
2632 (if (setq numbering (not (setq denumbering (not index))))
2633 allout-numbered-bullet
2634 (if (and prior-bullet
2635 (not (string= allout-numbered-bullet
2636 prior-bullet)))
2637 prior-bullet
2638 (allout-bullet-for-depth depth))))
2640 ;;; Neither soliciting nor controlled numbering ;;;
2641 ;;; (may be controlled denumbering, tho) ;;;
2643 ;; Check wrt previous sibling:
2644 ((and new ; only check for new prefixes
2645 (<= depth (allout-depth))
2646 allout-numbered-bullet ; ... & numbering enabled
2647 (not denumbering)
2648 (let ((sibling-bullet
2649 (save-excursion
2650 ;; Locate correct sibling:
2651 (or (>= depth (allout-depth))
2652 (allout-ascend-to-depth depth))
2653 (allout-get-bullet))))
2654 (if (and sibling-bullet
2655 (string= allout-numbered-bullet sibling-bullet))
2656 (setq numbering sibling-bullet)))))
2658 ;; Distinctive prior bullet?
2659 ((and prior-bullet
2660 (allout-distinctive-bullet prior-bullet)
2661 ;; Either non-numbered:
2662 (or (not (and allout-numbered-bullet
2663 (string= prior-bullet allout-numbered-bullet)))
2664 ;; or numbered, and not denumbering:
2665 (setq numbering (not denumbering)))
2666 ;; Here 'tis:
2667 prior-bullet))
2669 ;; Else, standard bullet per depth:
2670 ((allout-bullet-for-depth depth)))))
2672 (concat header-lead
2673 body
2674 bullet-char
2675 (if numbering
2676 (format "%d" (cond ((and index (numberp index)) index)
2677 (new (1+ (allout-sibling-index depth)))
2678 ((allout-sibling-index))))))
2681 ;;;_ > allout-open-topic (relative-depth &optional before use_sib_bullet)
2682 (defun allout-open-topic (relative-depth &optional before use_sib_bullet)
2683 "Open a new topic at depth RELATIVE-DEPTH.
2685 New topic is situated after current one, unless optional flag BEFORE
2686 is non-nil, or unless current line is complete empty (not even
2687 whitespace), in which case open is done on current line.
2689 If USE_SIB_BULLET is true, use the bullet of the prior sibling.
2691 Nuances:
2693 - Creation of new topics is with respect to the visible topic
2694 containing the cursor, regardless of intervening concealed ones.
2696 - New headers are generally created after/before the body of a
2697 topic. However, they are created right at cursor location if the
2698 cursor is on a blank line, even if that breaks the current topic
2699 body. This is intentional, to provide a simple means for
2700 deliberately dividing topic bodies.
2702 - Double spacing of topic lists is preserved. Also, the first
2703 level two topic is created double-spaced (and so would be
2704 subsequent siblings, if that's left intact). Otherwise,
2705 single-spacing is used.
2707 - Creation of sibling or nested topics is with respect to the topic
2708 you're starting from, even when creating backwards. This way you
2709 can easily create a sibling in front of the current topic without
2710 having to go to its preceding sibling, and then open forward
2711 from there."
2713 (let* ((depth (+ (allout-current-depth) relative-depth))
2714 (opening-on-blank (if (looking-at "^\$")
2715 (not (setq before nil))))
2716 opening-numbered ; Will get while computing ref-topic, below
2717 ref-depth ; Will get while computing ref-topic, below
2718 ref-bullet ; Will get while computing ref-topic, next
2719 (ref-topic (save-excursion
2720 (cond ((< relative-depth 0)
2721 (allout-ascend-to-depth depth))
2722 ((>= relative-depth 1) nil)
2723 (t (allout-back-to-current-heading)))
2724 (setq ref-depth (allout-recent-depth))
2725 (setq ref-bullet
2726 (if (> allout-recent-prefix-end 1)
2727 (allout-recent-bullet)
2728 ""))
2729 (setq opening-numbered
2730 (save-excursion
2731 (and allout-numbered-bullet
2732 (or (<= relative-depth 0)
2733 (allout-descend-to-depth depth))
2734 (if (allout-numbered-type-prefix)
2735 allout-numbered-bullet))))
2736 (point)))
2737 dbl-space
2738 doing-beginning)
2740 (if (not opening-on-blank)
2741 ; Positioning and vertical
2742 ; padding - only if not
2743 ; opening-on-blank:
2744 (progn
2745 (goto-char ref-topic)
2746 (setq dbl-space ; Determine double space action:
2747 (or (and (<= relative-depth 0) ; not descending;
2748 (save-excursion
2749 ;; at b-o-b or preceded by a blank line?
2750 (or (> 0 (forward-line -1))
2751 (looking-at "^\\s-*$")
2752 (bobp)))
2753 (save-excursion
2754 ;; succeeded by a blank line?
2755 (allout-end-of-current-subtree)
2756 (bolp)))
2757 (and (= ref-depth 1)
2758 (or before
2759 (= depth 1)
2760 (save-excursion
2761 ;; Don't already have following
2762 ;; vertical padding:
2763 (not (allout-pre-next-preface)))))))
2765 ; Position to prior heading,
2766 ; if inserting backwards, and
2767 ; not going outwards:
2768 (if (and before (>= relative-depth 0))
2769 (progn (allout-back-to-current-heading)
2770 (setq doing-beginning (bobp))
2771 (if (not (bobp))
2772 (allout-previous-heading)))
2773 (if (and before (bobp))
2774 (allout-unprotected (open-line 1))))
2776 (if (<= relative-depth 0)
2777 ;; Not going inwards, don't snug up:
2778 (if doing-beginning
2779 (allout-unprotected (open-line (if dbl-space 2 1)))
2780 (if before
2781 (progn (end-of-line)
2782 (allout-pre-next-preface)
2783 (while (= ?\r (following-char))
2784 (forward-char 1))
2785 (if (not (looking-at "^$"))
2786 (allout-unprotected (open-line 1))))
2787 (allout-end-of-current-subtree)))
2788 ;; Going inwards - double-space if first offspring is,
2789 ;; otherwise snug up.
2790 (end-of-line) ; So we skip any concealed progeny.
2791 (allout-pre-next-preface)
2792 (if (bolp)
2793 ;; Blank lines between current header body and next
2794 ;; header - get to last substantive (non-white-space)
2795 ;; line in body:
2796 (re-search-backward "[^ \t\n]" nil t))
2797 (if (save-excursion
2798 (allout-next-heading)
2799 (if (> (allout-recent-depth) ref-depth)
2800 ;; This is an offspring.
2801 (progn (forward-line -1)
2802 (looking-at "^\\s-*$"))))
2803 (progn (forward-line 1)
2804 (allout-unprotected (open-line 1))))
2805 (end-of-line))
2806 ;;(if doing-beginning (goto-char doing-beginning))
2807 (if (not (bobp))
2808 (progn (if (and (not (> depth ref-depth))
2809 (not before))
2810 (allout-unprotected (open-line 1))
2811 (if (> depth ref-depth)
2812 (allout-unprotected (newline 1))
2813 (if dbl-space
2814 (allout-unprotected (open-line 1))
2815 (if (not before)
2816 (allout-unprotected (newline 1))))))
2817 (if dbl-space
2818 (allout-unprotected (newline 1)))
2819 (if (and (not (eobp))
2820 (not (bolp)))
2821 (forward-char 1))))
2823 (insert (concat (allout-make-topic-prefix opening-numbered
2825 depth)
2826 " "))
2828 ;;(if doing-beginning (save-excursion (newline (if dbl-space 2 1))))
2831 (allout-rebullet-heading (and use_sib_bullet ref-bullet);;; solicit
2832 depth ;;; depth
2833 nil ;;; number-control
2834 nil ;;; index
2835 t) (end-of-line)
2838 ;;;_ . open-topic contingencies
2839 ;;;_ ; base topic - one from which open was issued
2840 ;;;_ , beginning char
2841 ;;;_ , amount of space before will be used, unless opening in place
2842 ;;;_ , end char will be used, unless opening before (and it still may)
2843 ;;;_ ; absolute depth of new topic
2844 ;;;_ ! insert in place - overrides most stuff
2845 ;;;_ ; relative depth of new re base
2846 ;;;_ ; before or after base topic
2847 ;;;_ ; spacing around topic, if any, prior to new topic and at same depth
2848 ;;;_ ; buffer boundaries - special provisions for beginning and end ob
2849 ;;;_ ; level 1 topics have special provisions also - double space.
2850 ;;;_ ; location of new topic
2851 ;;;_ > allout-open-subtopic (arg)
2852 (defun allout-open-subtopic (arg)
2853 "Open new topic header at deeper level than the current one.
2855 Negative universal arg means to open deeper, but place the new topic
2856 prior to the current one."
2857 (interactive "p")
2858 (allout-open-topic 1 (> 0 arg)))
2859 ;;;_ > allout-open-sibtopic (arg)
2860 (defun allout-open-sibtopic (arg)
2861 "Open new topic header at same level as the current one.
2863 Positive universal arg means to use the bullet of the prior sibling.
2865 Negative universal arg means to place the new topic prior to the current
2866 one."
2867 (interactive "p")
2868 (allout-open-topic 0 (> 0 arg) (< 1 arg)))
2869 ;;;_ > allout-open-supertopic (arg)
2870 (defun allout-open-supertopic (arg)
2871 "Open new topic header at shallower level than the current one.
2873 Negative universal arg means to open shallower, but place the new
2874 topic prior to the current one."
2876 (interactive "p")
2877 (allout-open-topic -1 (> 0 arg)))
2879 ;;;_ - Outline Alteration
2880 ;;;_ : Topic Modification
2881 ;;;_ = allout-former-auto-filler
2882 (defvar allout-former-auto-filler nil
2883 "Name of modal fill function being wrapped by `allout-auto-fill'.")
2884 ;;;_ > allout-auto-fill ()
2885 (defun allout-auto-fill ()
2886 "`allout-mode' autofill function.
2888 Maintains outline hanging topic indentation if
2889 `allout-use-hanging-indents' is set."
2890 (let ((fill-prefix (if allout-use-hanging-indents
2891 ;; Check for topic header indentation:
2892 (save-excursion
2893 (beginning-of-line)
2894 (if (looking-at allout-regexp)
2895 ;; ... construct indentation to account for
2896 ;; length of topic prefix:
2897 (make-string (progn (allout-end-of-prefix)
2898 (current-column))
2899 ?\ ))))))
2900 (if (or allout-former-auto-filler allout-use-hanging-indents)
2901 (do-auto-fill))))
2902 ;;;_ > allout-reindent-body (old-depth new-depth &optional number)
2903 (defun allout-reindent-body (old-depth new-depth &optional number)
2904 "Reindent body lines which were indented at OLD-DEPTH to NEW-DEPTH.
2906 Optional arg NUMBER indicates numbering is being added, and it must
2907 be accommodated.
2909 Note that refill of indented paragraphs is not done."
2911 (save-excursion
2912 (allout-end-of-prefix)
2913 (let* ((new-margin (current-column))
2914 excess old-indent-begin old-indent-end
2915 curr-ind
2916 ;; We want the column where the header-prefix text started
2917 ;; *before* the prefix was changed, so we infer it relative
2918 ;; to the new margin and the shift in depth:
2919 (old-margin (+ old-depth (- new-margin new-depth))))
2921 ;; Process lines up to (but excluding) next topic header:
2922 (allout-unprotected
2923 (save-match-data
2924 (while
2925 (and (re-search-forward "[\n\r]\\(\\s-*\\)"
2928 ;; Register the indent data, before we reset the
2929 ;; match data with a subsequent `looking-at':
2930 (setq old-indent-begin (match-beginning 1)
2931 old-indent-end (match-end 1))
2932 (not (looking-at allout-regexp)))
2933 (if (> 0 (setq excess (- (current-column)
2934 old-margin)))
2935 ;; Text starts left of old margin - don't adjust:
2937 ;; Text was hanging at or right of old left margin -
2938 ;; reindent it, preserving its existing indentation
2939 ;; beyond the old margin:
2940 (delete-region old-indent-begin old-indent-end)
2941 (indent-to (+ new-margin excess)))))))))
2942 ;;;_ > allout-rebullet-current-heading (arg)
2943 (defun allout-rebullet-current-heading (arg)
2944 "Solicit new bullet for current visible heading."
2945 (interactive "p")
2946 (let ((initial-col (current-column))
2947 (on-bullet (eq (point)(allout-current-bullet-pos)))
2948 (backwards (if (< arg 0)
2949 (setq arg (* arg -1)))))
2950 (while (> arg 0)
2951 (save-excursion (allout-back-to-current-heading)
2952 (allout-end-of-prefix)
2953 (allout-rebullet-heading t ;;; solicit
2954 nil ;;; depth
2955 nil ;;; number-control
2956 nil ;;; index
2957 t)) ;;; do-successors
2958 (setq arg (1- arg))
2959 (if (<= arg 0)
2961 (setq initial-col nil) ; Override positioning back to init col
2962 (if (not backwards)
2963 (allout-next-visible-heading 1)
2964 (allout-goto-prefix)
2965 (allout-next-visible-heading -1))))
2966 (message "Done.")
2967 (cond (on-bullet (goto-char (allout-current-bullet-pos)))
2968 (initial-col (move-to-column initial-col)))))
2969 ;;;_ > allout-rebullet-heading (&optional solicit ...)
2970 (defun allout-rebullet-heading (&optional solicit
2971 new-depth
2972 number-control
2973 index
2974 do-successors)
2976 "Adjust bullet of current topic prefix.
2978 If SOLICIT is non-nil, then the choice of bullet is solicited from
2979 user. If it's a character, then that character is offered as the
2980 default, otherwise the one suited to the context \(according to
2981 distinction or depth) is offered. If non-nil, then the
2982 context-specific bullet is just used.
2984 Second arg NEW-DEPTH forces the topic prefix to that depth, regardless
2985 of the topic's current depth.
2987 Third arg NUMBER-CONTROL can force the prefix to or away from
2988 numbered form. It has effect only if `allout-numbered-bullet' is
2989 non-nil and soliciting was not explicitly invoked (via first arg).
2990 Its effect, numbering or denumbering, then depends on the setting
2991 of the fourth arg, INDEX.
2993 If NUMBER-CONTROL is non-nil and fourth arg INDEX is nil, then the
2994 prefix of the topic is forced to be non-numbered. Null index and
2995 non-nil NUMBER-CONTROL forces denumbering. Non-nil INDEX (and
2996 non-nil NUMBER-CONTROL) forces a numbered-prefix form. If non-nil
2997 INDEX is a number, then that number is used for the numbered
2998 prefix. Non-nil and non-number means that the index for the
2999 numbered prefix will be derived by `allout-make-topic-prefix'.
3001 Fifth arg DO-SUCCESSORS t means re-resolve count on succeeding
3002 siblings.
3004 Cf vars `allout-stylish-prefixes', `allout-old-style-prefixes',
3005 and `allout-numbered-bullet', which all affect the behavior of
3006 this function."
3008 (let* ((current-depth (allout-depth))
3009 (new-depth (or new-depth current-depth))
3010 (mb allout-recent-prefix-beginning)
3011 (me allout-recent-prefix-end)
3012 (current-bullet (buffer-substring (- me 1) me))
3013 (new-prefix (allout-make-topic-prefix current-bullet
3015 new-depth
3016 solicit
3017 number-control
3018 index)))
3020 ;; Is new one is identical to old?
3021 (if (and (= current-depth new-depth)
3022 (string= current-bullet
3023 (substring new-prefix (1- (length new-prefix)))))
3024 ;; Nothing to do:
3027 ;; New prefix probably different from old:
3028 ; get rid of old one:
3029 (allout-unprotected (delete-region mb me))
3030 (goto-char mb)
3031 ; Dispense with number if
3032 ; numbered-bullet prefix:
3033 (if (and allout-numbered-bullet
3034 (string= allout-numbered-bullet current-bullet)
3035 (looking-at "[0-9]+"))
3036 (allout-unprotected
3037 (delete-region (match-beginning 0)(match-end 0))))
3039 ; Put in new prefix:
3040 (allout-unprotected (insert new-prefix))
3042 ;; Reindent the body if elected and margin changed:
3043 (if (and allout-reindent-bodies
3044 (not (= new-depth current-depth)))
3045 (allout-reindent-body current-depth new-depth))
3047 ;; Recursively rectify successive siblings of orig topic if
3048 ;; caller elected for it:
3049 (if do-successors
3050 (save-excursion
3051 (while (allout-next-sibling new-depth nil)
3052 (setq index
3053 (cond ((numberp index) (1+ index))
3054 ((not number-control) (allout-sibling-index))))
3055 (if (allout-numbered-type-prefix)
3056 (allout-rebullet-heading nil ;;; solicit
3057 new-depth ;;; new-depth
3058 number-control;;; number-control
3059 index ;;; index
3060 nil))))) ;;;(dont!)do-successors
3061 ) ; (if (and (= current-depth new-depth)...))
3062 ) ; let* ((current-depth (allout-depth))...)
3063 ) ; defun
3064 ;;;_ > allout-rebullet-topic (arg)
3065 (defun allout-rebullet-topic (arg)
3066 "Like `allout-rebullet-topic-grunt', but start from topic visible at point.
3068 Descends into invisible as well as visible topics, however.
3070 With repeat count, shift topic depth by that amount."
3071 (interactive "P")
3072 (let ((start-col (current-column))
3073 (was-eol (eolp)))
3074 (save-excursion
3075 ;; Normalize arg:
3076 (cond ((null arg) (setq arg 0))
3077 ((listp arg) (setq arg (car arg))))
3078 ;; Fill the user in, in case we're shifting a big topic:
3079 (if (not (zerop arg)) (message "Shifting..."))
3080 (allout-back-to-current-heading)
3081 (if (<= (+ (allout-recent-depth) arg) 0)
3082 (error "Attempt to shift topic below level 1"))
3083 (allout-rebullet-topic-grunt arg)
3084 (if (not (zerop arg)) (message "Shifting... done.")))
3085 (move-to-column (max 0 (+ start-col arg)))))
3086 ;;;_ > allout-rebullet-topic-grunt (&optional relative-depth ...)
3087 (defun allout-rebullet-topic-grunt (&optional relative-depth
3088 starting-depth
3089 starting-point
3090 index
3091 do-successors)
3093 "Rebullet the topic at point, visible or invisible, and all
3094 contained subtopics. See `allout-rebullet-heading' for rebulleting
3095 behavior.
3097 Arg RELATIVE-DEPTH means to shift the depth of the entire
3098 topic that amount.
3100 \(fn &optional RELATIVE-DEPTH)"
3102 ;; All args except the first one are for internal recursive use by the
3103 ;; function itself.
3105 (let* ((relative-depth (or relative-depth 0))
3106 (new-depth (allout-depth))
3107 (starting-depth (or starting-depth new-depth))
3108 (on-starting-call (null starting-point))
3109 (index (or index
3110 ;; Leave index null on starting call, so rebullet-heading
3111 ;; calculates it at what might be new depth:
3112 (and (or (zerop relative-depth)
3113 (not on-starting-call))
3114 (allout-sibling-index))))
3115 (moving-outwards (< 0 relative-depth))
3116 (starting-point (or starting-point (point))))
3118 ;; Sanity check for excessive promotion done only on starting call:
3119 (and on-starting-call
3120 moving-outwards
3121 (> 0 (+ starting-depth relative-depth))
3122 (error "Attempt to shift topic out beyond level 1")) ;;; ====>
3124 (cond ((= starting-depth new-depth)
3125 ;; We're at depth to work on this one:
3126 (allout-rebullet-heading nil ;;; solicit
3127 (+ starting-depth ;;; starting-depth
3128 relative-depth)
3129 nil ;;; number
3130 index ;;; index
3131 ;; Every contained topic will get hit,
3132 ;; and we have to get to outside ones
3133 ;; deliberately:
3134 nil) ;;; do-successors
3135 ;; ... and work on subsequent ones which are at greater depth:
3136 (setq index 0)
3137 (allout-next-heading)
3138 (while (and (not (eobp))
3139 (< starting-depth (allout-recent-depth)))
3140 (setq index (1+ index))
3141 (allout-rebullet-topic-grunt relative-depth ;;; relative-depth
3142 (1+ starting-depth);;;starting-depth
3143 starting-point ;;; starting-point
3144 index))) ;;; index
3146 ((< starting-depth new-depth)
3147 ;; Rare case - subtopic more than one level deeper than parent.
3148 ;; Treat this one at an even deeper level:
3149 (allout-rebullet-topic-grunt relative-depth ;;; relative-depth
3150 new-depth ;;; starting-depth
3151 starting-point ;;; starting-point
3152 index))) ;;; index
3154 (if on-starting-call
3155 (progn
3156 ;; Rectify numbering of former siblings of the adjusted topic,
3157 ;; if topic has changed depth
3158 (if (or do-successors
3159 (and (not (zerop relative-depth))
3160 (or (= (allout-recent-depth) starting-depth)
3161 (= (allout-recent-depth) (+ starting-depth
3162 relative-depth)))))
3163 (allout-rebullet-heading nil nil nil nil t))
3164 ;; Now rectify numbering of new siblings of the adjusted topic,
3165 ;; if depth has been changed:
3166 (progn (goto-char starting-point)
3167 (if (not (zerop relative-depth))
3168 (allout-rebullet-heading nil nil nil nil t)))))
3171 ;;;_ > allout-renumber-to-depth (&optional depth)
3172 (defun allout-renumber-to-depth (&optional depth)
3173 "Renumber siblings at current depth.
3175 Affects superior topics if optional arg DEPTH is less than current depth.
3177 Returns final depth."
3179 ;; Proceed by level, processing subsequent siblings on each,
3180 ;; ascending until we get shallower than the start depth:
3182 (let ((ascender (allout-depth))
3183 was-eobp)
3184 (while (and (not (eobp))
3185 (allout-depth)
3186 (>= (allout-recent-depth) depth)
3187 (>= ascender depth))
3188 ; Skip over all topics at
3189 ; lesser depths, which can not
3190 ; have been disturbed:
3191 (while (and (not (setq was-eobp (eobp)))
3192 (> (allout-recent-depth) ascender))
3193 (allout-next-heading))
3194 ; Prime ascender for ascension:
3195 (setq ascender (1- (allout-recent-depth)))
3196 (if (>= (allout-recent-depth) depth)
3197 (allout-rebullet-heading nil ;;; solicit
3198 nil ;;; depth
3199 nil ;;; number-control
3200 nil ;;; index
3201 t)) ;;; do-successors
3202 (if was-eobp (goto-char (point-max)))))
3203 (allout-recent-depth))
3204 ;;;_ > allout-number-siblings (&optional denumber)
3205 (defun allout-number-siblings (&optional denumber)
3206 "Assign numbered topic prefix to this topic and its siblings.
3208 With universal argument, denumber - assign default bullet to this
3209 topic and its siblings.
3211 With repeated universal argument (`^U^U'), solicit bullet for each
3212 rebulleting each topic at this level."
3214 (interactive "P")
3216 (save-excursion
3217 (allout-back-to-current-heading)
3218 (allout-beginning-of-level)
3219 (let ((depth (allout-recent-depth))
3220 (index (if (not denumber) 1))
3221 (use-bullet (equal '(16) denumber))
3222 (more t))
3223 (while more
3224 (allout-rebullet-heading use-bullet ;;; solicit
3225 depth ;;; depth
3226 t ;;; number-control
3227 index ;;; index
3228 nil) ;;; do-successors
3229 (if index (setq index (1+ index)))
3230 (setq more (allout-next-sibling depth nil))))))
3231 ;;;_ > allout-shift-in (arg)
3232 (defun allout-shift-in (arg)
3233 "Increase depth of current heading and any topics collapsed within it."
3234 (interactive "p")
3235 (allout-rebullet-topic arg))
3236 ;;;_ > allout-shift-out (arg)
3237 (defun allout-shift-out (arg)
3238 "Decrease depth of current heading and any topics collapsed within it."
3239 (interactive "p")
3240 (allout-rebullet-topic (* arg -1)))
3241 ;;;_ : Surgery (kill-ring) functions with special provisions for outlines:
3242 ;;;_ > allout-kill-line (&optional arg)
3243 (defun allout-kill-line (&optional arg)
3244 "Kill line, adjusting subsequent lines suitably for outline mode."
3246 (interactive "*P")
3247 (if (not (and (allout-mode-p) ; active outline mode,
3248 allout-numbered-bullet ; numbers may need adjustment,
3249 (bolp) ; may be clipping topic head,
3250 (looking-at allout-regexp))) ; are clipping topic head.
3251 ;; Above conditions do not obtain - just do a regular kill:
3252 (kill-line arg)
3253 ;; Ah, have to watch out for adjustments:
3254 (let* ((depth (allout-depth)))
3255 ; Do the kill:
3256 (kill-line arg)
3257 ; Provide some feedback:
3258 (sit-for 0)
3259 (save-excursion
3260 ; Start with the topic
3261 ; following killed line:
3262 (if (not (looking-at allout-regexp))
3263 (allout-next-heading))
3264 (allout-renumber-to-depth depth)))))
3265 ;;;_ > allout-kill-topic ()
3266 (defun allout-kill-topic ()
3267 "Kill topic together with subtopics.
3269 Leaves primary topic's trailing vertical whitespace, if any."
3271 ;; Some finagling is done to make complex topic kills appear faster
3272 ;; than they actually are. A redisplay is performed immediately
3273 ;; after the region is disposed of, though the renumbering process
3274 ;; has yet to be performed. This means that there may appear to be
3275 ;; a lag *after* the kill has been performed.
3277 (interactive)
3278 (let* ((beg (prog1 (allout-back-to-current-heading)(beginning-of-line)))
3279 (depth (allout-recent-depth)))
3280 (allout-end-of-current-subtree)
3281 (if (not (eobp))
3282 (if (or (not (looking-at "^$"))
3283 ;; A blank line - cut it with this topic *unless* this
3284 ;; is the last topic at this level, in which case
3285 ;; we'll leave the blank line as part of the
3286 ;; containing topic:
3287 (save-excursion
3288 (and (allout-next-heading)
3289 (>= (allout-recent-depth) depth))))
3290 (forward-char 1)))
3292 (kill-region beg (point))
3293 (sit-for 0)
3294 (save-excursion
3295 (allout-renumber-to-depth depth))))
3296 ;;;_ > allout-yank-processing ()
3297 (defun allout-yank-processing (&optional arg)
3299 "Incidental outline specific business to be done just after text yanks.
3301 Does depth adjustment of yanked topics, when:
3303 1 the stuff being yanked starts with a valid outline header prefix, and
3304 2 it is being yanked at the end of a line which consists of only a valid
3305 topic prefix.
3307 Also, adjusts numbering of subsequent siblings when appropriate.
3309 Depth adjustment alters the depth of all the topics being yanked
3310 the amount it takes to make the first topic have the depth of the
3311 header into which it's being yanked.
3313 The point is left in front of yanked, adjusted topics, rather than
3314 at the end (and vice-versa with the mark). Non-adjusted yanks,
3315 however, are left exactly like normal, not outline specific yanks."
3317 (interactive "*P")
3318 ; Get to beginning, leaving
3319 ; region around subject:
3320 (if (< (my-mark-marker t) (point))
3321 (exchange-point-and-mark))
3322 (let* ((subj-beg (point))
3323 (subj-end (my-mark-marker t))
3324 ;; 'resituate' if yanking an entire topic into topic header:
3325 (resituate (and (allout-e-o-prefix-p)
3326 (looking-at (concat "\\(" allout-regexp "\\)"))
3327 (allout-prefix-data (match-beginning 1)
3328 (match-end 1))))
3329 ;; `rectify-numbering' if resituating (where several topics may
3330 ;; be resituating) or yanking a topic into a topic slot (bol):
3331 (rectify-numbering (or resituate
3332 (and (bolp) (looking-at allout-regexp)))))
3333 (if resituate
3334 ; The yanked stuff is a topic:
3335 (let* ((prefix-len (- (match-end 1) subj-beg))
3336 (subj-depth (allout-recent-depth))
3337 (prefix-bullet (allout-recent-bullet))
3338 (adjust-to-depth
3339 ;; Nil if adjustment unnecessary, otherwise depth to which
3340 ;; adjustment should be made:
3341 (save-excursion
3342 (and (goto-char subj-end)
3343 (eolp)
3344 (goto-char subj-beg)
3345 (and (looking-at allout-regexp)
3346 (progn
3347 (beginning-of-line)
3348 (not (= (point) subj-beg)))
3349 (looking-at allout-regexp)
3350 (allout-prefix-data (match-beginning 0)
3351 (match-end 0)))
3352 (allout-recent-depth))))
3353 done
3354 (more t))
3355 (setq rectify-numbering allout-numbered-bullet)
3356 (if adjust-to-depth
3357 ; Do the adjustment:
3358 (progn
3359 (message "... yanking") (sit-for 0)
3360 (save-restriction
3361 (narrow-to-region subj-beg subj-end)
3362 ; Trim off excessive blank
3363 ; line at end, if any:
3364 (goto-char (point-max))
3365 (if (looking-at "^$")
3366 (allout-unprotected (delete-char -1)))
3367 ; Work backwards, with each
3368 ; shallowest level,
3369 ; successively excluding the
3370 ; last processed topic from
3371 ; the narrow region:
3372 (while more
3373 (allout-back-to-current-heading)
3374 ; go as high as we can in each bunch:
3375 (while (allout-ascend-to-depth (1- (allout-depth))))
3376 (save-excursion
3377 (allout-rebullet-topic-grunt (- adjust-to-depth
3378 subj-depth))
3379 (allout-depth))
3380 (if (setq more (not (bobp)))
3381 (progn (widen)
3382 (forward-char -1)
3383 (narrow-to-region subj-beg (point))))))
3384 (message "")
3385 ;; Preserve new bullet if it's a distinctive one, otherwise
3386 ;; use old one:
3387 (if (string-match (regexp-quote prefix-bullet)
3388 allout-distinctive-bullets-string)
3389 ; Delete from bullet of old to
3390 ; before bullet of new:
3391 (progn
3392 (beginning-of-line)
3393 (delete-region (point) subj-beg)
3394 (set-marker (my-mark-marker t) subj-end)
3395 (goto-char subj-beg)
3396 (allout-end-of-prefix))
3397 ; Delete base subj prefix,
3398 ; leaving old one:
3399 (delete-region (point) (+ (point)
3400 prefix-len
3401 (- adjust-to-depth subj-depth)))
3402 ; and delete residual subj
3403 ; prefix digits and space:
3404 (while (looking-at "[0-9]") (delete-char 1))
3405 (if (looking-at " ") (delete-char 1))))
3406 (exchange-point-and-mark))))
3407 (if rectify-numbering
3408 (progn
3409 (save-excursion
3410 ; Give some preliminary feedback:
3411 (message "... reconciling numbers") (sit-for 0)
3412 ; ... and renumber, in case necessary:
3413 (goto-char subj-beg)
3414 (if (allout-goto-prefix)
3415 (allout-rebullet-heading nil ;;; solicit
3416 (allout-depth) ;;; depth
3417 nil ;;; number-control
3418 nil ;;; index
3420 (message ""))))
3421 (if (not resituate)
3422 (exchange-point-and-mark))))
3423 ;;;_ > allout-yank (&optional arg)
3424 (defun allout-yank (&optional arg)
3425 "`allout-mode' yank, with depth and numbering adjustment of yanked topics.
3427 Non-topic yanks work no differently than normal yanks.
3429 If a topic is being yanked into a bare topic prefix, the depth of the
3430 yanked topic is adjusted to the depth of the topic prefix.
3432 1 we're yanking in an `allout-mode' buffer
3433 2 the stuff being yanked starts with a valid outline header prefix, and
3434 3 it is being yanked at the end of a line which consists of only a valid
3435 topic prefix.
3437 If these conditions hold then the depth of the yanked topics are all
3438 adjusted the amount it takes to make the first one at the depth of the
3439 header into which it's being yanked.
3441 The point is left in front of yanked, adjusted topics, rather than
3442 at the end (and vice-versa with the mark). Non-adjusted yanks,
3443 however, (ones that don't qualify for adjustment) are handled
3444 exactly like normal yanks.
3446 Numbering of yanked topics, and the successive siblings at the depth
3447 into which they're being yanked, is adjusted.
3449 `allout-yank-pop' works with `allout-yank' just like normal yank-pop
3450 works with normal yank in non-outline buffers."
3452 (interactive "*P")
3453 (setq this-command 'yank)
3454 (yank arg)
3455 (if (allout-mode-p)
3456 (allout-yank-processing)))
3457 ;;;_ > allout-yank-pop (&optional arg)
3458 (defun allout-yank-pop (&optional arg)
3459 "Yank-pop like `allout-yank' when popping to bare outline prefixes.
3461 Adapts level of popped topics to level of fresh prefix.
3463 Note - prefix changes to distinctive bullets will stick, if followed
3464 by pops to non-distinctive yanks. Bug..."
3466 (interactive "*p")
3467 (setq this-command 'yank)
3468 (yank-pop arg)
3469 (if (allout-mode-p)
3470 (allout-yank-processing)))
3472 ;;;_ - Specialty bullet functions
3473 ;;;_ : File Cross references
3474 ;;;_ > allout-resolve-xref ()
3475 (defun allout-resolve-xref ()
3476 "Pop to file associated with current heading, if it has an xref bullet.
3478 \(Works according to setting of `allout-file-xref-bullet')."
3479 (interactive)
3480 (if (not allout-file-xref-bullet)
3481 (error
3482 "outline cross references disabled - no `allout-file-xref-bullet'")
3483 (if (not (string= (allout-current-bullet) allout-file-xref-bullet))
3484 (error "current heading lacks cross-reference bullet `%s'"
3485 allout-file-xref-bullet)
3486 (let (file-name)
3487 (save-excursion
3488 (let* ((text-start allout-recent-prefix-end)
3489 (heading-end (progn (end-of-line) (point))))
3490 (goto-char text-start)
3491 (setq file-name
3492 (if (re-search-forward "\\s-\\(\\S-*\\)" heading-end t)
3493 (buffer-substring (match-beginning 1) (match-end 1))))))
3494 (setq file-name
3495 (if (not (= (aref file-name 0) ?:))
3496 (expand-file-name file-name)
3497 ; A registry-files ref, strip the `:'
3498 ; and try to follow it:
3499 (let ((reg-ref (reference-registered-file
3500 (substring file-name 1) nil t)))
3501 (if reg-ref (car (cdr reg-ref))))))
3502 (if (or (file-exists-p file-name)
3503 (if (file-writable-p file-name)
3504 (y-or-n-p (format "%s not there, create one? "
3505 file-name))
3506 (error "%s not found and can't be created" file-name)))
3507 (condition-case failure
3508 (find-file-other-window file-name)
3509 ('error failure))
3510 (error "%s not found" file-name))
3516 ;;;_ #6 Exposure Control
3518 ;;;_ - Fundamental
3519 ;;;_ > allout-flag-current-subtree (flag)
3520 (defun allout-flag-current-subtree (flag)
3521 "Hide or show subtree of currently-visible topic.
3523 See `allout-flag-region' for more details."
3525 (save-excursion
3526 (allout-back-to-current-heading)
3527 (allout-flag-region (point)
3528 (progn (allout-end-of-current-subtree) (1- (point)))
3529 flag)))
3531 ;;;_ - Topic-specific
3532 ;;;_ > allout-show-entry ()
3533 (defun allout-show-entry ()
3534 "Like `allout-show-current-entry', reveals entries nested in hidden topics.
3536 This is a way to give restricted peek at a concealed locality without the
3537 expense of exposing its context, but can leave the outline with aberrant
3538 exposure. `allout-hide-current-entry-completely' or `allout-show-to-offshoot'
3539 should be used after the peek to rectify the exposure."
3541 (interactive)
3542 (save-excursion
3543 (let ((at (point))
3544 beg end)
3545 (allout-goto-prefix)
3546 (setq beg (if (= (preceding-char) ?\r) (1- (point)) (point)))
3547 (re-search-forward "[\n\r]" nil t)
3548 (setq end (1- (if (< at (point))
3549 ;; We're on topic head line - show only it:
3550 (point)
3551 ;; or we're in body - include it:
3552 (max beg (or (allout-pre-next-preface) (point))))))
3553 (allout-flag-region beg end ?\n)
3554 (list beg end))))
3555 ;;;_ > allout-show-children (&optional level strict)
3556 (defun allout-show-children (&optional level strict)
3558 "If point is visible, show all direct subheadings of this heading.
3560 Otherwise, do `allout-show-to-offshoot', and then show subheadings.
3562 Optional LEVEL specifies how many levels below the current level
3563 should be shown, or all levels if t. Default is 1.
3565 Optional STRICT means don't resort to -show-to-offshoot, no matter
3566 what. This is basically so -show-to-offshoot, which is called by
3567 this function, can employ the pure offspring-revealing capabilities of
3570 Returns point at end of subtree that was opened, if any. (May get a
3571 point of non-opened subtree?)"
3573 (interactive "p")
3574 (let (max-pos)
3575 (if (and (not strict)
3576 (allout-hidden-p))
3578 (progn (allout-show-to-offshoot) ; Point's concealed, open to
3579 ; expose it.
3580 ;; Then recurse, but with "strict" set so we don't
3581 ;; infinite regress:
3582 (setq max-pos (allout-show-children level t)))
3584 (save-excursion
3585 (save-restriction
3586 (let* ((start-pt (point))
3587 (chart (allout-chart-subtree (or level 1)))
3588 (to-reveal (allout-chart-to-reveal chart (or level 1))))
3589 (goto-char start-pt)
3590 (if (and strict (= (preceding-char) ?\r))
3591 ;; Concealed root would already have been taken care of,
3592 ;; unless strict was set.
3593 (progn
3594 (allout-flag-region (point) (allout-snug-back) ?\n)
3595 (if allout-show-bodies
3596 (progn (goto-char (car to-reveal))
3597 (allout-show-current-entry)))))
3598 (while to-reveal
3599 (goto-char (car to-reveal))
3600 (allout-flag-region (point) (allout-snug-back) ?\n)
3601 (if allout-show-bodies
3602 (progn (goto-char (car to-reveal))
3603 (allout-show-current-entry)))
3604 (setq to-reveal (cdr to-reveal)))))))))
3605 ;;;_ > allout-hide-point-reconcile ()
3606 (defun allout-hide-reconcile ()
3607 "Like `allout-hide-current-entry'; hides completely if within hidden region.
3609 Specifically intended for aberrant exposure states, like entries that were
3610 exposed by `allout-show-entry' but are within otherwise concealed regions."
3611 (interactive)
3612 (save-excursion
3613 (allout-goto-prefix)
3614 (allout-flag-region (if (not (bobp)) (1- (point)) (point))
3615 (progn (allout-pre-next-preface)
3616 (if (= ?\r (following-char))
3617 (point)
3618 (1- (point))))
3619 ?\r)))
3620 ;;;_ > allout-show-to-offshoot ()
3621 (defun allout-show-to-offshoot ()
3622 "Like `allout-show-entry', but reveals all concealed ancestors, as well.
3624 As with `allout-hide-current-entry-completely', useful for rectifying
3625 aberrant exposure states produced by `allout-show-entry'."
3627 (interactive)
3628 (save-excursion
3629 (let ((orig-pt (point))
3630 (orig-pref (allout-goto-prefix))
3631 (last-at (point))
3632 bag-it)
3633 (while (or bag-it (= (preceding-char) ?\r))
3634 (beginning-of-line)
3635 (if (= last-at (setq last-at (point)))
3636 ;; Oops, we're not making any progress! Show the current
3637 ;; topic completely, and bag this try.
3638 (progn (beginning-of-line)
3639 (allout-show-current-subtree)
3640 (goto-char orig-pt)
3641 (setq bag-it t)
3642 (beep)
3643 (message "%s: %s"
3644 "allout-show-to-offshoot: "
3645 "Aberrant nesting encountered.")))
3646 (allout-show-children)
3647 (goto-char orig-pref))
3648 (goto-char orig-pt)))
3649 (if (allout-hidden-p)
3650 (allout-show-entry)))
3651 ;;;_ > allout-hide-current-entry ()
3652 (defun allout-hide-current-entry ()
3653 "Hide the body directly following this heading."
3654 (interactive)
3655 (allout-back-to-current-heading)
3656 (save-excursion
3657 (allout-flag-region (point)
3658 (progn (allout-end-of-current-entry) (point))
3659 ?\r)))
3660 ;;;_ > allout-show-current-entry (&optional arg)
3661 (defun allout-show-current-entry (&optional arg)
3663 "Show body following current heading, or hide the entry if repeat count."
3665 (interactive "P")
3666 (if arg
3667 (allout-hide-current-entry)
3668 (save-excursion
3669 (allout-flag-region (point)
3670 (progn (allout-end-of-current-entry) (point))
3671 ?\n))))
3672 ;;;_ > allout-hide-current-entry-completely ()
3673 ; ... allout-hide-current-entry-completely also for isearch dynamic exposure:
3674 (defun allout-hide-current-entry-completely ()
3675 "Like `allout-hide-current-entry', but conceal topic completely.
3677 Specifically intended for aberrant exposure states, like entries that were
3678 exposed by `allout-show-entry' but are within otherwise concealed regions."
3679 (interactive)
3680 (save-excursion
3681 (allout-goto-prefix)
3682 (allout-flag-region (if (not (bobp)) (1- (point)) (point))
3683 (progn (allout-pre-next-preface)
3684 (if (= ?\r (following-char))
3685 (point)
3686 (1- (point))))
3687 ?\r)))
3688 ;;;_ > allout-show-current-subtree (&optional arg)
3689 (defun allout-show-current-subtree (&optional arg)
3690 "Show everything within the current topic. With a repeat-count,
3691 expose this topic and its siblings."
3692 (interactive "P")
3693 (save-excursion
3694 (if (<= (allout-current-depth) 0)
3695 ;; Outside any topics - try to get to the first:
3696 (if (not (allout-next-heading))
3697 (error "No topics")
3698 ;; got to first, outermost topic - set to expose it and siblings:
3699 (message "Above outermost topic - exposing all.")
3700 (allout-flag-region (point-min)(point-max) ?\n))
3701 (if (not arg)
3702 (allout-flag-current-subtree ?\n)
3703 (allout-beginning-of-level)
3704 (allout-expose-topic '(* :))))))
3705 ;;;_ > allout-hide-current-subtree (&optional just-close)
3706 (defun allout-hide-current-subtree (&optional just-close)
3707 "Close the current topic, or containing topic if this one is already closed.
3709 If this topic is closed and it's a top level topic, close this topic
3710 and its siblings.
3712 If optional arg JUST-CLOSE is non-nil, do not treat the parent or
3713 siblings, even if the target topic is already closed."
3715 (interactive)
3716 (let ((from (point))
3717 (orig-eol (progn (end-of-line)
3718 (if (not (allout-goto-prefix))
3719 (error "No topics found")
3720 (end-of-line)(point)))))
3721 (allout-flag-current-subtree ?\r)
3722 (goto-char from)
3723 (if (and (= orig-eol (progn (goto-char orig-eol)
3724 (end-of-line)
3725 (point)))
3726 (not just-close)
3727 ;; Structure didn't change - try hiding current level:
3728 (goto-char from)
3729 (if (allout-up-current-level 1 t)
3731 (goto-char 0)
3732 (let ((msg
3733 "Top-level topic already closed - closing siblings..."))
3734 (message msg)
3735 (allout-expose-topic '(0 :))
3736 (message (concat msg " Done.")))
3737 nil)
3738 (/= (allout-recent-depth) 0))
3739 (allout-hide-current-subtree))
3740 (goto-char from)))
3741 ;;;_ > allout-show-current-branches ()
3742 (defun allout-show-current-branches ()
3743 "Show all subheadings of this heading, but not their bodies."
3744 (interactive)
3745 (beginning-of-line)
3746 (allout-show-children t))
3747 ;;;_ > allout-hide-current-leaves ()
3748 (defun allout-hide-current-leaves ()
3749 "Hide the bodies of the current topic and all its offspring."
3750 (interactive)
3751 (allout-back-to-current-heading)
3752 (allout-hide-region-body (point) (progn (allout-end-of-current-subtree)
3753 (point))))
3755 ;;;_ - Region and beyond
3756 ;;;_ > allout-show-all ()
3757 (defun allout-show-all ()
3758 "Show all of the text in the buffer."
3759 (interactive)
3760 (message "Exposing entire buffer...")
3761 (allout-flag-region (point-min) (point-max) ?\n)
3762 (message "Exposing entire buffer... Done."))
3763 ;;;_ > allout-hide-bodies ()
3764 (defun allout-hide-bodies ()
3765 "Hide all of buffer except headings."
3766 (interactive)
3767 (allout-hide-region-body (point-min) (point-max)))
3768 ;;;_ > allout-hide-region-body (start end)
3769 (defun allout-hide-region-body (start end)
3770 "Hide all body lines in the region, but not headings."
3771 (save-excursion
3772 (save-restriction
3773 (narrow-to-region start end)
3774 (goto-char (point-min))
3775 (while (not (eobp))
3776 (allout-flag-region (point)
3777 (progn (allout-pre-next-preface) (point)) ?\r)
3778 (if (not (eobp))
3779 (forward-char
3780 (if (looking-at "[\n\r][\n\r]")
3781 2 1)))))))
3783 ;;;_ > allout-expose-topic (spec)
3784 (defun allout-expose-topic (spec)
3785 "Apply exposure specs to successive outline topic items.
3787 Use the more convenient frontend, `allout-new-exposure', if you don't
3788 need evaluation of the arguments, or even better, the `allout-layout'
3789 variable-keyed mode-activation/auto-exposure feature of allout outline
3790 mode. See the respective documentation strings for more details.
3792 Cursor is left at start position.
3794 SPEC is either a number or a list.
3796 Successive specs on a list are applied to successive sibling topics.
3798 A simple spec \(either a number, one of a few symbols, or the null
3799 list) dictates the exposure for the corresponding topic.
3801 Non-null lists recursively designate exposure specs for respective
3802 subtopics of the current topic.
3804 The `:' repeat spec is used to specify exposure for any number of
3805 successive siblings, up to the trailing ones for which there are
3806 explicit specs following the `:'.
3808 Simple (numeric and null-list) specs are interpreted as follows:
3810 Numbers indicate the relative depth to open the corresponding topic.
3811 - negative numbers force the topic to be closed before opening to the
3812 absolute value of the number, so all siblings are open only to
3813 that level.
3814 - positive numbers open to the relative depth indicated by the
3815 number, but do not force already opened subtopics to be closed.
3816 - 0 means to close topic - hide all offspring.
3817 : - `repeat'
3818 apply prior element to all siblings at current level, *up to*
3819 those siblings that would be covered by specs following the `:'
3820 on the list. Ie, apply to all topics at level but the last
3821 ones. \(Only first of multiple colons at same level is
3822 respected - subsequent ones are discarded.)
3823 * - completely opens the topic, including bodies.
3824 + - shows all the sub headers, but not the bodies
3825 - - exposes the body of the corresponding topic.
3827 Examples:
3828 \(allout-expose-topic '(-1 : 0))
3829 Close this and all following topics at current level, exposing
3830 only their immediate children, but close down the last topic
3831 at this current level completely.
3832 \(allout-expose-topic '(-1 () : 1 0))
3833 Close current topic so only the immediate subtopics are shown;
3834 show the children in the second to last topic, and completely
3835 close the last one.
3836 \(allout-expose-topic '(-2 : -1 *))
3837 Expose children and grandchildren of all topics at current
3838 level except the last two; expose children of the second to
3839 last and completely open the last one."
3841 (interactive "xExposure spec: ")
3842 (if (not (listp spec))
3844 (let ((depth (allout-depth))
3845 (max-pos 0)
3846 prev-elem curr-elem
3847 stay done
3848 snug-back
3850 (while spec
3851 (setq prev-elem curr-elem
3852 curr-elem (car spec)
3853 spec (cdr spec))
3854 (cond ; Do current element:
3855 ((null curr-elem) nil)
3856 ((symbolp curr-elem)
3857 (cond ((eq curr-elem '*) (allout-show-current-subtree)
3858 (if (> allout-recent-end-of-subtree max-pos)
3859 (setq max-pos allout-recent-end-of-subtree)))
3860 ((eq curr-elem '+) (allout-show-current-branches)
3861 (if (> allout-recent-end-of-subtree max-pos)
3862 (setq max-pos allout-recent-end-of-subtree)))
3863 ((eq curr-elem '-) (allout-show-current-entry))
3864 ((eq curr-elem ':)
3865 (setq stay t)
3866 ;; Expand the `repeat' spec to an explicit version,
3867 ;; w.r.t. remaining siblings:
3868 (let ((residue ; = # of sibs not covered by remaining spec
3869 ;; Dang - could be nice to make use of the chart, sigh:
3870 (- (length (allout-chart-siblings))
3871 (length spec))))
3872 (if (< 0 residue)
3873 ;; Some residue - cover it with prev-elem:
3874 (setq spec (append (make-list residue prev-elem)
3875 spec)))))))
3876 ((numberp curr-elem)
3877 (if (and (>= 0 curr-elem) (allout-visible-p))
3878 (save-excursion (allout-hide-current-subtree t)
3879 (if (> 0 curr-elem)
3881 (if (> allout-recent-end-of-subtree max-pos)
3882 (setq max-pos
3883 allout-recent-end-of-subtree)))))
3884 (if (> (abs curr-elem) 0)
3885 (progn (allout-show-children (abs curr-elem))
3886 (if (> allout-recent-end-of-subtree max-pos)
3887 (setq max-pos allout-recent-end-of-subtree)))))
3888 ((listp curr-elem)
3889 (if (allout-descend-to-depth (1+ depth))
3890 (let ((got (allout-expose-topic curr-elem)))
3891 (if (and got (> got max-pos)) (setq max-pos got))))))
3892 (cond (stay (setq stay nil))
3893 ((listp (car spec)) nil)
3894 ((> max-pos (point))
3895 ;; Capitalize on max-pos state to get us nearer next sibling:
3896 (progn (goto-char (min (point-max) max-pos))
3897 (allout-next-heading)))
3898 ((allout-next-sibling depth))))
3899 max-pos)))
3900 ;;;_ > allout-old-expose-topic (spec &rest followers)
3901 (defun allout-old-expose-topic (spec &rest followers)
3902 "Dictate wholesale exposure scheme for current topic, according to SPEC.
3904 SPEC is either a number or a list. Optional successive args
3905 dictate exposure for subsequent siblings of current topic.
3907 A simple spec (either a number, a special symbol, or the null list)
3908 dictates the overall exposure for a topic. Non null lists are
3909 composite specs whose first element dictates the overall exposure for
3910 a topic, with the subsequent elements in the list interpreted as specs
3911 that dictate the exposure for the successive offspring of the topic.
3913 Simple (numeric and null-list) specs are interpreted as follows:
3915 - Numbers indicate the relative depth to open the corresponding topic:
3916 - negative numbers force the topic to be close before opening to the
3917 absolute value of the number.
3918 - positive numbers just open to the relative depth indicated by the number.
3919 - 0 just closes
3920 - `*' completely opens the topic, including bodies.
3921 - `+' shows all the sub headers, but not the bodies
3922 - `-' exposes the body and immediate offspring of the corresponding topic.
3924 If the spec is a list, the first element must be a number, which
3925 dictates the exposure depth of the topic as a whole. Subsequent
3926 elements of the list are nested SPECs, dictating the specific exposure
3927 for the corresponding offspring of the topic.
3929 Optional FOLLOWERS arguments dictate exposure for succeeding siblings."
3931 (interactive "xExposure spec: ")
3932 (let ((depth (allout-current-depth))
3933 done
3934 max-pos)
3935 (cond ((null spec) nil)
3936 ((symbolp spec)
3937 (if (eq spec '*) (allout-show-current-subtree))
3938 (if (eq spec '+) (allout-show-current-branches))
3939 (if (eq spec '-) (allout-show-current-entry)))
3940 ((numberp spec)
3941 (if (>= 0 spec)
3942 (save-excursion (allout-hide-current-subtree t)
3943 (end-of-line)
3944 (if (or (not max-pos)
3945 (> (point) max-pos))
3946 (setq max-pos (point)))
3947 (if (> 0 spec)
3948 (setq spec (* -1 spec)))))
3949 (if (> spec 0)
3950 (allout-show-children spec)))
3951 ((listp spec)
3952 ;(let ((got (allout-old-expose-topic (car spec))))
3953 ; (if (and got (or (not max-pos) (> got max-pos)))
3954 ; (setq max-pos got)))
3955 (let ((new-depth (+ (allout-current-depth) 1))
3956 got)
3957 (setq max-pos (allout-old-expose-topic (car spec)))
3958 (setq spec (cdr spec))
3959 (if (and spec
3960 (allout-descend-to-depth new-depth)
3961 (not (allout-hidden-p)))
3962 (progn (setq got (apply 'allout-old-expose-topic spec))
3963 (if (and got (or (not max-pos) (> got max-pos)))
3964 (setq max-pos got)))))))
3965 (while (and followers
3966 (progn (if (and max-pos (< (point) max-pos))
3967 (progn (goto-char max-pos)
3968 (setq max-pos nil)))
3969 (end-of-line)
3970 (allout-next-sibling depth)))
3971 (allout-old-expose-topic (car followers))
3972 (setq followers (cdr followers)))
3973 max-pos))
3974 (make-obsolete 'allout-old-expose-topic
3975 "use `allout-expose-topic' (with different schema format) instead."
3976 "19.23")
3977 ;;;_ > allout-new-exposure '()
3978 (defmacro allout-new-exposure (&rest spec)
3979 "Literal frontend for `allout-expose-topic', doesn't evaluate arguments.
3980 Some arguments that would need to be quoted in `allout-expose-topic'
3981 need not be quoted in `allout-new-exposure'.
3983 Cursor is left at start position.
3985 Use this instead of obsolete `allout-exposure'.
3987 Examples:
3988 \(allout-exposure (-1 () () () 1) 0)
3989 Close current topic at current level so only the immediate
3990 subtopics are shown, except also show the children of the
3991 third subtopic; and close the next topic at the current level.
3992 \(allout-exposure : -1 0)
3993 Close all topics at current level to expose only their
3994 immediate children, except for the last topic at the current
3995 level, in which even its immediate children are hidden.
3996 \(allout-exposure -2 : -1 *)
3997 Expose children and grandchildren of first topic at current
3998 level, and expose children of subsequent topics at current
3999 level *except* for the last, which should be opened completely."
4000 (list 'save-excursion
4001 '(if (not (or (allout-goto-prefix)
4002 (allout-next-heading)))
4003 (error "allout-new-exposure: Can't find any outline topics"))
4004 (list 'allout-expose-topic (list 'quote spec))))
4005 ;;;_ > allout-exposure '()
4006 (defmacro allout-exposure (&rest spec)
4007 "Literal frontend for `allout-old-expose-topic', doesn't evaluate arguments
4008 and retains start position."
4009 (list 'save-excursion
4010 '(if (not (or (allout-goto-prefix)
4011 (allout-next-heading)))
4012 (error "Can't find any outline topics"))
4013 (cons 'allout-old-expose-topic
4014 (mapcar (function (lambda (x) (list 'quote x))) spec))))
4015 (make-obsolete 'allout-exposure 'allout-new-exposure "19.23")
4017 ;;;_ #7 Systematic outline presentation - copying, printing, flattening
4019 ;;;_ - Mapping and processing of topics
4020 ;;;_ ( See also Subtree Charting, in Navigation code.)
4021 ;;;_ > allout-stringify-flat-index (flat-index)
4022 (defun allout-stringify-flat-index (flat-index &optional context)
4023 "Convert list representing section/subsection/... to document string.
4025 Optional arg CONTEXT indicates interior levels to include."
4026 (let ((delim ".")
4027 result
4028 numstr
4029 (context-depth (or (and context 2) 1)))
4030 ;; Take care of the explicit context:
4031 (while (> context-depth 0)
4032 (setq numstr (int-to-string (car flat-index))
4033 flat-index (cdr flat-index)
4034 result (if flat-index
4035 (cons delim (cons numstr result))
4036 (cons numstr result))
4037 context-depth (if flat-index (1- context-depth) 0)))
4038 (setq delim " ")
4039 ;; Take care of the indentation:
4040 (if flat-index
4041 (progn
4042 (while flat-index
4043 (setq result
4044 (cons delim
4045 (cons (make-string
4046 (1+ (truncate (if (zerop (car flat-index))
4048 (log10 (car flat-index)))))
4050 result)))
4051 (setq flat-index (cdr flat-index)))
4052 ;; Dispose of single extra delim:
4053 (setq result (cdr result))))
4054 (apply 'concat result)))
4055 ;;;_ > allout-stringify-flat-index-plain (flat-index)
4056 (defun allout-stringify-flat-index-plain (flat-index)
4057 "Convert list representing section/subsection/... to document string."
4058 (let ((delim ".")
4059 result)
4060 (while flat-index
4061 (setq result (cons (int-to-string (car flat-index))
4062 (if result
4063 (cons delim result))))
4064 (setq flat-index (cdr flat-index)))
4065 (apply 'concat result)))
4066 ;;;_ > allout-stringify-flat-index-indented (flat-index)
4067 (defun allout-stringify-flat-index-indented (flat-index)
4068 "Convert list representing section/subsection/... to document string."
4069 (let ((delim ".")
4070 result
4071 numstr)
4072 ;; Take care of the explicit context:
4073 (setq numstr (int-to-string (car flat-index))
4074 flat-index (cdr flat-index)
4075 result (if flat-index
4076 (cons delim (cons numstr result))
4077 (cons numstr result)))
4078 (setq delim " ")
4079 ;; Take care of the indentation:
4080 (if flat-index
4081 (progn
4082 (while flat-index
4083 (setq result
4084 (cons delim
4085 (cons (make-string
4086 (1+ (truncate (if (zerop (car flat-index))
4088 (log10 (car flat-index)))))
4090 result)))
4091 (setq flat-index (cdr flat-index)))
4092 ;; Dispose of single extra delim:
4093 (setq result (cdr result))))
4094 (apply 'concat result)))
4095 ;;;_ > allout-listify-exposed (&optional start end format)
4096 (defun allout-listify-exposed (&optional start end format)
4098 "Produce a list representing exposed topics in current region.
4100 This list can then be used by `allout-process-exposed' to manipulate
4101 the subject region.
4103 Optional START and END indicate bounds of region.
4105 optional arg, FORMAT, designates an alternate presentation form for
4106 the prefix:
4108 list - Present prefix as numeric section.subsection..., starting with
4109 section indicated by the list, innermost nesting first.
4110 `indent' \(symbol) - Convert header prefixes to all white space,
4111 except for distinctive bullets.
4113 The elements of the list produced are lists that represents a topic
4114 header and body. The elements of that list are:
4116 - a number representing the depth of the topic,
4117 - a string representing the header-prefix, including trailing whitespace and
4118 bullet.
4119 - a string representing the bullet character,
4120 - and a series of strings, each containing one line of the exposed
4121 portion of the topic entry."
4123 (interactive "r")
4124 (save-excursion
4125 (let*
4126 ;; state vars:
4127 (strings prefix pad result depth new-depth out gone-out bullet beg
4128 next done)
4130 (goto-char start)
4131 (beginning-of-line)
4132 ;; Goto initial topic, and register preceeding stuff, if any:
4133 (if (> (allout-goto-prefix) start)
4134 ;; First topic follows beginning point - register preliminary stuff:
4135 (setq result (list (list 0 "" nil
4136 (buffer-substring start (1- (point)))))))
4137 (while (and (not done)
4138 (not (eobp)) ; Loop until we've covered the region.
4139 (not (> (point) end)))
4140 (setq depth (allout-recent-depth) ; Current topics depth,
4141 bullet (allout-recent-bullet) ; ... bullet,
4142 prefix (allout-recent-prefix)
4143 beg (progn (allout-end-of-prefix t) (point))) ; and beginning.
4144 (setq done ; The boundary for the current topic:
4145 (not (allout-next-visible-heading 1)))
4146 (setq new-depth (allout-recent-depth))
4147 (setq gone-out out
4148 out (< new-depth depth))
4149 (beginning-of-line)
4150 (setq next (point))
4151 (goto-char beg)
4152 (setq strings nil)
4153 (while (> next (point)) ; Get all the exposed text in
4154 (setq strings
4155 (cons (buffer-substring
4157 ;To hidden text or end of line:
4158 (progn
4159 (search-forward "\r"
4160 (save-excursion (end-of-line)
4161 (point))
4163 (if (= (preceding-char) ?\r)
4164 (1- (point))
4165 (point))))
4166 strings))
4167 (if (< (point) next) ; Resume from after hid text, if any.
4168 (forward-line 1))
4169 (setq beg (point)))
4170 ;; Accumulate list for this topic:
4171 (setq strings (nreverse strings))
4172 (setq result
4173 (cons
4174 (if format
4175 (let ((special (if (string-match
4176 (regexp-quote bullet)
4177 allout-distinctive-bullets-string)
4178 bullet)))
4179 (cond ((listp format)
4180 (list depth
4181 (if allout-abbreviate-flattened-numbering
4182 (allout-stringify-flat-index format
4183 gone-out)
4184 (allout-stringify-flat-index-plain
4185 format))
4186 strings
4187 special))
4188 ((eq format 'indent)
4189 (if special
4190 (list depth
4191 (concat (make-string (1+ depth) ? )
4192 (substring prefix -1))
4193 strings)
4194 (list depth
4195 (make-string depth ? )
4196 strings)))
4197 (t (error "allout-listify-exposed: %s %s"
4198 "invalid format" format))))
4199 (list depth prefix strings))
4200 result))
4201 ;; Reasses format, if any:
4202 (if (and format (listp format))
4203 (cond ((= new-depth depth)
4204 (setq format (cons (1+ (car format))
4205 (cdr format))))
4206 ((> new-depth depth) ; descending - assume by 1:
4207 (setq format (cons 1 format)))
4209 ; Pop the residue:
4210 (while (< new-depth depth)
4211 (setq format (cdr format))
4212 (setq depth (1- depth)))
4213 ; And increment the current one:
4214 (setq format
4215 (cons (1+ (or (car format)
4216 -1))
4217 (cdr format)))))))
4218 ;; Put the list with first at front, to last at back:
4219 (nreverse result))))
4220 ;;;_ > allout-process-exposed (&optional func from to frombuf
4221 ;;; tobuf format)
4222 (defun allout-process-exposed (&optional func from to frombuf tobuf
4223 format start-num)
4224 "Map function on exposed parts of current topic; results to another buffer.
4226 Apply FUNC to exposed portions FROM position TO position in buffer
4227 FROMBUF to buffer TOBUF. Sixth optional arg, FORMAT, designates an
4228 alternate presentation form:
4230 `flat' - Present prefix as numeric section.subsection..., starting with
4231 section indicated by the start-num, innermost nesting first.
4232 X`flat-indented' - Prefix is like `flat' for first topic at each
4233 X level, but subsequent topics have only leaf topic
4234 X number, padded with blanks to line up with first.
4235 `indent' \(symbol) - Convert header prefixes to all white space,
4236 except for distinctive bullets.
4238 Defaults:
4239 FUNC: `allout-insert-listified'
4240 FROM: region start, if region active, else start of buffer
4241 TO: region end, if region active, else end of buffer
4242 FROMBUF: current buffer
4243 TOBUF: buffer name derived: \"*current-buffer-name exposed*\"
4244 FORMAT: nil"
4246 ; Resolve arguments,
4247 ; defaulting if necessary:
4248 (if (not func) (setq func 'allout-insert-listified))
4249 (if (not (and from to))
4250 (if (my-region-active-p)
4251 (setq from (region-beginning) to (region-end))
4252 (setq from (point-min) to (point-max))))
4253 (if frombuf
4254 (if (not (bufferp frombuf))
4255 ;; Specified but not a buffer - get it:
4256 (let ((got (get-buffer frombuf)))
4257 (if (not got)
4258 (error (concat "allout-process-exposed: source buffer "
4259 frombuf
4260 " not found."))
4261 (setq frombuf got))))
4262 ;; not specified - default it:
4263 (setq frombuf (current-buffer)))
4264 (if tobuf
4265 (if (not (bufferp tobuf))
4266 (setq tobuf (get-buffer-create tobuf)))
4267 ;; not specified - default it:
4268 (setq tobuf (concat "*" (buffer-name frombuf) " exposed*")))
4269 (if (listp format)
4270 (nreverse format))
4272 (let* ((listified
4273 (progn (set-buffer frombuf)
4274 (allout-listify-exposed from to format))))
4275 (set-buffer tobuf)
4276 (mapcar func listified)
4277 (pop-to-buffer tobuf)))
4279 ;;;_ - Copy exposed
4280 ;;;_ > allout-insert-listified (listified)
4281 (defun allout-insert-listified (listified)
4282 "Insert contents of listified outline portion in current buffer.
4284 LISTIFIED is a list representing each topic header and body:
4286 \`(depth prefix text)'
4290 \`(depth prefix text bullet-plus)'
4292 If `bullet-plus' is specified, it is inserted just after the entire prefix."
4293 (setq listified (cdr listified))
4294 (let ((prefix (prog1
4295 (car listified)
4296 (setq listified (cdr listified))))
4297 (text (prog1
4298 (car listified)
4299 (setq listified (cdr listified))))
4300 (bullet-plus (car listified)))
4301 (insert prefix)
4302 (if bullet-plus (insert (concat " " bullet-plus)))
4303 (while text
4304 (insert (car text))
4305 (if (setq text (cdr text))
4306 (insert "\n")))
4307 (insert "\n")))
4308 ;;;_ > allout-copy-exposed-to-buffer (&optional arg tobuf format)
4309 (defun allout-copy-exposed-to-buffer (&optional arg tobuf format)
4310 "Duplicate exposed portions of current outline to another buffer.
4312 Other buffer has current buffers name with \" exposed\" appended to it.
4314 With repeat count, copy the exposed parts of only the current topic.
4316 Optional second arg TOBUF is target buffer name.
4318 Optional third arg FORMAT, if non-nil, symbolically designates an
4319 alternate presentation format for the outline:
4321 `flat' - Convert topic header prefixes to numeric
4322 section.subsection... identifiers.
4323 `indent' - Convert header prefixes to all white space, except for
4324 distinctive bullets.
4325 `indent-flat' - The best of both - only the first of each level has
4326 the full path, the rest have only the section number
4327 of the leaf, preceded by the right amount of indentation."
4329 (interactive "P")
4330 (if (not tobuf)
4331 (setq tobuf (get-buffer-create (concat "*" (buffer-name) " exposed*"))))
4332 (let* ((start-pt (point))
4333 (beg (if arg (allout-back-to-current-heading) (point-min)))
4334 (end (if arg (allout-end-of-current-subtree) (point-max)))
4335 (buf (current-buffer))
4336 (start-list ()))
4337 (if (eq format 'flat)
4338 (setq format (if arg (save-excursion
4339 (goto-char beg)
4340 (allout-topic-flat-index))
4341 '(1))))
4342 (save-excursion (set-buffer tobuf)(erase-buffer))
4343 (allout-process-exposed 'allout-insert-listified
4346 (current-buffer)
4347 tobuf
4348 format start-list)
4349 (goto-char (point-min))
4350 (pop-to-buffer buf)
4351 (goto-char start-pt)))
4352 ;;;_ > allout-flatten-exposed-to-buffer (&optional arg tobuf)
4353 (defun allout-flatten-exposed-to-buffer (&optional arg tobuf)
4354 "Present numeric outline of outline's exposed portions in another buffer.
4356 The resulting outline is not compatible with outline mode - use
4357 `allout-copy-exposed-to-buffer' if you want that.
4359 Use `allout-indented-exposed-to-buffer' for indented presentation.
4361 With repeat count, copy the exposed portions of only current topic.
4363 Other buffer has current buffer's name with \" exposed\" appended to
4364 it, unless optional second arg TOBUF is specified, in which case it is
4365 used verbatim."
4366 (interactive "P")
4367 (allout-copy-exposed-to-buffer arg tobuf 'flat))
4368 ;;;_ > allout-indented-exposed-to-buffer (&optional arg tobuf)
4369 (defun allout-indented-exposed-to-buffer (&optional arg tobuf)
4370 "Present indented outline of outline's exposed portions in another buffer.
4372 The resulting outline is not compatible with outline mode - use
4373 `allout-copy-exposed-to-buffer' if you want that.
4375 Use `allout-flatten-exposed-to-buffer' for numeric sectional presentation.
4377 With repeat count, copy the exposed portions of only current topic.
4379 Other buffer has current buffer's name with \" exposed\" appended to
4380 it, unless optional second arg TOBUF is specified, in which case it is
4381 used verbatim."
4382 (interactive "P")
4383 (allout-copy-exposed-to-buffer arg tobuf 'indent))
4385 ;;;_ - LaTeX formatting
4386 ;;;_ > allout-latex-verb-quote (string &optional flow)
4387 (defun allout-latex-verb-quote (string &optional flow)
4388 "Return copy of STRING for literal reproduction across latex processing.
4389 Expresses the original characters \(including carriage returns) of the
4390 string across latex processing."
4391 (mapconcat (function
4392 (lambda (char)
4393 (cond ((memq char '(?\\ ?$ ?% ?# ?& ?{ ?} ?_ ?^ ?- ?*))
4394 (concat "\\char" (number-to-string char) "{}"))
4395 ((= char ?\n) "\\\\")
4396 (t (char-to-string char)))))
4397 string
4398 ""))
4399 ;;;_ > allout-latex-verbatim-quote-curr-line ()
4400 (defun allout-latex-verbatim-quote-curr-line ()
4401 "Express line for exact \(literal) representation across latex processing.
4403 Adjust line contents so it is unaltered \(from the original line)
4404 across latex processing, within the context of a `verbatim'
4405 environment. Leaves point at the end of the line."
4406 (beginning-of-line)
4407 (let ((beg (point))
4408 (end (progn (end-of-line)(point))))
4409 (goto-char beg)
4410 (while (re-search-forward "\\\\"
4411 ;;"\\\\\\|\\{\\|\\}\\|\\_\\|\\$\\|\\\"\\|\\&\\|\\^\\|\\-\\|\\*\\|#"
4412 end ; bounded by end-of-line
4413 1) ; no matches, move to end & return nil
4414 (goto-char (match-beginning 0))
4415 (insert "\\")
4416 (setq end (1+ end))
4417 (goto-char (1+ (match-end 0))))))
4418 ;;;_ > allout-insert-latex-header (buffer)
4419 (defun allout-insert-latex-header (buffer)
4420 "Insert initial latex commands at point in BUFFER."
4421 ;; Much of this is being derived from the stuff in appendix of E in
4422 ;; the TeXBook, pg 421.
4423 (set-buffer buffer)
4424 (let ((doc-style (format "\n\\documentstyle{%s}\n"
4425 "report"))
4426 (page-numbering (if allout-number-pages
4427 "\\pagestyle{empty}\n"
4428 ""))
4429 (linesdef (concat "\\def\\beginlines{"
4430 "\\par\\begingroup\\nobreak\\medskip"
4431 "\\parindent=0pt\n"
4432 " \\kern1pt\\nobreak \\obeylines \\obeyspaces "
4433 "\\everypar{\\strut}}\n"
4434 "\\def\\endlines{"
4435 "\\kern1pt\\endgroup\\medbreak\\noindent}\n"))
4436 (titlecmd (format "\\newcommand{\\titlecmd}[1]{{%s #1}}\n"
4437 allout-title-style))
4438 (labelcmd (format "\\newcommand{\\labelcmd}[1]{{%s #1}}\n"
4439 allout-label-style))
4440 (headlinecmd (format "\\newcommand{\\headlinecmd}[1]{{%s #1}}\n"
4441 allout-head-line-style))
4442 (bodylinecmd (format "\\newcommand{\\bodylinecmd}[1]{{%s #1}}\n"
4443 allout-body-line-style))
4444 (setlength (format "%s%s%s%s"
4445 "\\newlength{\\stepsize}\n"
4446 "\\setlength{\\stepsize}{"
4447 allout-indent
4448 "}\n"))
4449 (oneheadline (format "%s%s%s%s%s%s%s"
4450 "\\newcommand{\\OneHeadLine}[3]{%\n"
4451 "\\noindent%\n"
4452 "\\hspace*{#2\\stepsize}%\n"
4453 "\\labelcmd{#1}\\hspace*{.2cm}"
4454 "\\headlinecmd{#3}\\\\["
4455 allout-line-skip
4456 "]\n}\n"))
4457 (onebodyline (format "%s%s%s%s%s%s"
4458 "\\newcommand{\\OneBodyLine}[2]{%\n"
4459 "\\noindent%\n"
4460 "\\hspace*{#1\\stepsize}%\n"
4461 "\\bodylinecmd{#2}\\\\["
4462 allout-line-skip
4463 "]\n}\n"))
4464 (begindoc "\\begin{document}\n\\begin{center}\n")
4465 (title (format "%s%s%s%s"
4466 "\\titlecmd{"
4467 (allout-latex-verb-quote (if allout-title
4468 (condition-case err
4469 (eval allout-title)
4470 ('error "<unnamed buffer>"))
4471 "Unnamed Outline"))
4472 "}\n"
4473 "\\end{center}\n\n"))
4474 (hsize "\\hsize = 7.5 true in\n")
4475 (hoffset "\\hoffset = -1.5 true in\n")
4476 (vspace "\\vspace{.1cm}\n\n"))
4477 (insert (concat doc-style
4478 page-numbering
4479 titlecmd
4480 labelcmd
4481 headlinecmd
4482 bodylinecmd
4483 setlength
4484 oneheadline
4485 onebodyline
4486 begindoc
4487 title
4488 hsize
4489 hoffset
4490 vspace)
4492 ;;;_ > allout-insert-latex-trailer (buffer)
4493 (defun allout-insert-latex-trailer (buffer)
4494 "Insert concluding latex commands at point in BUFFER."
4495 (set-buffer buffer)
4496 (insert "\n\\end{document}\n"))
4497 ;;;_ > allout-latexify-one-item (depth prefix bullet text)
4498 (defun allout-latexify-one-item (depth prefix bullet text)
4499 "Insert LaTeX commands for formatting one outline item.
4501 Args are the topics numeric DEPTH, the header PREFIX lead string, the
4502 BULLET string, and a list of TEXT strings for the body."
4503 (let* ((head-line (if text (car text)))
4504 (body-lines (cdr text))
4505 (curr-line)
4506 body-content bop)
4507 ; Do the head line:
4508 (insert (concat "\\OneHeadLine{\\verb\1 "
4509 (allout-latex-verb-quote bullet)
4510 "\1}{"
4511 depth
4512 "}{\\verb\1 "
4513 (if head-line
4514 (allout-latex-verb-quote head-line)
4516 "\1}\n"))
4517 (if (not body-lines)
4519 ;;(insert "\\beginlines\n")
4520 (insert "\\begin{verbatim}\n")
4521 (while body-lines
4522 (setq curr-line (car body-lines))
4523 (if (and (not body-content)
4524 (not (string-match "^\\s-*$" curr-line)))
4525 (setq body-content t))
4526 ; Mangle any occurrences of
4527 ; "\end{verbatim}" in text,
4528 ; it's special:
4529 (if (and body-content
4530 (setq bop (string-match "\\end{verbatim}" curr-line)))
4531 (setq curr-line (concat (substring curr-line 0 bop)
4533 (substring curr-line bop))))
4534 ;;(insert "|" (car body-lines) "|")
4535 (insert curr-line)
4536 (allout-latex-verbatim-quote-curr-line)
4537 (insert "\n")
4538 (setq body-lines (cdr body-lines)))
4539 (if body-content
4540 (setq body-content nil)
4541 (forward-char -1)
4542 (insert "\\ ")
4543 (forward-char 1))
4544 ;;(insert "\\endlines\n")
4545 (insert "\\end{verbatim}\n")
4547 ;;;_ > allout-latexify-exposed (arg &optional tobuf)
4548 (defun allout-latexify-exposed (arg &optional tobuf)
4549 "Format current topics exposed portions to TOBUF for latex processing.
4550 TOBUF defaults to a buffer named the same as the current buffer, but
4551 with \"*\" prepended and \" latex-formed*\" appended.
4553 With repeat count, copy the exposed portions of entire buffer."
4555 (interactive "P")
4556 (if (not tobuf)
4557 (setq tobuf
4558 (get-buffer-create (concat "*" (buffer-name) " latexified*"))))
4559 (let* ((start-pt (point))
4560 (beg (if arg (point-min) (allout-back-to-current-heading)))
4561 (end (if arg (point-max) (allout-end-of-current-subtree)))
4562 (buf (current-buffer)))
4563 (set-buffer tobuf)
4564 (erase-buffer)
4565 (allout-insert-latex-header tobuf)
4566 (goto-char (point-max))
4567 (allout-process-exposed 'allout-latexify-one-item
4571 tobuf)
4572 (goto-char (point-max))
4573 (allout-insert-latex-trailer tobuf)
4574 (goto-char (point-min))
4575 (pop-to-buffer buf)
4576 (goto-char start-pt)))
4578 ;;;_ #8 miscellaneous
4579 ;;;_ > allout-mark-topic ()
4580 (defun allout-mark-topic ()
4581 "Put the region around topic currently containing point."
4582 (interactive)
4583 (beginning-of-line)
4584 (allout-goto-prefix)
4585 (push-mark (point))
4586 (allout-end-of-current-subtree)
4587 (exchange-point-and-mark))
4588 ;;;_ > outlineify-sticky ()
4589 ;; outlinify-sticky is correct spelling; provide this alias for sticklers:
4590 (defalias 'outlinify-sticky 'outlineify-sticky)
4591 (defun outlineify-sticky (&optional arg)
4592 "Activate outline mode and establish file var so it is started subsequently.
4594 See doc-string for `allout-layout' and `allout-init' for details on
4595 setup for auto-startup."
4597 (interactive "P")
4599 (allout-mode t)
4601 (save-excursion
4602 (goto-char (point-min))
4603 (if (looking-at allout-regexp)
4605 (allout-open-topic 2)
4606 (insert (concat "Dummy outline topic header - see"
4607 "`allout-mode' docstring: `^Hm'."))
4608 (forward-line 1)
4609 (goto-char (point-max))
4610 (open-line 1)
4611 (allout-open-topic 0)
4612 (insert "Local emacs vars.\n")
4613 (allout-open-topic 1)
4614 (insert "(`allout-layout' is for allout.el allout-mode)\n")
4615 (allout-open-topic 0)
4616 (insert "Local variables:\n")
4617 (allout-open-topic 0)
4618 (insert (format "allout-layout: %s\n"
4619 (or allout-layout
4620 '(-1 : 0))))
4621 (allout-open-topic 0)
4622 (insert "End:\n"))))
4623 ;;;_ > solicit-char-in-string (prompt string &optional do-defaulting)
4624 (defun solicit-char-in-string (prompt string &optional do-defaulting)
4625 "Solicit (with first arg PROMPT) choice of a character from string STRING.
4627 Optional arg DO-DEFAULTING indicates to accept empty input (CR)."
4629 (let ((new-prompt prompt)
4630 got)
4632 (while (not got)
4633 (message "%s" new-prompt)
4635 ;; We do our own reading here, so we can circumvent, eg, special
4636 ;; treatment for `?' character. (Oughta use minibuffer keymap instead.)
4637 (setq got
4638 (char-to-string (let ((cursor-in-echo-area nil)) (read-char))))
4640 (setq got
4641 (cond ((string-match (regexp-quote got) string) got)
4642 ((and do-defaulting (string= got "\r"))
4643 ;; Return empty string to default:
4645 ((string= got "\C-g") (signal 'quit nil))
4647 (setq new-prompt (concat prompt
4649 " ...pick from: "
4650 string
4651 ""))
4652 nil))))
4653 ;; got something out of loop - return it:
4654 got)
4656 ;;;_ > regexp-sans-escapes (string)
4657 (defun regexp-sans-escapes (regexp &optional successive-backslashes)
4658 "Return a copy of REGEXP with all character escapes stripped out.
4660 Representations of actual backslashes - '\\\\\\\\' - are left as a
4661 single backslash.
4663 Optional arg SUCCESSIVE-BACKSLASHES is used internally for recursion."
4665 (if (string= regexp "")
4667 ;; Set successive-backslashes to number if current char is
4668 ;; backslash, or else to nil:
4669 (setq successive-backslashes
4670 (if (= (aref regexp 0) ?\\)
4671 (if successive-backslashes (1+ successive-backslashes) 1)
4672 nil))
4673 (if (or (not successive-backslashes) (= 2 successive-backslashes))
4674 ;; Include first char:
4675 (concat (substring regexp 0 1)
4676 (regexp-sans-escapes (substring regexp 1)))
4677 ;; Exclude first char, but maintain count:
4678 (regexp-sans-escapes (substring regexp 1) successive-backslashes))))
4679 ;;;_ > my-region-active-p ()
4680 (defmacro my-region-active-p ()
4681 (if (fboundp 'region-active-p)
4682 '(region-active-p)
4683 'mark-active))
4684 ;;;_ - add-hook definition for divergent emacsen
4685 ;;;_ > add-hook (hook function &optional append)
4686 (if (not (fboundp 'add-hook))
4687 (defun add-hook (hook function &optional append)
4688 "Add to the value of HOOK the function FUNCTION unless already present.
4689 \(It becomes the first hook on the list unless optional APPEND is non-nil, in
4690 which case it becomes the last). HOOK should be a symbol, and FUNCTION may be
4691 any valid function. HOOK's value should be a list of functions, not a single
4692 function. If HOOK is void, it is first set to nil."
4693 (or (boundp hook) (set hook nil))
4694 (or (if (consp function)
4695 ;; Clever way to tell whether a given lambda-expression
4696 ;; is equal to anything in the hook.
4697 (let ((tail (assoc (cdr function) (symbol-value hook))))
4698 (equal function tail))
4699 (memq function (symbol-value hook)))
4700 (set hook
4701 (if append
4702 (nconc (symbol-value hook) (list function))
4703 (cons function (symbol-value hook)))))))
4704 ;;;_ : my-mark-marker to accommodate divergent emacsen:
4705 (defun my-mark-marker (&optional force buffer)
4706 "Accommodate the different signature for mark-marker across Emacsen.
4708 XEmacs takes two optional args, while GNU Emacs does not,
4709 so pass them along when appropriate."
4710 (if (featurep 'xemacs)
4711 (mark-marker force buffer)
4712 (mark-marker)))
4714 ;;;_ #9 Under development
4715 ;;;_ > allout-bullet-isearch (&optional bullet)
4716 (defun allout-bullet-isearch (&optional bullet)
4717 "Isearch \(regexp) for topic with bullet BULLET."
4718 (interactive)
4719 (if (not bullet)
4720 (setq bullet (solicit-char-in-string
4721 "ISearch for topic with bullet: "
4722 (regexp-sans-escapes allout-bullets-string))))
4724 (let ((isearch-regexp t)
4725 (isearch-string (concat "^"
4726 allout-header-prefix
4727 "[ \t]*"
4728 bullet)))
4729 (isearch-repeat 'forward)
4730 (isearch-mode t)))
4731 ;;;_ ? Re hooking up with isearch - use isearch-op-fun rather than
4732 ;;; wrapping the isearch functions.
4734 ;;;_* Local emacs vars.
4735 ;;; The following `allout-layout' local variable setting:
4736 ;;; - closes all topics from the first topic to just before the third-to-last,
4737 ;;; - shows the children of the third to last (config vars)
4738 ;;; - and the second to last (code section),
4739 ;;; - and closes the last topic (this local-variables section).
4740 ;;;Local variables:
4741 ;;;allout-layout: (0 : -1 -1 0)
4742 ;;;End:
4744 ;;; arch-tag: cf38fbc3-c044-450f-8bff-afed8ba5681c
4745 ;;; allout.el ends here