1 ;;; allout.el --- extensive outline mode for use alone and with other modes
3 ;; Copyright (C) 1992, 1993, 1994, 2001, 2002, 2003, 2004,
4 ;; 2005, 2006 Free Software Foundation, Inc.
6 ;; Author: Ken Manheimer <ken dot manheimer at gmail dot com>
7 ;; Maintainer: Ken Manheimer <ken dot manheimer at gmail dot com>
8 ;; Created: Dec 1991 - first release to usenet
10 ;; Keywords: outlines wp languages
11 ;; Website: http://myriadicity.net/Sundry/EmacsAllout
13 ;; This file is part of GNU Emacs.
15 ;; GNU Emacs is free software; you can redistribute it and/or modify
16 ;; it under the terms of the GNU General Public License as published by
17 ;; the Free Software Foundation; either version 2, or (at your option)
20 ;; GNU Emacs is distributed in the hope that it will be useful,
21 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
22 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
23 ;; GNU General Public License for more details.
25 ;; You should have received a copy of the GNU General Public License
26 ;; along with GNU Emacs; see the file COPYING. If not, write to the
27 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
28 ;; Boston, MA 02110-1301, USA.
32 ;; Allout outline minor mode provides extensive outline formatting and
33 ;; and manipulation beyond standard emacs outline mode. Some features:
35 ;; - Classic outline-mode topic-oriented navigation and exposure adjustment
36 ;; - Topic-oriented editing including coherent topic and subtopic
37 ;; creation, promotion, demotion, cut/paste across depths, etc.
38 ;; - Incremental search with dynamic exposure and reconcealment of text
39 ;; - Customizable bullet format - enables programming-language specific
40 ;; outlining, for code-folding editing. (Allout code itself is to try it;
41 ;; formatted as an outline - do ESC-x eval-buffer in allout.el; but
42 ;; emacs local file variables need to be enabled when the
43 ;; file was visited - see `enable-local-variables'.)
44 ;; - Configurable per-file initial exposure settings
45 ;; - Symmetric-key and key-pair topic encryption, plus symmetric passphrase
46 ;; mnemonic support, with verification against an established passphrase
47 ;; (using a stashed encrypted dummy string) and user-supplied hint
48 ;; maintenance. (See allout-toggle-current-subtree-encryption docstring.)
49 ;; - Automatic topic-number maintenance
50 ;; - "Hot-spot" operation, for single-keystroke maneuvering and
51 ;; exposure control (see the allout-mode docstring)
52 ;; - Easy rendering of exposed portions into numbered, latex, indented, etc
54 ;; - Careful attention to whitespace - enabling blank lines between items
55 ;; and maintenance of hanging indentation (in paragraph auto-fill and
56 ;; across topic promotion and demotion) of topic bodies consistent with
57 ;; indentation of their topic header.
61 ;; See the `allout-mode' function's docstring for an introduction to the
64 ;; The latest development version and helpful notes are available at
65 ;; http://myriadicity.net/Sundry/EmacsAllout .
67 ;; The outline menubar additions provide quick reference to many of
68 ;; the features, and see the docstring of the variable `allout-init'
69 ;; for instructions on priming your emacs session for automatic
70 ;; activation of allout-mode.
72 ;; See the docstring of the variables `allout-layout' and
73 ;; `allout-auto-activation' for details on automatic activation of
74 ;; `allout-mode' as a minor mode. (It has changed since allout
75 ;; 3.x, for those of you that depend on the old method.)
77 ;; Note - the lines beginning with `;;;_' are outline topic headers.
78 ;; Just `ESC-x eval-buffer' to give it a whirl.
80 ;; ken manheimer (ken dot manheimer at gmail dot com)
84 ;;;_* Dependency autoloads
87 ;; Most of the requires here are for stuff covered by autoloads.
88 ;; Since just byte-compiling doesn't trigger autoloads, so that
89 ;; "function not found" warnings would occur without these requires.
94 ;; `cl' is required for `assert'. `assert' is not covered by a standard
95 ;; autoload, but it is a macro, so that eval-when-compile is sufficient
96 ;; to byte-compile it in, or to do the require when the buffer evalled.
100 ;;;_* USER CUSTOMIZATION VARIABLES:
102 ;;;_ > defgroup allout
104 "Extensive outline mode for use alone and with other modes."
108 ;;;_ + Layout, Mode, and Topic Header Configuration
110 ;;;_ = allout-auto-activation
111 (defcustom allout-auto-activation nil
112 "*Regulates auto-activation modality of allout outlines - see `allout-init'.
114 Setq-default by `allout-init' to regulate whether or not allout
115 outline mode is automatically activated when the buffer-specific
116 variable `allout-layout' is non-nil, and whether or not the layout
117 dictated by `allout-layout' should be imposed on mode activation.
119 With value t, auto-mode-activation and auto-layout are enabled.
120 \(This also depends on `allout-find-file-hook' being installed in
121 `find-file-hook', which is also done by `allout-init'.)
123 With value `ask', auto-mode-activation is enabled, and endorsement for
124 performing auto-layout is asked of the user each time.
126 With value `activate', only auto-mode-activation is enabled,
129 With value nil, neither auto-mode-activation nor auto-layout are
132 See the docstring for `allout-init' for the proper interface to
134 :type '(choice (const :tag "On" t)
135 (const :tag "Ask about layout" "ask")
136 (const :tag "Mode only" "activate")
137 (const :tag "Off" nil))
139 ;;;_ = allout-default-layout
140 (defcustom allout-default-layout '(-2 : 0)
141 "*Default allout outline layout specification.
143 This setting specifies the outline exposure to use when
144 `allout-layout' has the local value `t'. This docstring describes the
145 layout specifications.
147 A list value specifies a default layout for the current buffer,
148 to be applied upon activation of `allout-mode'. Any non-nil
149 value will automatically trigger `allout-mode', provided
150 `allout-init' has been called to enable this behavior.
152 The types of elements in the layout specification are:
154 integer - dictate the relative depth to open the corresponding topic(s),
156 - negative numbers force the topic to be closed before opening
157 to the absolute value of the number, so all siblings are open
159 - positive numbers open to the relative depth indicated by the
160 number, but do not force already opened subtopics to be closed.
161 - 0 means to close topic - hide all subitems.
162 : - repeat spec - apply the preceeding element to all siblings at
163 current level, *up to* those siblings that would be covered by specs
164 following the `:' on the list. Ie, apply to all topics at level but
165 trailing ones accounted for by trailing specs. \(Only the first of
166 multiple colons at the same level is honored - later ones are ignored.)
167 * - completely exposes the topic, including bodies
168 + - exposes all subtopics, but not the bodies
169 - - exposes the body of the corresponding topic, but not subtopics
170 list - a nested layout spec, to be applied intricately to its
171 corresponding item(s)
175 Collapse the top-level topics to show their children and
176 grandchildren, but completely collapse the final top-level topic.
178 Close the first topic so only the immediate subtopics are shown,
179 leave the subsequent topics exposed as they are until the second
180 second to last topic, which is exposed at least one level, and
181 completely close the last topic.
183 Expose children and grandchildren of all topics at current
184 level except the last two; expose children of the second to
185 last and completely expose the last one, including its subtopics.
187 See `allout-expose-topic' for more about the exposure process.
189 Also, allout's mode-specific provisions will make topic prefixes default
190 to the comment-start string, if any, of the language of the file. This
191 is modulo the setting of `allout-use-mode-specific-leader', which see."
192 :type 'allout-layout-type
194 ;;;_ : allout-layout-type
195 (define-widget 'allout-layout-type 'lazy
196 "Allout layout format customization basic building blocks."
198 (choice (integer :tag "integer (<= zero is strict)")
199 (const :tag ": (repeat prior)" :)
200 (const :tag "* (completely expose)" *)
201 (const :tag "+ (expose all offspring, headlines only)" +)
202 (const :tag "- (expose topic body but not offspring)" -)
203 (allout-layout-type :tag "<Nested layout>"))))
205 ;;;_ = allout-show-bodies
206 (defcustom allout-show-bodies nil
207 "*If non-nil, show entire body when exposing a topic, rather than
211 (make-variable-buffer-local 'allout-show-bodies)
213 (put 'allout-show-bodies 'safe-local-variable
214 (if (fboundp 'booleanp) 'booleanp '(lambda (x) (member x '(t nil)))))
216 ;;;_ = allout-beginning-of-line-cycles
217 (defcustom allout-beginning-of-line-cycles t
218 "*If non-nil, \\[allout-beginning-of-line] will cycle through smart-placement options.
220 Cycling only happens on when the command is repeated, not when it
221 follows a different command.
223 Smart-placement means that repeated calls to this function will
226 - if the cursor is on a non-headline body line and not on the first column:
227 then it goes to the first column
228 - if the cursor is on the first column of a non-headline body line:
229 then it goes to the start of the headline within the item body
230 - if the cursor is on the headline and not the start of the headline:
231 then it goes to the start of the headline
232 - if the cursor is on the start of the headline:
233 then it goes to the bullet character \(for hotspot navigation\)
234 - if the cursor is on the bullet character:
235 then it goes to the first column of that line \(the headline\)
236 - if the cursor is on the first column of the headline:
237 then it goes to the start of the headline within the item body.
239 In this fashion, you can use the beginning-of-line command to do
240 its normal job and then, when repeated, advance through the
241 entry, cycling back to start.
243 If this configuration variable is nil, then the cursor is just
244 advanced to the beginning of the line and remains there on
246 :type 'boolean :group 'allout)
247 ;;;_ = allout-end-of-line-cycles
248 (defcustom allout-end-of-line-cycles t
249 "*If non-nil, \\[allout-end-of-line] will cycle through smart-placement options.
251 Cycling only happens on when the command is repeated, not when it
252 follows a different command.
254 Smart-placement means that repeated calls to this function will
257 - if the cursor is not on the end-of-line,
258 then it goes to the end-of-line
259 - if the cursor is on the end-of-line but not the end-of-entry,
260 then it goes to the end-of-entry, exposing it if necessary
261 - if the cursor is on the end-of-entry,
262 then it goes to the end of the head line
264 In this fashion, you can use the end-of-line command to do its
265 normal job and then, when repeated, advance through the entry,
266 cycling back to start.
268 If this configuration variable is nil, then the cursor is just
269 advanced to the end of the line and remains there on repeated
271 :type 'boolean :group 'allout)
273 ;;;_ = allout-header-prefix
274 (defcustom allout-header-prefix "."
275 ;; this string is treated as literal match. it will be `regexp-quote'd, so
276 ;; one cannot use regular expressions to match varying header prefixes.
277 "*Leading string which helps distinguish topic headers.
279 Outline topic header lines are identified by a leading topic
280 header prefix, which mostly have the value of this var at their front.
281 Level 1 topics are exceptions. They consist of only a single
282 character, which is typically set to the `allout-primary-bullet'."
285 (make-variable-buffer-local 'allout-header-prefix)
287 (put 'allout-header-prefix 'safe-local-variable 'stringp)
288 ;;;_ = allout-primary-bullet
289 (defcustom allout-primary-bullet "*"
290 "Bullet used for top-level outline topics.
292 Outline topic header lines are identified by a leading topic header
293 prefix, which is concluded by bullets that includes the value of this
294 var and the respective allout-*-bullets-string vars.
296 The value of an asterisk (`*') provides for backwards compatibility
297 with the original Emacs outline mode. See `allout-plain-bullets-string'
298 and `allout-distinctive-bullets-string' for the range of available
302 (make-variable-buffer-local 'allout-primary-bullet)
304 (put 'allout-primary-bullet 'safe-local-variable 'stringp)
305 ;;;_ = allout-plain-bullets-string
306 (defcustom allout-plain-bullets-string ".,"
307 "*The bullets normally used in outline topic prefixes.
309 See `allout-distinctive-bullets-string' for the other kind of
312 DO NOT include the close-square-bracket, `]', as a bullet.
314 Outline mode has to be reactivated in order for changes to the value
315 of this var to take effect."
318 (make-variable-buffer-local 'allout-plain-bullets-string)
320 (put 'allout-plain-bullets-string 'safe-local-variable 'stringp)
321 ;;;_ = allout-distinctive-bullets-string
322 (defcustom allout-distinctive-bullets-string "*+-=>()[{}&!?#%\"X@$~_\\:;^"
323 "*Persistent outline header bullets used to distinguish special topics.
325 These bullets are used to distinguish topics from the run-of-the-mill
326 ones. They are not used in the standard topic headers created by
327 the topic-opening, shifting, and rebulleting \(eg, on topic shift,
328 topic paste, blanket rebulleting) routines, but are offered among the
329 choices for rebulleting. They are not altered by the above automatic
330 rebulleting, so they can be used to characterize topics, eg:
333 `\(' parenthetic comment \(with a matching close paren inside)
334 `[' meta-note \(with a matching close ] inside)
340 ... for example. (`#' typically has a special meaning to the software,
341 according to the value of `allout-numbered-bullet'.)
343 See `allout-plain-bullets-string' for the selection of
346 You must run `set-allout-regexp' in order for outline mode to
347 reconcile to changes of this value.
349 DO NOT include the close-square-bracket, `]', on either of the bullet
353 (make-variable-buffer-local 'allout-distinctive-bullets-string)
355 (put 'allout-distinctive-bullets-string 'safe-local-variable 'stringp)
357 ;;;_ = allout-use-mode-specific-leader
358 (defcustom allout-use-mode-specific-leader t
359 "*When non-nil, use mode-specific topic-header prefixes.
361 Allout outline mode will use the mode-specific `allout-mode-leaders' or
362 comment-start string, if any, to lead the topic prefix string, so topic
363 headers look like comments in the programming language. It will also use
364 the comment-start string, with an '_' appended, for `allout-primary-bullet'.
366 String values are used as literals, not regular expressions, so
367 do not escape any regulare-expression characters.
369 Value t means to first check for assoc value in `allout-mode-leaders'
370 alist, then use comment-start string, if any, then use default \(`.').
371 \(See note about use of comment-start strings, below.)
373 Set to the symbol for either of `allout-mode-leaders' or
374 `comment-start' to use only one of them, respectively.
376 Value nil means to always use the default \(`.') and leave
377 `allout-primary-bullet' unaltered.
379 comment-start strings that do not end in spaces are tripled in
380 the header-prefix, and an `_' underscore is tacked on the end, to
381 distinguish them from regular comment strings. comment-start
382 strings that do end in spaces are not tripled, but an underscore
383 is substituted for the space. [This presumes that the space is
384 for appearance, not comment syntax. You can use
385 `allout-mode-leaders' to override this behavior, when
387 :type '(choice (const t) (const nil) string
388 (const allout-mode-leaders)
389 (const comment-start))
392 (put 'allout-use-mode-specific-leader 'safe-local-variable
393 '(lambda (x) (or (memq x '(t nil allout-mode-leaders comment-start))
395 ;;;_ = allout-mode-leaders
396 (defvar allout-mode-leaders '()
397 "Specific allout-prefix leading strings per major modes.
399 Use this if the mode's comment-start string isn't what you
400 prefer, or if the mode lacks a comment-start string. See
401 `allout-use-mode-specific-leader' for more details.
403 If you're constructing a string that will comment-out outline
404 structuring so it can be included in program code, append an extra
405 character, like an \"_\" underscore, to distinguish the lead string
406 from regular comments that start at the beginning-of-line.")
408 ;;;_ = allout-old-style-prefixes
409 (defcustom allout-old-style-prefixes nil
410 "*When non-nil, use only old-and-crusty `outline-mode' `*' topic prefixes.
412 Non-nil restricts the topic creation and modification
413 functions to asterix-padded prefixes, so they look exactly
414 like the original Emacs-outline style prefixes.
416 Whatever the setting of this variable, both old and new style prefixes
417 are always respected by the topic maneuvering functions."
420 (make-variable-buffer-local 'allout-old-style-prefixes)
422 (put 'allout-old-style-prefixes 'safe-local-variable
423 (if (fboundp 'booleanp) 'booleanp '(lambda (x) (member x '(t nil)))))
424 ;;;_ = allout-stylish-prefixes - alternating bullets
425 (defcustom allout-stylish-prefixes t
426 "*Do fancy stuff with topic prefix bullets according to level, etc.
428 Non-nil enables topic creation, modification, and repositioning
429 functions to vary the topic bullet char (the char that marks the topic
430 depth) just preceding the start of the topic text) according to level.
431 Otherwise, only asterisks (`*') and distinctive bullets are used.
433 This is how an outline can look (but sans indentation) with stylish
438 . + One level 3 subtopic
439 . . One level 4 subtopic
440 . . A second 4 subtopic
441 . + Another level 3 subtopic
442 . #1 A numbered level 4 subtopic
444 . ! Another level 4 subtopic with a different distinctive bullet
445 . #4 And another numbered level 4 subtopic
447 This would be an outline with stylish prefixes inhibited (but the
448 numbered and other distinctive bullets retained):
452 . * One level 3 subtopic
453 . * One level 4 subtopic
454 . * A second 4 subtopic
455 . * Another level 3 subtopic
456 . #1 A numbered level 4 subtopic
458 . ! Another level 4 subtopic with a different distinctive bullet
459 . #4 And another numbered level 4 subtopic
461 Stylish and constant prefixes (as well as old-style prefixes) are
462 always respected by the topic maneuvering functions, regardless of
463 this variable setting.
465 The setting of this var is not relevant when `allout-old-style-prefixes'
469 (make-variable-buffer-local 'allout-stylish-prefixes)
471 (put 'allout-stylish-prefixes 'safe-local-variable
472 (if (fboundp 'booleanp) 'booleanp '(lambda (x) (member x '(t nil)))))
474 ;;;_ = allout-numbered-bullet
475 (defcustom allout-numbered-bullet "#"
476 "*String designating bullet of topics that have auto-numbering; nil for none.
478 Topics having this bullet have automatic maintenance of a sibling
479 sequence-number tacked on, just after the bullet. Conventionally set
480 to \"#\", you can set it to a bullet of your choice. A nil value
481 disables numbering maintenance."
482 :type '(choice (const nil) string)
484 (make-variable-buffer-local 'allout-numbered-bullet)
486 (put 'allout-numbered-bullet 'safe-local-variable
487 (if (fboundp 'string-or-null-p)
489 '(lambda (x) (or (stringp x) (null x)))))
490 ;;;_ = allout-file-xref-bullet
491 (defcustom allout-file-xref-bullet "@"
492 "*Bullet signifying file cross-references, for `allout-resolve-xref'.
494 Set this var to the bullet you want to use for file cross-references."
495 :type '(choice (const nil) string)
498 (put 'allout-file-xref-bullet 'safe-local-variable
499 (if (fboundp 'string-or-null-p)
501 '(lambda (x) (or (stringp x) (null x)))))
502 ;;;_ = allout-presentation-padding
503 (defcustom allout-presentation-padding 2
504 "*Presentation-format white-space padding factor, for greater indent."
508 (make-variable-buffer-local 'allout-presentation-padding)
510 (put 'allout-presentation-padding 'safe-local-variable 'integerp)
512 ;;;_ = allout-abbreviate-flattened-numbering
513 (defcustom allout-abbreviate-flattened-numbering nil
514 "*If non-nil, `allout-flatten-exposed-to-buffer' abbreviates topic
515 numbers to minimal amount with some context. Otherwise, entire
516 numbers are always used."
520 ;;;_ + LaTeX formatting
521 ;;;_ - allout-number-pages
522 (defcustom allout-number-pages nil
523 "*Non-nil turns on page numbering for LaTeX formatting of an outline."
526 ;;;_ - allout-label-style
527 (defcustom allout-label-style "\\large\\bf"
528 "*Font and size of labels for LaTeX formatting of an outline."
531 ;;;_ - allout-head-line-style
532 (defcustom allout-head-line-style "\\large\\sl "
533 "*Font and size of entries for LaTeX formatting of an outline."
536 ;;;_ - allout-body-line-style
537 (defcustom allout-body-line-style " "
538 "*Font and size of entries for LaTeX formatting of an outline."
541 ;;;_ - allout-title-style
542 (defcustom allout-title-style "\\Large\\bf"
543 "*Font and size of titles for LaTeX formatting of an outline."
547 (defcustom allout-title '(or buffer-file-name (buffer-name))
548 "*Expression to be evaluated to determine the title for LaTeX
552 ;;;_ - allout-line-skip
553 (defcustom allout-line-skip ".05cm"
554 "*Space between lines for LaTeX formatting of an outline."
558 (defcustom allout-indent ".3cm"
559 "*LaTeX formatted depth-indent spacing."
563 ;;;_ + Topic encryption
564 ;;;_ = allout-encryption group
565 (defgroup allout-encryption nil
566 "Settings for topic encryption features of allout outliner."
568 ;;;_ = allout-topic-encryption-bullet
569 (defcustom allout-topic-encryption-bullet "~"
570 "*Bullet signifying encryption of the entry's body."
571 :type '(choice (const nil) string)
573 :group 'allout-encryption)
574 ;;;_ = allout-passphrase-verifier-handling
575 (defcustom allout-passphrase-verifier-handling t
576 "*Enable use of symmetric encryption passphrase verifier if non-nil.
578 See the docstring for the `allout-enable-file-variable-adjustment'
579 variable for details about allout ajustment of file variables."
582 :group 'allout-encryption)
583 (make-variable-buffer-local 'allout-passphrase-verifier-handling)
584 ;;;_ = allout-passphrase-hint-handling
585 (defcustom allout-passphrase-hint-handling 'always
586 "*Dictate outline encryption passphrase reminder handling:
588 always - always show reminder when prompting
589 needed - show reminder on passphrase entry failure
590 disabled - never present or adjust reminder
592 See the docstring for the `allout-enable-file-variable-adjustment'
593 variable for details about allout ajustment of file variables."
594 :type '(choice (const always)
598 :group 'allout-encryption)
599 (make-variable-buffer-local 'allout-passphrase-hint-handling)
600 ;;;_ = allout-encrypt-unencrypted-on-saves
601 (defcustom allout-encrypt-unencrypted-on-saves t
602 "*When saving, should topics pending encryption be encrypted?
604 The idea is to prevent file-system exposure of any un-encrypted stuff, and
605 mostly covers both deliberate file writes and auto-saves.
607 - Yes: encrypt all topics pending encryption, even if it's the one
608 currently being edited. \(In that case, the currently edited topic
609 will be automatically decrypted before any user interaction, so they
610 can continue editing but the copy on the file system will be
612 Auto-saves will use the \"All except current topic\" mode if this
613 one is selected, to avoid practical difficulties - see below.
614 - All except current topic: skip the topic currently being edited, even if
615 it's pending encryption. This may expose the current topic on the
616 file sytem, but avoids the nuisance of prompts for the encryption
617 passphrase in the middle of editing for, eg, autosaves.
618 This mode is used for auto-saves for both this option and \"Yes\".
619 - No: leave it to the user to encrypt any unencrypted topics.
621 For practical reasons, auto-saves always use the 'except-current policy
622 when auto-encryption is enabled. \(Otherwise, spurious passphrase prompts
623 and unavoidable timing collisions are too disruptive.) If security for a
624 file requires that even the current topic is never auto-saved in the clear,
625 disable auto-saves for that file."
627 :type '(choice (const :tag "Yes" t)
628 (const :tag "All except current topic" except-current)
629 (const :tag "No" nil))
631 :group 'allout-encryption)
632 (make-variable-buffer-local 'allout-encrypt-unencrypted-on-saves)
635 ;;;_ = allout-developer group
636 (defgroup allout-developer nil
637 "Settings for topic encryption features of allout outliner."
639 ;;;_ = allout-run-unit-tests-on-load
640 (defcustom allout-run-unit-tests-on-load nil
641 "*When non-nil, unit tests will be run at end of loading the allout module.
643 Generally, allout code developers are the only ones who'll want to set this.
645 \(If set, this makes it an even better practice to exercise changes by
646 doing byte-compilation with a repeat count, so the file is loaded after
649 See `allout-run-unit-tests' to see what's run."
651 :group 'allout-developer)
653 ;;;_ + Miscellaneous customization
655 ;;;_ = allout-command-prefix
656 (defcustom allout-command-prefix "\C-c "
657 "*Key sequence to be used as prefix for outline mode command key bindings.
659 Default is '\C-c<space>'; just '\C-c' is more short-and-sweet, if you're
660 willing to let allout use a bunch of \C-c keybindings."
664 ;;;_ = allout-keybindings-list
665 ;;; You have to reactivate allout-mode - `(allout-mode t)' - to
666 ;;; institute changes to this var.
667 (defvar allout-keybindings-list ()
668 "*List of `allout-mode' key / function bindings, for `allout-mode-map'.
670 String or vector key will be prefaced with `allout-command-prefix',
671 unless optional third, non-nil element is present.")
672 (setq allout-keybindings-list
675 ("\C-n" allout-next-visible-heading)
676 ("\C-p" allout-previous-visible-heading)
677 ("\C-u" allout-up-current-level)
678 ("\C-f" allout-forward-current-level)
679 ("\C-b" allout-backward-current-level)
680 ("\C-a" allout-beginning-of-current-entry)
681 ("\C-e" allout-end-of-entry)
683 ("\C-i" allout-show-children)
684 ("\C-s" allout-show-current-subtree)
685 ("\C-h" allout-hide-current-subtree)
686 ("h" allout-hide-current-subtree)
687 ("\C-o" allout-show-current-entry)
688 ("!" allout-show-all)
689 ("x" allout-toggle-current-subtree-encryption)
690 ; Alteration commands:
691 (" " allout-open-sibtopic)
692 ("." allout-open-subtopic)
693 ("," allout-open-supertopic)
694 ("'" allout-shift-in)
695 (">" allout-shift-in)
696 ("<" allout-shift-out)
697 ("\C-m" allout-rebullet-topic)
698 ("*" allout-rebullet-current-heading)
699 ("#" allout-number-siblings)
700 ("\C-k" allout-kill-line t)
701 ("\M-k" allout-copy-line-as-kill t)
702 ("\C-y" allout-yank t)
703 ("\M-y" allout-yank-pop t)
704 ("\C-k" allout-kill-topic)
705 ("\M-k" allout-copy-topic-as-kill)
706 ; Miscellaneous commands:
707 ;([?\C-\ ] allout-mark-topic)
708 ("@" allout-resolve-xref)
709 ("=c" allout-copy-exposed-to-buffer)
710 ("=i" allout-indented-exposed-to-buffer)
711 ("=t" allout-latexify-exposed)
712 ("=p" allout-flatten-exposed-to-buffer)))
714 ;;;_ = allout-inhibit-auto-fill
715 (defcustom allout-inhibit-auto-fill nil
716 "*If non-nil, auto-fill will be inhibited in the allout buffers.
718 You can customize this setting to set it for all allout buffers, or set it
719 in individual buffers if you want to inhibit auto-fill only in particular
720 buffers. \(You could use a function on `allout-mode-hook' to inhibit
721 auto-fill according, eg, to the major mode.\)
723 If you don't set this and auto-fill-mode is enabled, allout will use the
724 value that `normal-auto-fill-function', if any, when allout mode starts, or
725 else allout's special hanging-indent maintaining auto-fill function,
729 (make-variable-buffer-local 'allout-inhibit-auto-fill)
731 ;;;_ = allout-use-hanging-indents
732 (defcustom allout-use-hanging-indents t
733 "*If non-nil, topic body text auto-indent defaults to indent of the header.
734 Ie, it is indented to be just past the header prefix. This is
735 relevant mostly for use with indented-text-mode, or other situations
736 where auto-fill occurs."
739 (make-variable-buffer-local 'allout-use-hanging-indents)
741 (put 'allout-use-hanging-indents 'safe-local-variable
742 (if (fboundp 'booleanp) 'booleanp '(lambda (x) (member x '(t nil)))))
744 ;;;_ = allout-reindent-bodies
745 (defcustom allout-reindent-bodies (if allout-use-hanging-indents
747 "*Non-nil enables auto-adjust of topic body hanging indent with depth shifts.
749 When active, topic body lines that are indented even with or beyond
750 their topic header are reindented to correspond with depth shifts of
753 A value of t enables reindent in non-programming-code buffers, ie
754 those that do not have the variable `comment-start' set. A value of
755 `force' enables reindent whether or not `comment-start' is set."
756 :type '(choice (const nil) (const t) (const text) (const force))
759 (make-variable-buffer-local 'allout-reindent-bodies)
761 (put 'allout-reindent-bodies 'safe-local-variable
762 '(lambda (x) (memq x '(nil t text force))))
764 ;;;_ = allout-enable-file-variable-adjustment
765 (defcustom allout-enable-file-variable-adjustment t
766 "*If non-nil, some allout outline actions edit Emacs local file var text.
768 This can range from changes to existing entries, addition of new ones,
769 and creation of a new local variables section when necessary.
771 Emacs file variables adjustments are also inhibited if `enable-local-variables'
774 Operations potentially causing edits include allout encryption routines.
775 For details, see `allout-toggle-current-subtree-encryption's docstring."
778 (make-variable-buffer-local 'allout-enable-file-variable-adjustment)
780 ;;;_* CODE - no user customizations below.
782 ;;;_ #1 Internal Outline Formatting and Configuration
784 ;;;_ = allout-version
785 (defvar allout-version "2.2.1"
786 "Version of currently loaded outline package. \(allout.el)")
787 ;;;_ > allout-version
788 (defun allout-version (&optional here)
789 "Return string describing the loaded outline version."
791 (let ((msg (concat "Allout Outline Mode v " allout-version)))
792 (if here (insert msg))
795 ;;;_ : Mode activation (defined here because it's referenced early)
797 (defvar allout-mode nil "Allout outline mode minor-mode flag.")
798 (make-variable-buffer-local 'allout-mode)
799 ;;;_ = allout-layout nil
800 (defvar allout-layout nil ; LEAVE GLOBAL VALUE NIL - see docstring.
801 "Buffer-specific setting for allout layout.
803 In buffers where this is non-nil \(and if `allout-init' has been run, to
804 enable this behavior), `allout-mode' will be automatically activated. The
805 layout dictated by the value will be used to set the initial exposure when
806 `allout-mode' is activated.
808 \*You should not setq-default this variable non-nil unless you want every
809 visited file to be treated as an allout file.*
811 The value would typically be set by a file local variable. For
812 example, the following lines at the bottom of an Emacs Lisp file:
815 ;;;allout-layout: \(0 : -1 -1 0)
818 dictate activation of `allout-mode' mode when the file is visited
819 \(presuming allout-init was already run), followed by the
820 equivalent of `\(allout-expose-topic 0 : -1 -1 0)'. \(This is
821 the layout used for the allout.el source file.)
823 `allout-default-layout' describes the specification format.
824 `allout-layout' can additionally have the value `t', in which
825 case the value of `allout-default-layout' is used.")
826 (make-variable-buffer-local 'allout-layout)
828 (put 'allout-layout 'safe-local-variable
829 '(lambda (x) (or (numberp x) (listp x) (memq x '(: * + -)))))
831 ;;;_ : Topic header format
833 (defvar allout-regexp ""
834 "*Regular expression to match the beginning of a heading line.
836 Any line whose beginning matches this regexp is considered a
837 heading. This var is set according to the user configuration vars
838 by `set-allout-regexp'.")
839 (make-variable-buffer-local 'allout-regexp)
840 ;;;_ = allout-bullets-string
841 (defvar allout-bullets-string ""
842 "A string dictating the valid set of outline topic bullets.
844 This var should *not* be set by the user - it is set by `set-allout-regexp',
845 and is produced from the elements of `allout-plain-bullets-string'
846 and `allout-distinctive-bullets-string'.")
847 (make-variable-buffer-local 'allout-bullets-string)
848 ;;;_ = allout-bullets-string-len
849 (defvar allout-bullets-string-len 0
850 "Length of current buffers' `allout-plain-bullets-string'.")
851 (make-variable-buffer-local 'allout-bullets-string-len)
852 ;;;_ = allout-depth-specific-regexp
853 (defvar allout-depth-specific-regexp ""
854 "*Regular expression to match a heading line prefix for a particular depth.
856 This expression is used to search for depth-specific topic
857 headers at depth 2 and greater. Use `allout-depth-one-regexp'
858 for to seek topics at depth one.
860 This var is set according to the user configuration vars by
861 `set-allout-regexp'. It is prepared with format strings for two
862 decimal numbers, which should each be one less than the depth of the
863 topic prefix to be matched.")
864 (make-variable-buffer-local 'allout-depth-specific-regexp)
865 ;;;_ = allout-depth-one-regexp
866 (defvar allout-depth-one-regexp ""
867 "*Regular expression to match a heading line prefix for depth one.
869 This var is set according to the user configuration vars by
870 `set-allout-regexp'. It is prepared with format strings for two
871 decimal numbers, which should each be one less than the depth of the
872 topic prefix to be matched.")
873 (make-variable-buffer-local 'allout-depth-one-regexp)
874 ;;;_ = allout-line-boundary-regexp
875 (defvar allout-line-boundary-regexp ()
876 "`allout-regexp' with outline style beginning-of-line anchor.
878 This is properly set by `set-allout-regexp'.")
879 (make-variable-buffer-local 'allout-line-boundary-regexp)
880 ;;;_ = allout-bob-regexp
881 (defvar allout-bob-regexp ()
882 "Like `allout-line-boundary-regexp', for headers at beginning of buffer.")
883 (make-variable-buffer-local 'allout-bob-regexp)
884 ;;;_ = allout-header-subtraction
885 (defvar allout-header-subtraction (1- (length allout-header-prefix))
886 "Allout-header prefix length to subtract when computing topic depth.")
887 (make-variable-buffer-local 'allout-header-subtraction)
888 ;;;_ = allout-plain-bullets-string-len
889 (defvar allout-plain-bullets-string-len (length allout-plain-bullets-string)
890 "Length of `allout-plain-bullets-string', updated by `set-allout-regexp'.")
891 (make-variable-buffer-local 'allout-plain-bullets-string-len)
893 ;;;_ = allout-doublecheck-at-and-shallower
894 (defconst allout-doublecheck-at-and-shallower 3
895 "Verify apparent topics of this depth and shallower as being non-aberrant.
897 Verified with `allout-aberrant-container-p'. This check's usefulness is
898 limited to shallow prospects, because the determination of aberrance
899 depends on the mistaken item being followed by a legitimate item of
900 excessively greater depth.")
901 ;;;_ X allout-reset-header-lead (header-lead)
902 (defun allout-reset-header-lead (header-lead)
903 "*Reset the leading string used to identify topic headers."
904 (interactive "sNew lead string: ")
905 (setq allout-header-prefix header-lead)
906 (setq allout-header-subtraction (1- (length allout-header-prefix)))
908 ;;;_ X allout-lead-with-comment-string (header-lead)
909 (defun allout-lead-with-comment-string (&optional header-lead)
910 "*Set the topic-header leading string to specified string.
912 Useful when for encapsulating outline structure in programming
913 language comments. Returns the leading string."
916 (if (not (stringp header-lead))
917 (setq header-lead (read-string
918 "String prefix for topic headers: ")))
919 (setq allout-reindent-bodies nil)
920 (allout-reset-header-lead header-lead)
922 ;;;_ > allout-infer-header-lead-and-primary-bullet ()
923 (defun allout-infer-header-lead-and-primary-bullet ()
924 "Determine appropriate `allout-header-prefix' and `allout-primary-bullet'.
926 Works according to settings of:
929 `allout-header-prefix' (default)
930 `allout-use-mode-specific-leader'
931 and `allout-mode-leaders'.
933 Apply this via \(re)activation of `allout-mode', rather than
934 invoking it directly."
935 (let* ((use-leader (and (boundp 'allout-use-mode-specific-leader)
936 (if (or (stringp allout-use-mode-specific-leader)
937 (memq allout-use-mode-specific-leader
938 '(allout-mode-leaders
941 allout-use-mode-specific-leader
942 ;; Oops - garbled value, equate with effect of 't:
946 ((not use-leader) nil)
947 ;; Use the explicitly designated leader:
948 ((stringp use-leader) use-leader)
949 (t (or (and (memq use-leader '(t allout-mode-leaders))
950 ;; Get it from outline mode leaders?
951 (cdr (assq major-mode allout-mode-leaders)))
952 ;; ... didn't get from allout-mode-leaders...
953 (and (memq use-leader '(t comment-start))
955 ;; Use comment-start, maybe tripled, and with
959 (substring comment-start
960 (1- (length comment-start))))
961 ;; Use comment-start, sans trailing space:
962 (substring comment-start 0 -1)
963 (concat comment-start comment-start comment-start))
964 ;; ... and append underscore, whichever:
968 (setq allout-header-prefix leader)
969 (if (not allout-old-style-prefixes)
970 ;; setting allout-primary-bullet makes the top level topics use -
971 ;; actually, be - the special prefix:
972 (setq allout-primary-bullet leader))
973 allout-header-prefix)))
974 (defalias 'allout-infer-header-lead
975 'allout-infer-header-lead-and-primary-bullet)
976 ;;;_ > allout-infer-body-reindent ()
977 (defun allout-infer-body-reindent ()
978 "Determine proper setting for `allout-reindent-bodies'.
980 Depends on default setting of `allout-reindent-bodies' \(which see)
981 and presence of setting for `comment-start', to tell whether the
982 file is programming code."
983 (if (and allout-reindent-bodies
985 (not (eq 'force allout-reindent-bodies)))
986 (setq allout-reindent-bodies nil)))
987 ;;;_ > set-allout-regexp ()
988 (defun set-allout-regexp ()
989 "Generate proper topic-header regexp form for outline functions.
991 Works with respect to `allout-plain-bullets-string' and
992 `allout-distinctive-bullets-string'.
994 Also refresh various data structures that hinge on the regexp."
997 ;; Derive allout-bullets-string from user configured components:
998 (setq allout-bullets-string "")
999 (let ((strings (list 'allout-plain-bullets-string
1000 'allout-distinctive-bullets-string
1001 'allout-primary-bullet))
1008 (setq cur-len (length (setq cur-string (symbol-value (car strings)))))
1009 (while (< index cur-len)
1010 (setq cur-char (aref cur-string index))
1011 (setq allout-bullets-string
1012 (concat allout-bullets-string
1014 ; Single dash would denote a
1015 ; sequence, repeated denotes
1017 ((eq cur-char ?-) "--")
1018 ; literal close-square-bracket
1019 ; doesn't work right in the
1021 ((eq cur-char ?\]) "")
1022 (t (regexp-quote (char-to-string cur-char))))))
1023 (setq index (1+ index)))
1024 (setq strings (cdr strings)))
1026 ;; Derive next for repeated use in allout-pending-bullet:
1027 (setq allout-plain-bullets-string-len (length allout-plain-bullets-string))
1028 (setq allout-header-subtraction (1- (length allout-header-prefix)))
1030 (let (new-part old-part)
1031 (setq new-part (concat "\\("
1032 (regexp-quote allout-header-prefix)
1034 ;; already regexp-quoted in a custom way:
1035 "[" allout-bullets-string "]"
1037 old-part (concat "\\("
1038 (regexp-quote allout-primary-bullet)
1040 (regexp-quote allout-header-prefix)
1043 " ?[^" allout-primary-bullet "]")
1044 allout-regexp (concat new-part
1049 allout-line-boundary-regexp (concat "\n" new-part
1053 allout-bob-regexp (concat "\\`" new-part
1057 (setq allout-depth-specific-regexp
1058 (concat "\\(^\\|\\`\\)"
1061 ;; new-style spacers-then-bullet string:
1063 (allout-format-quote (regexp-quote allout-header-prefix))
1065 "[" (allout-format-quote allout-bullets-string) "]"
1068 ;; old-style all-bullets string, if primary not multi-char:
1069 (if (< 0 allout-header-subtraction)
1072 (allout-format-quote
1073 (regexp-quote allout-primary-bullet))
1074 (allout-format-quote
1075 (regexp-quote allout-primary-bullet))
1076 (allout-format-quote
1077 (regexp-quote allout-primary-bullet))
1079 ;; disqualify greater depths:
1081 (allout-format-quote allout-primary-bullet)
1086 (setq allout-depth-one-regexp
1087 (concat "\\(^\\|\\`\\)"
1091 (regexp-quote allout-header-prefix)
1092 ;; disqualify any bullet char following any amount of
1093 ;; intervening whitespace:
1095 (concat "[^ " allout-bullets-string "]")
1097 (if (< 0 allout-header-subtraction)
1098 ;; Need not support anything like the old
1099 ;; bullet style if the prefix is multi-char.
1102 (regexp-quote allout-primary-bullet)
1103 ;; disqualify deeper primary-bullet sequences:
1104 "[^" allout-primary-bullet "]"))
1108 ;;;_ = allout-mode-map
1109 (defvar allout-mode-map nil "Keybindings for (allout) outline minor mode.")
1110 ;;;_ > produce-allout-mode-map (keymap-alist &optional base-map)
1111 (defun produce-allout-mode-map (keymap-list &optional base-map)
1112 "Produce keymap for use as allout-mode-map, from KEYMAP-LIST.
1114 Built on top of optional BASE-MAP, or empty sparse map if none specified.
1115 See doc string for allout-keybindings-list for format of binding list."
1116 (let ((map (or base-map (make-sparse-keymap)))
1117 (pref (list allout-command-prefix)))
1120 (let ((add-pref (null (cdr (cdr cell))))
1121 (key-suff (list (car cell))))
1124 (apply 'concat (if add-pref
1125 (append pref key-suff)
1127 (car (cdr cell)))))))
1131 (defvar allout-mode-exposure-menu)
1132 (defvar allout-mode-editing-menu)
1133 (defvar allout-mode-navigation-menu)
1134 (defvar allout-mode-misc-menu)
1135 (defun produce-allout-mode-menubar-entries ()
1137 (easy-menu-define allout-mode-exposure-menu
1139 "Allout outline exposure menu."
1141 ["Show Entry" allout-show-current-entry t]
1142 ["Show Children" allout-show-children t]
1143 ["Show Subtree" allout-show-current-subtree t]
1144 ["Hide Subtree" allout-hide-current-subtree t]
1145 ["Hide Leaves" allout-hide-current-leaves t]
1147 ["Show All" allout-show-all t]))
1148 (easy-menu-define allout-mode-editing-menu
1150 "Allout outline editing menu."
1152 ["Open Sibling" allout-open-sibtopic t]
1153 ["Open Subtopic" allout-open-subtopic t]
1154 ["Open Supertopic" allout-open-supertopic t]
1156 ["Shift Topic In" allout-shift-in t]
1157 ["Shift Topic Out" allout-shift-out t]
1158 ["Rebullet Topic" allout-rebullet-topic t]
1159 ["Rebullet Heading" allout-rebullet-current-heading t]
1160 ["Number Siblings" allout-number-siblings t]
1162 ["Toggle Topic Encryption"
1163 allout-toggle-current-subtree-encryption
1164 (> (allout-current-depth) 1)]))
1165 (easy-menu-define allout-mode-navigation-menu
1167 "Allout outline navigation menu."
1169 ["Next Visible Heading" allout-next-visible-heading t]
1170 ["Previous Visible Heading"
1171 allout-previous-visible-heading t]
1173 ["Up Level" allout-up-current-level t]
1174 ["Forward Current Level" allout-forward-current-level t]
1175 ["Backward Current Level"
1176 allout-backward-current-level t]
1178 ["Beginning of Entry"
1179 allout-beginning-of-current-entry t]
1180 ["End of Entry" allout-end-of-entry t]
1181 ["End of Subtree" allout-end-of-current-subtree t]))
1182 (easy-menu-define allout-mode-misc-menu
1184 "Allout outlines miscellaneous bindings."
1186 ["Version" allout-version t]
1188 ["Duplicate Exposed" allout-copy-exposed-to-buffer t]
1189 ["Duplicate Exposed, numbered"
1190 allout-flatten-exposed-to-buffer t]
1191 ["Duplicate Exposed, indented"
1192 allout-indented-exposed-to-buffer t]
1194 ["Set Header Lead" allout-reset-header-lead t]
1195 ["Set New Exposure" allout-expose-topic t])))
1196 ;;;_ : Allout Modal-Variables Utilities
1197 ;;;_ = allout-mode-prior-settings
1198 (defvar allout-mode-prior-settings nil
1199 "Internal `allout-mode' use; settings to be resumed on mode deactivation.
1201 See `allout-add-resumptions' and `allout-do-resumptions'.")
1202 (make-variable-buffer-local 'allout-mode-prior-settings)
1203 ;;;_ > allout-add-resumptions (&rest pairs)
1204 (defun allout-add-resumptions (&rest pairs)
1205 "Set name/value PAIRS.
1207 Old settings are preserved for later resumption using `allout-do-resumptions'.
1209 The new values are set as a buffer local. On resumption, the prior buffer
1210 scope of the variable is restored along with its value. If it was a void
1211 buffer-local value, then it is left as nil on resumption.
1213 The pairs are lists whose car is the name of the variable and car of the
1214 cdr is the new value: '(some-var some-value)'. The pairs can actually be
1215 triples, where the third element qualifies the disposition of the setting,
1216 as described further below.
1218 If the optional third element is the symbol 'extend, then the new value
1219 created by `cons'ing the second element of the pair onto the front of the
1222 If the optional third element is the symbol 'append, then the new value is
1223 extended from the existing one by `append'ing a list containing the second
1224 element of the pair onto the end of the existing value.
1226 Extension, and resumptions in general, should not be used for hook
1227 functions - use the 'local mode of `add-hook' for that, instead.
1229 The settings are stored on `allout-mode-prior-settings'."
1231 (let* ((pair (pop pairs))
1234 (qualifier (if (> (length pair) 2)
1237 (if (not (symbolp name))
1238 (error "Pair's name, %S, must be a symbol, not %s"
1239 name (type-of name)))
1240 (setq prior-value (condition-case nil
1242 (void-variable nil)))
1243 (when (not (assoc name allout-mode-prior-settings))
1244 ;; Not already added as a resumption, create the prior setting entry.
1245 (if (local-variable-p name)
1246 ;; is already local variable - preserve the prior value:
1247 (push (list name prior-value) allout-mode-prior-settings)
1248 ;; wasn't local variable, indicate so for resumption by killing
1249 ;; local value, and make it local:
1250 (push (list name) allout-mode-prior-settings)
1251 (make-local-variable name)))
1253 (cond ((eq qualifier 'extend)
1254 (if (not (listp prior-value))
1255 (error "extension of non-list prior value attempted")
1256 (set name (cons value prior-value))))
1257 ((eq qualifier 'append)
1258 (if (not (listp prior-value))
1259 (error "appending of non-list prior value attempted")
1260 (set name (append prior-value (list value)))))
1261 (t (error "unrecognized setting qualifier `%s' encountered"
1263 (set name value)))))
1264 ;;;_ > allout-do-resumptions ()
1265 (defun allout-do-resumptions ()
1266 "Resume all name/value settings registered by `allout-add-resumptions'.
1268 This is used when concluding allout-mode, to resume selected variables to
1269 their settings before allout-mode was started."
1271 (while allout-mode-prior-settings
1272 (let* ((pair (pop allout-mode-prior-settings))
1274 (value-cell (cdr pair)))
1275 (if (not value-cell)
1276 ;; Prior value was global:
1277 (kill-local-variable name)
1278 ;; Prior value was explicit:
1279 (set name (car value-cell))))))
1280 ;;;_ : Mode-specific incidentals
1281 ;;;_ > allout-unprotected (expr)
1282 (defmacro allout-unprotected (expr)
1283 "Enable internal outline operations to alter invisible text."
1284 `(let ((inhibit-read-only (if (not buffer-read-only) t))
1285 (inhibit-field-text-motion t))
1287 ;;;_ = allout-mode-hook
1288 (defvar allout-mode-hook nil
1289 "*Hook that's run when allout mode starts.")
1290 ;;;_ = allout-mode-deactivate-hook
1291 (defvar allout-mode-deactivate-hook nil
1292 "*Hook that's run when allout mode ends.")
1293 ;;;_ = allout-exposure-category
1294 (defvar allout-exposure-category nil
1295 "Symbol for use as allout invisible-text overlay category.")
1296 ;;;_ x allout-view-change-hook
1297 (defvar allout-view-change-hook nil
1298 "*\(Deprecated\) A hook run after allout outline exposure changes.
1300 Switch to using `allout-exposure-change-hook' instead. Both hooks are
1301 currently respected, but the other conveys the details of the exposure
1302 change via explicit parameters, and this one will eventually be disabled in
1303 a subsequent allout version.")
1304 ;;;_ = allout-exposure-change-hook
1305 (defvar allout-exposure-change-hook nil
1306 "*Hook that's run after allout outline subtree exposure changes.
1308 It is run at the conclusion of `allout-flag-region'.
1310 Functions on the hook must take three arguments:
1312 - from - integer indicating the point at the start of the change.
1313 - to - integer indicating the point of the end of the change.
1314 - flag - change mode: nil for exposure, otherwise concealment.
1316 This hook might be invoked multiple times by a single command.
1318 This hook is replacing `allout-view-change-hook', which is being deprecated
1319 and eventually will not be invoked.")
1320 ;;;_ = allout-structure-added-hook
1321 (defvar allout-structure-added-hook nil
1322 "*Hook that's run after addition of items to the outline.
1324 Functions on the hook should take two arguments:
1326 - new-start - integer indicating the point at the start of the first new item.
1327 - new-end - integer indicating the point of the end of the last new item.
1329 Some edits that introduce new items may missed by this hook -
1330 specifically edits that native allout routines do not control.
1332 This hook might be invoked multiple times by a single command.")
1333 ;;;_ = allout-structure-deleted-hook
1334 (defvar allout-structure-deleted-hook nil
1335 "*Hook that's run after disciplined deletion of subtrees from the outline.
1337 Functions on the hook must take two arguments:
1339 - depth - integer indicating the depth of the subtree that was deleted.
1340 - removed-from - integer indicating the point where the subtree was removed.
1342 Some edits that remove or invalidate items may missed by this hook -
1343 specifically edits that native allout routines do not control.
1345 This hook might be invoked multiple times by a single command.")
1346 ;;;_ = allout-structure-shifted-hook
1347 (defvar allout-structure-shifted-hook nil
1348 "*Hook that's run after shifting of items in the outline.
1350 Functions on the hook should take two arguments:
1352 - depth-change - integer indicating depth increase, negative for decrease
1353 - start - integer indicating the start point of the shifted parent item.
1355 Some edits that shift items can be missed by this hook - specifically edits
1356 that native allout routines do not control.
1358 This hook might be invoked multiple times by a single command.")
1359 ;;;_ = allout-outside-normal-auto-fill-function
1360 (defvar allout-outside-normal-auto-fill-function nil
1361 "Value of normal-auto-fill-function outside of allout mode.
1363 Used by allout-auto-fill to do the mandated normal-auto-fill-function
1364 wrapped within allout's automatic fill-prefix setting.")
1365 (make-variable-buffer-local 'allout-outside-normal-auto-fill-function)
1366 ;;;_ = file-var-bug hack
1367 (defvar allout-v18/19-file-var-hack nil
1368 "Horrible hack used to prevent invalid multiple triggering of outline
1369 mode from prop-line file-var activation. Used by `allout-mode' function
1371 ;;;_ = allout-passphrase-verifier-string
1372 (defvar allout-passphrase-verifier-string nil
1373 "Setting used to test solicited encryption passphrases against the one
1374 already associated with a file.
1376 It consists of an encrypted random string useful only to verify that a
1377 passphrase entered by the user is effective for decryption. The passphrase
1378 itself is \*not* recorded in the file anywhere, and the encrypted contents
1379 are random binary characters to avoid exposing greater susceptibility to
1382 The verifier string is retained as an Emacs file variable, as well as in
1383 the emacs buffer state, if file variable adjustments are enabled. See
1384 `allout-enable-file-variable-adjustment' for details about that.")
1385 (make-variable-buffer-local 'allout-passphrase-verifier-string)
1387 (put 'allout-passphrase-verifier-string 'safe-local-variable 'stringp)
1388 ;;;_ = allout-passphrase-hint-string
1389 (defvar allout-passphrase-hint-string ""
1390 "Variable used to retain reminder string for file's encryption passphrase.
1392 See the description of `allout-passphrase-hint-handling' for details about how
1393 the reminder is deployed.
1395 The hint is retained as an Emacs file variable, as well as in the emacs buffer
1396 state, if file variable adjustments are enabled. See
1397 `allout-enable-file-variable-adjustment' for details about that.")
1398 (make-variable-buffer-local 'allout-passphrase-hint-string)
1399 (setq-default allout-passphrase-hint-string "")
1401 (put 'allout-passphrase-hint-string 'safe-local-variable 'stringp)
1402 ;;;_ = allout-after-save-decrypt
1403 (defvar allout-after-save-decrypt nil
1404 "Internal variable, is nil or has the value of two points:
1406 - the location of a topic to be decrypted after saving is done
1407 - where to situate the cursor after the decryption is performed
1409 This is used to decrypt the topic that was currently being edited, if it
1410 was encrypted automatically as part of a file write or autosave.")
1411 (make-variable-buffer-local 'allout-after-save-decrypt)
1412 ;;;_ = allout-encryption-plaintext-sanitization-regexps
1413 (defvar allout-encryption-plaintext-sanitization-regexps nil
1414 "List of regexps whose matches are removed from plaintext before encryption.
1416 This is for the sake of removing artifacts, like escapes, that are added on
1417 and not actually part of the original plaintext. The removal is done just
1418 prior to encryption.
1420 Entries must be symbols that are bound to the desired values.
1422 Each value can be a regexp or a list with a regexp followed by a
1423 substitution string. If it's just a regexp, all its matches are removed
1424 before the text is encrypted. If it's a regexp and a substitution, the
1425 substition is used against the regexp matches, a la `replace-match'.")
1426 (make-variable-buffer-local 'allout-encryption-text-removal-regexps)
1427 ;;;_ = allout-encryption-ciphertext-rejection-regexps
1428 (defvar allout-encryption-ciphertext-rejection-regexps nil
1429 "Variable for regexps matching plaintext to remove before encryption.
1431 This is for the sake of redoing encryption in cases where the ciphertext
1432 incidentally contains strings that would disrupt mode operation -
1433 for example, a line that happens to look like an allout-mode topic prefix.
1435 Entries must be symbols that are bound to the desired regexp values.
1437 The encryption will be retried up to
1438 `allout-encryption-ciphertext-rejection-limit' times, after which an error
1441 (make-variable-buffer-local 'allout-encryption-ciphertext-rejection-regexps)
1442 ;;;_ = allout-encryption-ciphertext-rejection-ceiling
1443 (defvar allout-encryption-ciphertext-rejection-ceiling 5
1444 "Limit on number of times encryption ciphertext is rejected.
1446 See `allout-encryption-ciphertext-rejection-regexps' for rejection reasons.")
1447 (make-variable-buffer-local 'allout-encryption-ciphertext-rejection-ceiling)
1448 ;;;_ > allout-mode-p ()
1449 ;; Must define this macro above any uses, or byte compilation will lack
1450 ;; proper def, if file isn't loaded - eg, during emacs build!
1451 (defmacro allout-mode-p ()
1452 "Return t if `allout-mode' is active in current buffer."
1454 ;;;_ > allout-write-file-hook-handler ()
1455 (defun allout-write-file-hook-handler ()
1456 "Implement `allout-encrypt-unencrypted-on-saves' policy for file writes."
1458 (if (or (not (allout-mode-p))
1459 (not (boundp 'allout-encrypt-unencrypted-on-saves))
1460 (not allout-encrypt-unencrypted-on-saves))
1462 (let ((except-mark (and (equal allout-encrypt-unencrypted-on-saves
1465 (if (save-excursion (goto-char (point-min))
1466 (allout-next-topic-pending-encryption except-mark))
1468 (message "auto-encrypting pending topics")
1470 (condition-case failure
1471 (setq allout-after-save-decrypt
1472 (allout-encrypt-decrypted except-mark))
1475 "allout-write-file-hook-handler suppressing error %s"
1480 ;;;_ > allout-auto-save-hook-handler ()
1481 (defun allout-auto-save-hook-handler ()
1482 "Implement `allout-encrypt-unencrypted-on-saves' policy for auto save."
1484 (if (and (allout-mode-p) allout-encrypt-unencrypted-on-saves)
1485 ;; Always implement 'except-current policy when enabled.
1486 (let ((allout-encrypt-unencrypted-on-saves 'except-current))
1487 (allout-write-file-hook-handler))))
1488 ;;;_ > allout-after-saves-handler ()
1489 (defun allout-after-saves-handler ()
1490 "Decrypt topic encrypted for save, if it's currently being edited.
1492 Ie, if it was pending encryption and contained the point in its body before
1495 We use values stored in `allout-after-save-decrypt' to locate the topic
1496 and the place for the cursor after the decryption is done."
1497 (if (not (and (allout-mode-p)
1498 (boundp 'allout-after-save-decrypt)
1499 allout-after-save-decrypt))
1501 (goto-char (car allout-after-save-decrypt))
1502 (let ((was-modified (buffer-modified-p)))
1503 (allout-toggle-subtree-encryption)
1504 (if (not was-modified)
1505 (set-buffer-modified-p nil)))
1506 (goto-char (cadr allout-after-save-decrypt))
1507 (setq allout-after-save-decrypt nil))
1510 ;;;_ #2 Mode activation
1511 ;;;_ = allout-explicitly-deactivated
1512 (defvar allout-explicitly-deactivated nil
1513 "If t, `allout-mode's last deactivation was deliberate.
1514 So `allout-post-command-business' should not reactivate it...")
1515 (make-variable-buffer-local 'allout-explicitly-deactivated)
1516 ;;;_ > allout-init (&optional mode)
1517 (defun allout-init (&optional mode)
1518 "Prime `allout-mode' to enable/disable auto-activation, wrt `allout-layout'.
1520 MODE is one of the following symbols:
1522 - nil \(or no argument) deactivate auto-activation/layout;
1523 - `activate', enable auto-activation only;
1524 - `ask', enable auto-activation, and enable auto-layout but with
1525 confirmation for layout operation solicited from user each time;
1526 - `report', just report and return the current auto-activation state;
1527 - anything else \(eg, t) for auto-activation and auto-layout, without
1528 any confirmation check.
1530 Use this function to setup your Emacs session for automatic activation
1531 of allout outline mode, contingent to the buffer-specific setting of
1532 the `allout-layout' variable. (See `allout-layout' and
1533 `allout-expose-topic' docstrings for more details on auto layout).
1535 `allout-init' works by setting up (or removing) the `allout-mode'
1536 find-file-hook, and giving `allout-auto-activation' a suitable
1539 To prime your Emacs session for full auto-outline operation, include
1540 the following two lines in your Emacs init file:
1550 (concat "Select outline auto setup mode "
1551 "(empty for report, ? for options) ")
1552 '(("nil")("full")("activate")("deactivate")
1553 ("ask") ("report") (""))
1556 (if (string= mode "")
1558 (setq mode (intern-soft mode)))))
1560 ;; convenience aliases, for consistent ref to respective vars:
1561 ((hook 'allout-find-file-hook)
1562 (find-file-hook-var-name (if (boundp 'find-file-hook)
1565 (curr-mode 'allout-auto-activation))
1568 (set find-file-hook-var-name
1569 (delq hook (symbol-value find-file-hook-var-name)))
1571 (message "Allout outline mode auto-activation inhibited.")))
1573 (if (not (memq hook (symbol-value find-file-hook-var-name)))
1575 ;; Just punt and use the reports from each of the modes:
1576 (allout-init (symbol-value curr-mode))))
1577 (t (add-hook find-file-hook-var-name hook)
1578 (set curr-mode ; `set', not `setq'!
1579 (cond ((eq mode 'activate)
1581 "Outline mode auto-activation enabled.")
1584 ;; Return the current mode setting:
1588 (concat "Outline mode auto-activation and "
1589 "-layout \(upon confirmation) enabled."))
1592 "Outline mode auto-activation and -layout enabled.")
1594 ;;;_ > allout-setup-menubar ()
1595 (defun allout-setup-menubar ()
1596 "Populate the current buffer's menubar with `allout-mode' stuff."
1597 (let ((menus (list allout-mode-exposure-menu
1598 allout-mode-editing-menu
1599 allout-mode-navigation-menu
1600 allout-mode-misc-menu))
1603 (setq cur (car menus)
1605 (easy-menu-add cur))))
1606 ;;;_ > allout-overlay-preparations
1607 (defun allout-overlay-preparations ()
1608 "Set the properties of the allout invisible-text overlay and others."
1609 (setplist 'allout-exposure-category nil)
1610 (put 'allout-exposure-category 'invisible 'allout)
1611 (put 'allout-exposure-category 'evaporate t)
1612 ;; XXX We use isearch-open-invisible *and* isearch-mode-end-hook. The
1613 ;; latter would be sufficient, but it seems that a separate behavior -
1614 ;; the _transient_ opening of invisible text during isearch - is keyed to
1615 ;; presence of the isearch-open-invisible property - even though this
1616 ;; property controls the isearch _arrival_ behavior. This is the case at
1617 ;; least in emacs 21, 22.0, and xemacs 21.4.
1618 (put 'allout-exposure-category 'isearch-open-invisible
1619 'allout-isearch-end-handler)
1620 (if (featurep 'xemacs)
1621 (put 'allout-exposure-category 'start-open t)
1622 (put 'allout-exposure-category 'insert-in-front-hooks
1623 '(allout-overlay-insert-in-front-handler)))
1624 (put 'allout-exposure-category 'modification-hooks
1625 '(allout-overlay-interior-modification-handler)))
1626 ;;;_ > allout-mode (&optional toggle)
1629 (defun allout-mode (&optional toggle)
1631 "Toggle minor mode for controlling exposure and editing of text outlines.
1634 Optional arg forces mode to re-initialize iff arg is positive num or
1635 symbol. Allout outline mode always runs as a minor mode.
1637 Allout outline mode provides extensive outline oriented formatting and
1638 manipulation. It enables structural editing of outlines, as well as
1639 navigation and exposure. It also is specifically aimed at
1640 accommodating syntax-sensitive text like programming languages. \(For
1641 an example, see the allout code itself, which is organized as an allout
1644 In addition to outline navigation and exposure, allout includes:
1646 - topic-oriented repositioning, promotion/demotion, cut, and paste
1647 - integral outline exposure-layout
1648 - incremental search with dynamic exposure and reconcealment of hidden text
1649 - automatic topic-number maintenance
1650 - easy topic encryption and decryption
1651 - \"Hot-spot\" operation, for single-keystroke maneuvering and
1652 exposure control. \(See the allout-mode docstring.)
1654 and many other features.
1656 Below is a description of the bindings, and then explanation of
1657 special `allout-mode' features and terminology. See also the outline
1658 menubar additions for quick reference to many of the features, and see
1659 the docstring of the function `allout-init' for instructions on
1660 priming your emacs session for automatic activation of `allout-mode'.
1663 The bindings are dictated by the `allout-keybindings-list' and
1664 `allout-command-prefix' variables.
1666 Navigation: Exposure Control:
1667 ---------- ----------------
1668 \\[allout-next-visible-heading] allout-next-visible-heading | \\[allout-hide-current-subtree] allout-hide-current-subtree
1669 \\[allout-previous-visible-heading] allout-previous-visible-heading | \\[allout-show-children] allout-show-children
1670 \\[allout-up-current-level] allout-up-current-level | \\[allout-show-current-subtree] allout-show-current-subtree
1671 \\[allout-forward-current-level] allout-forward-current-level | \\[allout-show-current-entry] allout-show-current-entry
1672 \\[allout-backward-current-level] allout-backward-current-level | \\[allout-show-all] allout-show-all
1673 \\[allout-end-of-entry] allout-end-of-entry
1674 \\[allout-beginning-of-current-entry] allout-beginning-of-current-entry, alternately, goes to hot-spot
1676 Topic Header Production:
1677 -----------------------
1678 \\[allout-open-sibtopic] allout-open-sibtopic Create a new sibling after current topic.
1679 \\[allout-open-subtopic] allout-open-subtopic ... an offspring of current topic.
1680 \\[allout-open-supertopic] allout-open-supertopic ... a sibling of the current topic's parent.
1682 Topic Level and Prefix Adjustment:
1683 ---------------------------------
1684 \\[allout-shift-in] allout-shift-in Shift current topic and all offspring deeper.
1685 \\[allout-shift-out] allout-shift-out ... less deep.
1686 \\[allout-rebullet-current-heading] allout-rebullet-current-heading Prompt for alternate bullet for
1688 \\[allout-rebullet-topic] allout-rebullet-topic Reconcile bullets of topic and its offspring
1689 - distinctive bullets are not changed, others
1690 alternated according to nesting depth.
1691 \\[allout-number-siblings] allout-number-siblings Number bullets of topic and siblings - the
1692 offspring are not affected. With repeat
1693 count, revoke numbering.
1695 Topic-oriented Killing and Yanking:
1696 ----------------------------------
1697 \\[allout-kill-topic] allout-kill-topic Kill current topic, including offspring.
1698 \\[allout-copy-topic-as-kill] allout-copy-topic-as-kill Copy current topic, including offspring.
1699 \\[allout-kill-line] allout-kill-line kill-line, attending to outline structure.
1700 \\[allout-copy-line-as-kill] allout-copy-line-as-kill Copy line but don't delete it.
1701 \\[allout-yank] allout-yank Yank, adjusting depth of yanked topic to
1702 depth of heading if yanking into bare topic
1703 heading (ie, prefix sans text).
1704 \\[allout-yank-pop] allout-yank-pop Is to allout-yank as yank-pop is to yank
1706 Topic-oriented Encryption:
1707 -------------------------
1708 \\[allout-toggle-current-subtree-encryption] allout-toggle-current-subtree-encryption Encrypt/Decrypt topic content
1712 M-x outlineify-sticky Activate outline mode for current buffer,
1713 and establish a default file-var setting
1714 for `allout-layout'.
1715 \\[allout-mark-topic] allout-mark-topic
1716 \\[allout-copy-exposed-to-buffer] allout-copy-exposed-to-buffer
1717 Duplicate outline, sans concealed text, to
1718 buffer with name derived from derived from that
1719 of current buffer - \"*BUFFERNAME exposed*\".
1720 \\[allout-flatten-exposed-to-buffer] allout-flatten-exposed-to-buffer
1721 Like above 'copy-exposed', but convert topic
1722 prefixes to section.subsection... numeric
1724 \\[eval-expression] (allout-init t) Setup Emacs session for outline mode
1729 Outline mode supports gpg encryption of topics, with support for
1730 symmetric and key-pair modes, passphrase timeout, passphrase
1731 consistency checking, user-provided hinting for symmetric key
1732 mode, and auto-encryption of topics pending encryption on save.
1733 \(Topics pending encryption are, by default, automatically
1734 encrypted during file saves; if you're editing the contents of
1735 such a topic, it is automatically decrypted for continued
1736 editing.) The aim is reliable topic privacy while preventing
1737 accidents like neglected encryption before saves, forgetting
1738 which passphrase was used, and other practical pitfalls.
1740 See `allout-toggle-current-subtree-encryption' function docstring and
1741 `allout-encrypt-unencrypted-on-saves' customization variable for details.
1745 Hot-spot operation provides a means for easy, single-keystroke outline
1746 navigation and exposure control.
1748 When the text cursor is positioned directly on the bullet character of
1749 a topic, regular characters (a to z) invoke the commands of the
1750 corresponding allout-mode keymap control chars. For example, \"f\"
1751 would invoke the command typically bound to \"C-c<space>C-f\"
1752 \(\\[allout-forward-current-level] `allout-forward-current-level').
1754 Thus, by positioning the cursor on a topic bullet, you can
1755 execute the outline navigation and manipulation commands with a
1756 single keystroke. Regular navigation keys (eg, \\[forward-char], \\[next-line]) never get
1757 this special translation, so you can use them to get out of the
1758 hot-spot and back to normal operation.
1760 Note that the command `allout-beginning-of-current-entry' \(\\[allout-beginning-of-current-entry]\)
1761 will move to the hot-spot when the cursor is already located at the
1762 beginning of the current entry, so you usually can hit \\[allout-beginning-of-current-entry]
1763 twice in a row to get to the hot-spot.
1767 Topic hierarchy constituents - TOPICS and SUBTOPICS:
1769 TOPIC: A basic, coherent component of an Emacs outline. It can
1770 contain and be contained by other topics.
1772 The visible topic most immediately containing the cursor.
1773 DEPTH: The degree of nesting of a topic; it increases with
1774 containment. Also called the:
1775 LEVEL: The same as DEPTH.
1778 The topics that contain a topic.
1779 PARENT: A topic's immediate ancestor. It has a depth one less than
1782 The topics contained by a topic;
1784 An immediate offspring of a topic;
1786 The immediate offspring of a topic.
1788 Topics having the same parent and depth.
1790 Topic text constituents:
1792 HEADER: The first line of a topic, include the topic PREFIX and header
1794 PREFIX: The leading text of a topic which distinguishes it from normal
1795 text. It has a strict form, which consists of a prefix-lead
1796 string, padding, and a bullet. The bullet may be followed by a
1797 number, indicating the ordinal number of the topic among its
1798 siblings, a space, and then the header text.
1800 The relative length of the PREFIX determines the nesting depth
1803 The string at the beginning of a topic prefix, normally a `.'.
1804 It can be customized by changing the setting of
1805 `allout-header-prefix' and then reinitializing `allout-mode'.
1807 By setting the prefix-lead to the comment-string of a
1808 programming language, you can embed outline structuring in
1809 program code without interfering with the language processing
1810 of that code. See `allout-use-mode-specific-leader'
1811 docstring for more detail.
1813 Spaces or asterisks which separate the prefix-lead and the
1814 bullet, determining the depth of the topic.
1815 BULLET: A character at the end of the topic prefix, it must be one of
1816 the characters listed on `allout-plain-bullets-string' or
1817 `allout-distinctive-bullets-string'. (See the documentation
1818 for these variables for more details.) The default choice of
1819 bullet when generating topics varies in a cycle with the depth of
1821 ENTRY: The text contained in a topic before any offspring.
1822 BODY: Same as ENTRY.
1826 The state of a topic which determines the on-screen visibility
1827 of its offspring and contained text.
1829 Topics and entry text whose display is inhibited. Contiguous
1830 units of concealed text is represented by `...' ellipses.
1832 Concealed topics are effectively collapsed within an ancestor.
1833 CLOSED: A topic whose immediate offspring and body-text is concealed.
1834 OPEN: A topic that is not closed, though its offspring or body may be."
1838 (let* ((active (and (not (equal major-mode 'outline))
1840 ; Massage universal-arg `toggle' val:
1842 (or (and (listp toggle)(car toggle))
1844 ; Activation specifically demanded?
1845 (explicit-activation (and toggle
1846 (or (symbolp toggle)
1847 (and (wholenump toggle)
1848 (not (zerop toggle))))))
1849 ;; allout-mode already called once during this complex command?
1850 (same-complex-command (eq allout-v18/19-file-var-hack
1851 (car command-history)))
1852 (write-file-hook-var-name (cond ((boundp 'write-file-functions)
1853 'write-file-functions)
1854 ((boundp 'write-file-hooks)
1856 (t 'local-write-file-hooks)))
1860 ; See comments below re v19.18,.19 bug.
1861 (setq allout-v18/19-file-var-hack (car command-history))
1865 ;; Provision for v19.18, 19.19 bug -
1866 ;; Emacs v 19.18, 19.19 file-var code invokes prop-line-designated
1867 ;; modes twice when file is visited. We have to avoid toggling mode
1868 ;; off on second invocation, so we detect it as best we can, and
1870 ((and same-complex-command ; Still in same complex command
1871 ; as last time `allout-mode' invoked.
1872 active ; Already activated.
1873 (not explicit-activation) ; Prop-line file-vars don't have args.
1874 (string-match "^19.1[89]" ; Bug only known to be in v19.18 and
1875 emacs-version)); 19.19.
1879 ((and (not explicit-activation)
1881 ; Activation not explicitly
1882 ; requested, and either in
1883 ; active state or *de*activation
1884 ; specifically requested:
1885 (setq allout-explicitly-deactivated t)
1887 (allout-do-resumptions)
1889 (remove-from-invisibility-spec '(allout . t))
1890 (remove-hook 'pre-command-hook 'allout-pre-command-business t)
1891 (remove-hook 'post-command-hook 'allout-post-command-business t)
1892 (remove-hook 'before-change-functions 'allout-before-change-handler t)
1893 (remove-hook 'isearch-mode-end-hook 'allout-isearch-end-handler t)
1894 (remove-hook write-file-hook-var-name 'allout-write-file-hook-handler t)
1895 (remove-hook 'auto-save-hook 'allout-auto-save-hook-handler t)
1897 (remove-overlays (point-min) (point-max)
1898 'category 'allout-exposure-category)
1900 (setq allout-mode nil)
1901 (run-hooks 'allout-mode-deactivate-hook))
1905 (setq allout-explicitly-deactivated nil)
1906 (if allout-old-style-prefixes
1907 ;; Inhibit all the fancy formatting:
1908 (allout-add-resumptions '(allout-primary-bullet "*")))
1910 (allout-overlay-preparations) ; Doesn't hurt to redo this.
1912 (allout-infer-header-lead-and-primary-bullet)
1913 (allout-infer-body-reindent)
1916 (allout-add-resumptions
1917 '(allout-encryption-ciphertext-rejection-regexps
1918 allout-line-boundary-regexp
1920 '(allout-encryption-ciphertext-rejection-regexps
1924 ;; Produce map from current version of allout-keybindings-list:
1925 (setq allout-mode-map
1926 (produce-allout-mode-map allout-keybindings-list))
1927 (substitute-key-definition 'beginning-of-line
1928 'allout-beginning-of-line
1929 allout-mode-map global-map)
1930 (substitute-key-definition 'move-beginning-of-line
1931 'allout-beginning-of-line
1932 allout-mode-map global-map)
1933 (substitute-key-definition 'end-of-line
1935 allout-mode-map global-map)
1936 (substitute-key-definition 'move-end-of-line
1938 allout-mode-map global-map)
1939 (produce-allout-mode-menubar-entries)
1940 (fset 'allout-mode-map allout-mode-map)
1942 ;; Include on minor-mode-map-alist, if not already there:
1943 (if (not (member '(allout-mode . allout-mode-map)
1944 minor-mode-map-alist))
1945 (setq minor-mode-map-alist
1946 (cons '(allout-mode . allout-mode-map)
1947 minor-mode-map-alist)))
1949 (add-to-invisibility-spec '(allout . t))
1950 (allout-add-resumptions '(line-move-ignore-invisible t))
1951 (add-hook 'pre-command-hook 'allout-pre-command-business nil t)
1952 (add-hook 'post-command-hook 'allout-post-command-business nil t)
1953 (add-hook 'before-change-functions 'allout-before-change-handler
1955 (add-hook 'isearch-mode-end-hook 'allout-isearch-end-handler nil t)
1956 (add-hook write-file-hook-var-name 'allout-write-file-hook-handler
1958 (add-hook 'auto-save-hook 'allout-auto-save-hook-handler
1961 ;; Stash auto-fill settings and adjust so custom allout auto-fill
1962 ;; func will be used if auto-fill is active or activated. (The
1963 ;; custom func respects topic headline, maintains hanging-indents,
1965 (if (and auto-fill-function (not allout-inhibit-auto-fill))
1966 ;; allout-auto-fill will use the stashed values and so forth.
1967 (allout-add-resumptions '(auto-fill-function allout-auto-fill)))
1968 (allout-add-resumptions (list 'allout-former-auto-filler
1970 ;; Register allout-auto-fill to be used if
1971 ;; filling is active:
1972 (list 'allout-outside-normal-auto-fill-function
1973 normal-auto-fill-function)
1974 '(normal-auto-fill-function allout-auto-fill)
1975 ;; Paragraphs are broken by topic headlines.
1976 (list 'paragraph-start
1977 (concat paragraph-start "\\|^\\("
1978 allout-regexp "\\)"))
1979 (list 'paragraph-separate
1980 (concat paragraph-separate "\\|^\\("
1981 allout-regexp "\\)")))
1982 (or (assq 'allout-mode minor-mode-alist)
1983 (setq minor-mode-alist
1984 (cons '(allout-mode " Allout") minor-mode-alist)))
1986 (allout-setup-menubar)
1991 (setq allout-mode t)
1992 (run-hooks 'allout-mode-hook))
1996 (allout-infer-body-reindent))
1997 ) ;; end of activation-mode cases.
1999 ;; Do auto layout if warranted:
2000 (let ((use-layout (if (listp allout-layout)
2002 allout-default-layout)))
2004 allout-auto-activation
2006 (and (not (eq allout-auto-activation 'activate))
2007 (if (eq allout-auto-activation 'ask)
2008 (if (y-or-n-p (format "Expose %s with layout '%s'? "
2012 (message "Skipped %s layout." (buffer-name))
2016 (message "Adjusting '%s' exposure..." (buffer-name))
2018 (allout-this-or-next-heading)
2021 (apply 'allout-expose-topic (list use-layout))
2022 (message "Adjusting '%s' exposure... done." (buffer-name)))
2023 ;; Problem applying exposure - notify user, but don't
2024 ;; interrupt, eg, file visit:
2025 (error (message "%s" (car (cdr err)))
2030 ;;;_ > allout-minor-mode
2031 (defalias 'allout-minor-mode 'allout-mode)
2033 ;;;_ - Position Assessment
2034 ;;;_ > allout-hidden-p (&optional pos)
2035 (defsubst allout-hidden-p (&optional pos)
2036 "Non-nil if the character after point is invisible."
2037 (eq (get-char-property (or pos (point)) 'invisible) 'allout))
2039 ;;;_ > allout-overlay-insert-in-front-handler (ol after beg end
2040 ;;; &optional prelen)
2041 (defun allout-overlay-insert-in-front-handler (ol after beg end
2043 "Shift the overlay so stuff inserted in front of it are excluded."
2045 (move-overlay ol (1+ beg) (overlay-end ol))))
2046 ;;;_ > allout-overlay-interior-modification-handler (ol after beg end
2047 ;;; &optional prelen)
2048 (defun allout-overlay-interior-modification-handler (ol after beg end
2050 "Get confirmation before making arbitrary changes to invisible text.
2052 We expose the invisible text and ask for confirmation. Refusal or
2053 keyboard-quit abandons the changes, with keyboard-quit additionally
2054 reclosing the opened text.
2056 No confirmation is necessary when inhibit-read-only is set - eg, allout
2057 internal functions use this feature cohesively bunch changes."
2059 (when (and (not inhibit-read-only) (not after))
2060 (let ((start (point))
2061 (ol-start (overlay-start ol))
2062 (ol-end (overlay-end ol))
2065 (while (< (point) end)
2066 (when (allout-hidden-p)
2067 (allout-show-to-offshoot)
2068 (if (allout-hidden-p)
2069 (save-excursion (forward-char 1)
2070 (allout-show-to-offshoot)))
2072 (setq first (point))))
2073 (goto-char (if (featurep 'xemacs)
2074 (next-property-change (1+ (point)) nil end)
2075 (next-char-property-change (1+ (point)) end))))
2081 (substitute-command-keys
2082 (concat "Modify concealed text? (\"no\" just aborts,"
2083 " \\[keyboard-quit] also reconceals) "))))
2084 (progn (goto-char start)
2085 (error "Concealed-text change refused.")))
2086 (quit (allout-flag-region ol-start ol-end nil)
2087 (allout-flag-region ol-start ol-end t)
2088 (error "Concealed-text change abandoned, text reconcealed."))))
2089 (goto-char start))))
2090 ;;;_ > allout-before-change-handler (beg end)
2091 (defun allout-before-change-handler (beg end)
2092 "Protect against changes to invisible text.
2094 See allout-overlay-interior-modification-handler for details."
2096 (if (and (allout-mode-p) undo-in-progress (allout-hidden-p))
2097 (allout-show-to-offshoot))
2099 ;; allout-overlay-interior-modification-handler on an overlay handles
2100 ;; this in other emacs, via `allout-exposure-category's 'modification-hooks.
2101 (when (and (featurep 'xemacs) (allout-mode-p))
2102 ;; process all of the pending overlays:
2105 (let ((overlay (allout-get-invisibility-overlay)))
2106 (allout-overlay-interior-modification-handler
2107 overlay nil beg end nil)))))
2108 ;;;_ > allout-isearch-end-handler (&optional overlay)
2109 (defun allout-isearch-end-handler (&optional overlay)
2110 "Reconcile allout outline exposure on arriving in hidden text after isearch.
2112 Optional OVERLAY parameter is for when this function is used by
2113 `isearch-open-invisible' overlay property. It is otherwise unused, so this
2114 function can also be used as an `isearch-mode-end-hook'."
2116 (if (and (allout-mode-p) (allout-hidden-p))
2117 (allout-show-to-offshoot)))
2119 ;;;_ #3 Internal Position State-Tracking - "allout-recent-*" funcs
2120 ;;; All the basic outline functions that directly do string matches to
2121 ;;; evaluate heading prefix location set the variables
2122 ;;; `allout-recent-prefix-beginning' and `allout-recent-prefix-end'
2123 ;;; when successful. Functions starting with `allout-recent-' all
2124 ;;; use this state, providing the means to avoid redundant searches
2125 ;;; for just-established data. This optimization can provide
2126 ;;; significant speed improvement, but it must be employed carefully.
2127 ;;;_ = allout-recent-prefix-beginning
2128 (defvar allout-recent-prefix-beginning 0
2129 "Buffer point of the start of the last topic prefix encountered.")
2130 (make-variable-buffer-local 'allout-recent-prefix-beginning)
2131 ;;;_ = allout-recent-prefix-end
2132 (defvar allout-recent-prefix-end 0
2133 "Buffer point of the end of the last topic prefix encountered.")
2134 (make-variable-buffer-local 'allout-recent-prefix-end)
2135 ;;;_ = allout-recent-depth
2136 (defvar allout-recent-depth 0
2137 "Depth of the last topic prefix encountered.")
2138 (make-variable-buffer-local 'allout-recent-depth)
2139 ;;;_ = allout-recent-end-of-subtree
2140 (defvar allout-recent-end-of-subtree 0
2141 "Buffer point last returned by `allout-end-of-current-subtree'.")
2142 (make-variable-buffer-local 'allout-recent-end-of-subtree)
2143 ;;;_ > allout-prefix-data ()
2144 (defsubst allout-prefix-data ()
2145 "Register allout-prefix state data.
2147 For reference by `allout-recent' funcs. Returns BEGINNING."
2148 (setq allout-recent-prefix-end (or (match-end 1) (match-end 2))
2149 allout-recent-prefix-beginning (or (match-beginning 1)
2150 (match-beginning 2))
2151 allout-recent-depth (max 1 (- allout-recent-prefix-end
2152 allout-recent-prefix-beginning
2153 allout-header-subtraction)))
2154 allout-recent-prefix-beginning)
2155 ;;;_ > nullify-allout-prefix-data ()
2156 (defsubst nullify-allout-prefix-data ()
2157 "Mark allout prefix data as being uninformative."
2158 (setq allout-recent-prefix-end (point)
2159 allout-recent-prefix-beginning (point)
2160 allout-recent-depth 0)
2161 allout-recent-prefix-beginning)
2162 ;;;_ > allout-recent-depth ()
2163 (defsubst allout-recent-depth ()
2164 "Return depth of last heading encountered by an outline maneuvering function.
2166 All outline functions which directly do string matches to assess
2167 headings set the variables `allout-recent-prefix-beginning' and
2168 `allout-recent-prefix-end' if successful. This function uses those settings
2169 to return the current depth."
2171 allout-recent-depth)
2172 ;;;_ > allout-recent-prefix ()
2173 (defsubst allout-recent-prefix ()
2174 "Like `allout-recent-depth', but returns text of last encountered prefix.
2176 All outline functions which directly do string matches to assess
2177 headings set the variables `allout-recent-prefix-beginning' and
2178 `allout-recent-prefix-end' if successful. This function uses those settings
2179 to return the current prefix."
2180 (buffer-substring-no-properties allout-recent-prefix-beginning
2181 allout-recent-prefix-end))
2182 ;;;_ > allout-recent-bullet ()
2183 (defmacro allout-recent-bullet ()
2184 "Like allout-recent-prefix, but returns bullet of last encountered prefix.
2186 All outline functions which directly do string matches to assess
2187 headings set the variables `allout-recent-prefix-beginning' and
2188 `allout-recent-prefix-end' if successful. This function uses those settings
2189 to return the current depth of the most recently matched topic."
2190 '(buffer-substring-no-properties (1- allout-recent-prefix-end)
2191 allout-recent-prefix-end))
2195 ;;;_ - Position Assessment
2196 ;;;_ : Location Predicates
2197 ;;;_ > allout-on-current-heading-p ()
2198 (defun allout-on-current-heading-p ()
2199 "Return non-nil if point is on current visible topics' header line.
2201 Actually, returns prefix beginning point."
2203 (allout-beginning-of-current-line)
2204 (and (looking-at allout-regexp)
2205 (allout-prefix-data)
2206 (or (> allout-recent-depth allout-doublecheck-at-and-shallower)
2207 (not (allout-aberrant-container-p))))))
2208 ;;;_ > allout-on-heading-p ()
2209 (defalias 'allout-on-heading-p 'allout-on-current-heading-p)
2210 ;;;_ > allout-e-o-prefix-p ()
2211 (defun allout-e-o-prefix-p ()
2212 "True if point is located where current topic prefix ends, heading begins."
2213 (and (save-excursion (let ((inhibit-field-text-motion t))
2214 (beginning-of-line))
2215 (looking-at allout-regexp))
2216 (= (point)(save-excursion (allout-end-of-prefix)(point)))))
2217 ;;;_ > allout-aberrant-container-p ()
2218 (defun allout-aberrant-container-p ()
2219 "True if topic, or next sibling with children, contains them discontinuously.
2221 Discontinuous means an immediate offspring that is nested more
2222 than one level deeper than the topic.
2224 If topic has no offspring, then the next sibling with offspring will
2225 determine whether or not this one is determined to be aberrant.
2227 If true, then the allout-recent-* settings are calibrated on the
2228 offspring that qaulifies it as aberrant, ie with depth that
2229 exceeds the topic by more than one."
2231 ;; This is most clearly understood when considering standard-prefix-leader
2232 ;; low-level topics, which can all too easily match text not intended as
2233 ;; headers. For example, any line with a leading '.' or '*' and lacking a
2234 ;; following bullet qualifies without this protection. (A sequence of
2235 ;; them can occur naturally, eg a typical textual bullet list.) We
2236 ;; disqualify such low-level sequences when they are followed by a
2237 ;; discontinuously contained child, inferring that the sequences are not
2238 ;; actually connected with their prospective context.
2240 (let ((depth (allout-depth))
2241 (start-point (point))
2244 (while (and (not done)
2245 (re-search-forward allout-line-boundary-regexp nil 0))
2246 (allout-prefix-data)
2247 (goto-char allout-recent-prefix-beginning)
2249 ;; sibling - continue:
2250 ((eq allout-recent-depth depth))
2251 ;; first offspring is excessive - aberrant:
2252 ((> allout-recent-depth (1+ depth))
2253 (setq done t aberrant t))
2254 ;; next non-sibling is lower-depth - not aberrant:
2255 (t (setq done t)))))
2258 (goto-char start-point)
2259 ;; recalibrate allout-recent-*
2262 ;;;_ : Location attributes
2263 ;;;_ > allout-depth ()
2264 (defun allout-depth ()
2265 "Return depth of topic most immediately containing point.
2267 Return zero if point is not within any topic.
2269 Like `allout-current-depth', but respects hidden as well as visible topics."
2271 (let ((start-point (point)))
2272 (if (and (allout-goto-prefix)
2273 (not (< start-point (point))))
2276 ;; Oops, no prefix, nullify it:
2277 (nullify-allout-prefix-data)
2278 ;; ... and return 0:
2280 ;;;_ > allout-current-depth ()
2281 (defun allout-current-depth ()
2282 "Return depth of visible topic most immediately containing point.
2284 Return zero if point is not within any topic."
2286 (if (allout-back-to-current-heading)
2288 (- allout-recent-prefix-end
2289 allout-recent-prefix-beginning
2290 allout-header-subtraction))
2292 ;;;_ > allout-get-current-prefix ()
2293 (defun allout-get-current-prefix ()
2294 "Topic prefix of the current topic."
2296 (if (allout-goto-prefix)
2297 (allout-recent-prefix))))
2298 ;;;_ > allout-get-bullet ()
2299 (defun allout-get-bullet ()
2300 "Return bullet of containing topic (visible or not)."
2302 (and (allout-goto-prefix)
2303 (allout-recent-bullet))))
2304 ;;;_ > allout-current-bullet ()
2305 (defun allout-current-bullet ()
2306 "Return bullet of current (visible) topic heading, or none if none found."
2309 (allout-back-to-current-heading)
2310 (buffer-substring-no-properties (- allout-recent-prefix-end 1)
2311 allout-recent-prefix-end))
2312 ;; Quick and dirty provision, ostensibly for missing bullet:
2313 (args-out-of-range nil))
2315 ;;;_ > allout-get-prefix-bullet (prefix)
2316 (defun allout-get-prefix-bullet (prefix)
2317 "Return the bullet of the header prefix string PREFIX."
2318 ;; Doesn't make sense if we're old-style prefixes, but this just
2319 ;; oughtn't be called then, so forget about it...
2320 (if (string-match allout-regexp prefix)
2321 (substring prefix (1- (match-end 2)) (match-end 2))))
2322 ;;;_ > allout-sibling-index (&optional depth)
2323 (defun allout-sibling-index (&optional depth)
2324 "Item number of this prospective topic among its siblings.
2326 If optional arg DEPTH is greater than current depth, then we're
2327 opening a new level, and return 0.
2329 If less than this depth, ascend to that depth and count..."
2332 (cond ((and depth (<= depth 0) 0))
2333 ((or (null depth) (= depth (allout-depth)))
2335 (while (allout-previous-sibling allout-recent-depth nil)
2336 (setq index (1+ index)))
2338 ((< depth allout-recent-depth)
2339 (allout-ascend-to-depth depth)
2340 (allout-sibling-index))
2342 ;;;_ > allout-topic-flat-index ()
2343 (defun allout-topic-flat-index ()
2344 "Return a list indicating point's numeric section.subsect.subsubsect...
2345 Outermost is first."
2346 (let* ((depth (allout-depth))
2347 (next-index (allout-sibling-index depth))
2349 (while (> next-index 0)
2350 (setq rev-sibls (cons next-index rev-sibls))
2351 (setq depth (1- depth))
2352 (setq next-index (allout-sibling-index depth)))
2356 ;;;_ - Navigation routines
2357 ;;;_ > allout-beginning-of-current-line ()
2358 (defun allout-beginning-of-current-line ()
2359 "Like beginning of line, but to visible text."
2361 ;; This combination of move-beginning-of-line and beginning-of-line is
2362 ;; deliberate, but the (beginning-of-line) may now be superfluous.
2363 (let ((inhibit-field-text-motion t))
2364 (move-beginning-of-line 1)
2366 (while (and (not (bobp)) (or (not (bolp)) (allout-hidden-p)))
2368 (if (or (allout-hidden-p) (not (bolp)))
2369 (forward-char -1)))))
2370 ;;;_ > allout-end-of-current-line ()
2371 (defun allout-end-of-current-line ()
2372 "Move to the end of line, past concealed text if any."
2373 ;; XXX This is for symmetry with `allout-beginning-of-current-line' -
2374 ;; `move-end-of-line' doesn't suffer the same problem as
2375 ;; `move-beginning-of-line'.
2376 (let ((inhibit-field-text-motion t))
2378 (while (allout-hidden-p)
2380 (if (allout-hidden-p) (forward-char 1)))))
2381 ;;;_ > allout-beginning-of-line ()
2382 (defun allout-beginning-of-line ()
2383 "Beginning-of-line with `allout-beginning-of-line-cycles' behavior, if set."
2387 (if (or (not allout-beginning-of-line-cycles)
2388 (not (equal last-command this-command)))
2389 (move-beginning-of-line 1)
2391 (let ((beginning-of-body
2393 (while (and (<= allout-recent-depth
2394 allout-doublecheck-at-and-shallower)
2395 (allout-aberrant-container-p)
2396 (allout-previous-visible-heading 1)))
2397 (allout-beginning-of-current-entry)
2399 (cond ((= (current-column) 0)
2400 (goto-char beginning-of-body))
2401 ((< (point) beginning-of-body)
2402 (allout-beginning-of-current-line))
2403 ((= (point) beginning-of-body)
2404 (goto-char (allout-current-bullet-pos)))
2405 (t (allout-beginning-of-current-line)
2406 (if (< (point) beginning-of-body)
2407 ;; we were on the headline after its start:
2408 (goto-char beginning-of-body)))))))
2409 ;;;_ > allout-end-of-line ()
2410 (defun allout-end-of-line ()
2411 "End-of-line with `allout-end-of-line-cycles' behavior, if set."
2415 (if (or (not allout-end-of-line-cycles)
2416 (not (equal last-command this-command)))
2417 (allout-end-of-current-line)
2418 (let ((end-of-entry (save-excursion
2419 (allout-end-of-entry)
2422 (allout-end-of-current-line))
2423 ((or (allout-hidden-p) (save-excursion
2426 (allout-back-to-current-heading)
2427 (allout-show-current-entry)
2428 (allout-show-children)
2429 (allout-end-of-entry))
2430 ((>= (point) end-of-entry)
2431 (allout-back-to-current-heading)
2432 (allout-end-of-current-line))
2433 (t (allout-end-of-entry))))))
2434 ;;;_ > allout-next-heading ()
2435 (defsubst allout-next-heading ()
2436 "Move to the heading for the topic \(possibly invisible) after this one.
2438 Returns the location of the heading, or nil if none found.
2440 We skip anomolous low-level topics, a la `allout-aberrant-container-p'."
2441 (if (looking-at allout-regexp)
2444 (when (re-search-forward allout-line-boundary-regexp nil 0)
2445 (allout-prefix-data)
2446 (and (<= allout-recent-depth allout-doublecheck-at-and-shallower)
2447 ;; this will set allout-recent-* on the first non-aberrant topic,
2448 ;; whether it's the current one or one that disqualifies it:
2449 (allout-aberrant-container-p))
2450 (goto-char allout-recent-prefix-beginning)))
2451 ;;;_ > allout-this-or-next-heading
2452 (defun allout-this-or-next-heading ()
2453 "Position cursor on current or next heading."
2454 ;; A throwaway non-macro that is defined after allout-next-heading
2455 ;; and usable by allout-mode.
2456 (if (not (allout-goto-prefix-doublechecked)) (allout-next-heading)))
2457 ;;;_ > allout-previous-heading ()
2458 (defun allout-previous-heading ()
2459 "Move to the prior \(possibly invisible) heading line.
2461 Return the location of the beginning of the heading, or nil if not found.
2463 We skip anomolous low-level topics, a la `allout-aberrant-container-p'."
2467 ;; allout-goto-prefix-doublechecked calls us, so we can't use it here.
2468 (let ((start-point (point)))
2469 (allout-goto-prefix)
2470 (when (or (re-search-backward allout-line-boundary-regexp nil 0)
2471 (looking-at allout-bob-regexp))
2472 (goto-char (allout-prefix-data))
2473 (if (and (<= allout-recent-depth allout-doublecheck-at-and-shallower)
2474 (allout-aberrant-container-p))
2475 (or (allout-previous-heading)
2476 (and (goto-char start-point)
2477 ;; recalibrate allout-recent-*:
2481 ;;;_ > allout-get-invisibility-overlay ()
2482 (defun allout-get-invisibility-overlay ()
2483 "Return the overlay at point that dictates allout invisibility."
2484 (let ((overlays (overlays-at (point)))
2486 (while (and overlays (not got))
2487 (if (equal (overlay-get (car overlays) 'invisible) 'allout)
2488 (setq got (car overlays))
2491 ;;;_ > allout-back-to-visible-text ()
2492 (defun allout-back-to-visible-text ()
2493 "Move to most recent prior character that is visible, and return point."
2494 (if (allout-hidden-p)
2495 (goto-char (overlay-start (allout-get-invisibility-overlay))))
2498 ;;;_ - Subtree Charting
2499 ;;;_ " These routines either produce or assess charts, which are
2500 ;;; nested lists of the locations of topics within a subtree.
2502 ;;; Charts enable efficient subtree navigation by providing a reusable basis
2503 ;;; for elaborate, compound assessment and adjustment of a subtree.
2505 ;;;_ > allout-chart-subtree (&optional levels visible orig-depth prev-depth)
2506 (defun allout-chart-subtree (&optional levels visible orig-depth prev-depth)
2507 "Produce a location \"chart\" of subtopics of the containing topic.
2509 Optional argument LEVELS specifies a depth limit \(relative to start
2510 depth) for the chart. Null LEVELS means no limit.
2512 When optional argument VISIBLE is non-nil, the chart includes
2513 only the visible subelements of the charted subjects.
2515 The remaining optional args are for internal use by the function.
2517 Point is left at the end of the subtree.
2519 Charts are used to capture outline structure, so that outline-altering
2520 routines need assess the structure only once, and then use the chart
2521 for their elaborate manipulations.
2523 The chart entries for the topics are in reverse order, so the
2524 last topic is listed first. The entry for each topic consists of
2525 an integer indicating the point at the beginning of the topic
2526 prefix. Charts for offspring consists of a list containing,
2527 recursively, the charts for the respective subtopics. The chart
2528 for a topics' offspring precedes the entry for the topic itself.
2530 The other function parameters are for internal recursion, and should
2531 not be specified by external callers. ORIG-DEPTH is depth of topic at
2532 starting point, and PREV-DEPTH is depth of prior topic."
2534 (let ((original (not orig-depth)) ; `orig-depth' set only in recursion.
2537 (if original ; Just starting?
2538 ; Register initial settings and
2539 ; position to first offspring:
2540 (progn (setq orig-depth (allout-depth))
2541 (or prev-depth (setq prev-depth (1+ orig-depth)))
2543 (allout-next-visible-heading 1)
2544 (allout-next-heading))))
2546 ;; Loop over the current levels' siblings. Besides being more
2547 ;; efficient than tail-recursing over a level, it avoids exceeding
2548 ;; the typically quite constrained Emacs max-lisp-eval-depth.
2550 ;; Probably would speed things up to implement loop-based stack
2551 ;; operation rather than recursing for lower levels. Bah.
2553 (while (and (not (eobp))
2554 ; Still within original topic?
2555 (< orig-depth (setq curr-depth allout-recent-depth))
2556 (cond ((= prev-depth curr-depth)
2557 ;; Register this one and move on:
2558 (setq chart (cons allout-recent-prefix-beginning chart))
2559 (if (and levels (<= levels 1))
2560 ;; At depth limit - skip sublevels:
2561 (or (allout-next-sibling curr-depth)
2562 ;; or no more siblings - proceed to
2563 ;; next heading at lesser depth:
2564 (while (and (<= curr-depth
2565 allout-recent-depth)
2567 (allout-next-visible-heading 1)
2568 (allout-next-heading)))))
2570 (allout-next-visible-heading 1)
2571 (allout-next-heading))))
2573 ((and (< prev-depth curr-depth)
2576 ;; Recurse on deeper level of curr topic:
2578 (cons (allout-chart-subtree (and levels
2584 ;; ... then continue with this one.
2587 ;; ... else nil if we've ascended back to prev-depth.
2591 (if original ; We're at the last sibling on
2592 ; the original level. Position
2594 (progn (and (not (eobp)) (forward-char -1))
2595 (and (= (preceding-char) ?\n)
2596 (= (aref (buffer-substring (max 1 (- (point) 3))
2601 (setq allout-recent-end-of-subtree (point))))
2603 chart ; (nreverse chart) not necessary,
2604 ; and maybe not preferable.
2606 ;;;_ > allout-chart-siblings (&optional start end)
2607 (defun allout-chart-siblings (&optional start end)
2608 "Produce a list of locations of this and succeeding sibling topics.
2609 Effectively a top-level chart of siblings. See `allout-chart-subtree'
2610 for an explanation of charts."
2612 (when (allout-goto-prefix-doublechecked)
2613 (let ((chart (list (point))))
2614 (while (allout-next-sibling)
2615 (setq chart (cons (point) chart)))
2616 (if chart (setq chart (nreverse chart)))))))
2617 ;;;_ > allout-chart-to-reveal (chart depth)
2618 (defun allout-chart-to-reveal (chart depth)
2620 "Return a flat list of hidden points in subtree CHART, up to DEPTH.
2622 If DEPTH is nil, include hidden points at any depth.
2624 Note that point can be left at any of the points on chart, or at the
2628 (while (and (or (null depth) (> depth 0))
2630 (setq here (car chart))
2632 (let ((further (allout-chart-to-reveal here (if (null depth)
2635 ;; We're on the start of a subtree - recurse with it, if there's
2636 ;; more depth to go:
2637 (if further (setq result (append further result)))
2638 (setq chart (cdr chart)))
2640 (if (allout-hidden-p)
2641 (setq result (cons here result)))
2642 (setq chart (cdr chart))))
2644 ;;;_ X allout-chart-spec (chart spec &optional exposing)
2645 ;; (defun allout-chart-spec (chart spec &optional exposing)
2646 ;; "Not yet \(if ever) implemented.
2648 ;; Produce exposure directives given topic/subtree CHART and an exposure SPEC.
2650 ;; Exposure spec indicates the locations to be exposed and the prescribed
2651 ;; exposure status. Optional arg EXPOSING is an integer, with 0
2652 ;; indicating pending concealment, anything higher indicating depth to
2653 ;; which subtopic headers should be exposed, and negative numbers
2654 ;; indicating (negative of) the depth to which subtopic headers and
2655 ;; bodies should be exposed.
2657 ;; The produced list can have two types of entries. Bare numbers
2658 ;; indicate points in the buffer where topic headers that should be
2661 ;; - bare negative numbers indicates that the topic starting at the
2662 ;; point which is the negative of the number should be opened,
2663 ;; including their entries.
2664 ;; - bare positive values indicate that this topic header should be
2666 ;; - Lists signify the beginning and end points of regions that should
2667 ;; be flagged, and the flag to employ. (For concealment: `\(\?r\)', and
2670 ;; (cond ((listp spec)
2673 ;; (setq spec (cdr spec)))
2677 ;;;_ > allout-goto-prefix ()
2678 (defun allout-goto-prefix ()
2679 "Put point at beginning of immediately containing outline topic.
2681 Goes to most immediate subsequent topic if none immediately containing.
2683 Not sensitive to topic visibility.
2685 Returns the point at the beginning of the prefix, or nil if none."
2688 (while (and (not done)
2689 (search-backward "\n" nil 1))
2691 (if (looking-at allout-regexp)
2692 (setq done (allout-prefix-data))
2695 (cond ((looking-at allout-regexp)
2696 (allout-prefix-data))
2697 ((allout-next-heading))
2700 ;;;_ > allout-goto-prefix-doublechecked ()
2701 (defun allout-goto-prefix-doublechecked ()
2702 "Put point at beginning of immediately containing outline topic.
2704 Like `allout-goto-prefix', but shallow topics \(according to
2705 `allout-doublecheck-at-and-shallower') are checked and
2706 disqualified for child containment discontinuity, according to
2707 `allout-aberrant-container-p'."
2708 (allout-goto-prefix)
2709 (if (and (<= allout-recent-depth allout-doublecheck-at-and-shallower)
2710 (allout-aberrant-container-p))
2711 (allout-previous-heading)
2714 ;;;_ > allout-end-of-prefix ()
2715 (defun allout-end-of-prefix (&optional ignore-decorations)
2716 "Position cursor at beginning of header text.
2718 If optional IGNORE-DECORATIONS is non-nil, put just after bullet,
2719 otherwise skip white space between bullet and ensuing text."
2721 (if (not (allout-goto-prefix-doublechecked))
2723 (goto-char allout-recent-prefix-end)
2724 (if ignore-decorations
2726 (while (looking-at "[0-9]") (forward-char 1))
2727 (if (and (not (eolp)) (looking-at "\\s-")) (forward-char 1)))
2728 ;; Reestablish where we are:
2729 (allout-current-depth)))
2730 ;;;_ > allout-current-bullet-pos ()
2731 (defun allout-current-bullet-pos ()
2732 "Return position of current \(visible) topic's bullet."
2734 (if (not (allout-current-depth))
2736 (1- allout-recent-prefix-end)))
2737 ;;;_ > allout-back-to-current-heading ()
2738 (defun allout-back-to-current-heading ()
2739 "Move to heading line of current topic, or beginning if already on the line.
2741 Return value of point, unless we started outside of (before any) topics,
2742 in which case we return nil."
2744 (allout-beginning-of-current-line)
2745 (if (or (allout-on-current-heading-p)
2746 (and (re-search-backward (concat "^\\(" allout-regexp "\\)")
2748 (progn (while (allout-hidden-p)
2749 (allout-beginning-of-current-line)
2750 (if (not (looking-at allout-regexp))
2751 (re-search-backward allout-regexp
2753 (allout-prefix-data))))
2755 (allout-end-of-prefix)
2757 ;;;_ > allout-back-to-heading ()
2758 (defalias 'allout-back-to-heading 'allout-back-to-current-heading)
2759 ;;;_ > allout-pre-next-prefix ()
2760 (defun allout-pre-next-prefix ()
2761 "Skip forward to just before the next heading line.
2763 Returns that character position."
2765 (if (allout-next-heading)
2766 (goto-char (1- allout-recent-prefix-beginning))))
2767 ;;;_ > allout-end-of-subtree (&optional current include-trailing-blank)
2768 (defun allout-end-of-subtree (&optional current include-trailing-blank)
2769 "Put point at the end of the last leaf in the containing topic.
2771 Optional CURRENT means put point at the end of the containing
2774 Optional INCLUDE-TRAILING-BLANK means include a trailing blank line, if
2775 any, as part of the subtree. Otherwise, that trailing blank will be
2776 excluded as delimiting whitespace between topics.
2778 Returns the value of point."
2781 (allout-back-to-current-heading)
2782 (allout-goto-prefix-doublechecked))
2783 (let ((level allout-recent-depth))
2784 (allout-next-heading)
2785 (while (and (not (eobp))
2786 (> allout-recent-depth level))
2787 (allout-next-heading))
2789 (allout-end-of-entry)
2791 (if (and (not include-trailing-blank) (= ?\n (preceding-char)))
2793 (setq allout-recent-end-of-subtree (point))))
2794 ;;;_ > allout-end-of-current-subtree (&optional include-trailing-blank)
2795 (defun allout-end-of-current-subtree (&optional include-trailing-blank)
2797 "Put point at end of last leaf in currently visible containing topic.
2799 Optional INCLUDE-TRAILING-BLANK means include a trailing blank line, if
2800 any, as part of the subtree. Otherwise, that trailing blank will be
2801 excluded as delimiting whitespace between topics.
2803 Returns the value of point."
2805 (allout-end-of-subtree t include-trailing-blank))
2806 ;;;_ > allout-beginning-of-current-entry ()
2807 (defun allout-beginning-of-current-entry ()
2808 "When not already there, position point at beginning of current topic header.
2810 If already there, move cursor to bullet for hot-spot operation.
2811 \(See `allout-mode' doc string for details of hot-spot operation.)"
2813 (let ((start-point (point)))
2814 (move-beginning-of-line 1)
2815 (if (< 0 (allout-current-depth))
2816 (goto-char allout-recent-prefix-end)
2817 (goto-char (point-min)))
2818 (allout-end-of-prefix)
2819 (if (and (interactive-p)
2820 (= (point) start-point))
2821 (goto-char (allout-current-bullet-pos)))))
2822 ;;;_ > allout-end-of-entry (&optional inclusive)
2823 (defun allout-end-of-entry (&optional inclusive)
2824 "Position the point at the end of the current topics' entry.
2826 Optional INCLUSIVE means also include trailing empty line, if any. When
2827 unset, whitespace between items separates them even when the items are
2830 (allout-pre-next-prefix)
2831 (if (and (not inclusive) (not (bobp)) (= ?\n (preceding-char)))
2834 ;;;_ > allout-end-of-current-heading ()
2835 (defun allout-end-of-current-heading ()
2837 (allout-beginning-of-current-entry)
2838 (search-forward "\n" nil t)
2840 (defalias 'allout-end-of-heading 'allout-end-of-current-heading)
2841 ;;;_ > allout-get-body-text ()
2842 (defun allout-get-body-text ()
2843 "Return the unmangled body text of the topic immediately containing point."
2845 (allout-end-of-prefix)
2846 (if (not (search-forward "\n" nil t))
2849 (let ((pre-body (point)))
2852 (allout-end-of-entry t)
2853 (if (not (= pre-body (point)))
2854 (buffer-substring-no-properties (1+ pre-body) (point))))
2861 ;;;_ > allout-ascend-to-depth (depth)
2862 (defun allout-ascend-to-depth (depth)
2863 "Ascend to depth DEPTH, returning depth if successful, nil if not."
2864 (if (and (> depth 0)(<= depth (allout-depth)))
2865 (let (last-ascended)
2866 (while (and (< depth allout-recent-depth)
2867 (setq last-ascended (allout-ascend))))
2868 (goto-char allout-recent-prefix-beginning)
2869 (if (interactive-p) (allout-end-of-prefix))
2870 (and last-ascended allout-recent-depth))))
2871 ;;;_ > allout-ascend ()
2872 (defun allout-ascend ()
2873 "Ascend one level, returning t if successful, nil if not."
2875 (if (allout-beginning-of-level)
2876 (allout-previous-heading))
2877 (if (interactive-p) (allout-end-of-prefix))))
2878 ;;;_ > allout-descend-to-depth (depth)
2879 (defun allout-descend-to-depth (depth)
2880 "Descend to depth DEPTH within current topic.
2882 Returning depth if successful, nil if not."
2883 (let ((start-point (point))
2884 (start-depth (allout-depth)))
2886 (and (> (allout-depth) 0)
2887 (not (= depth allout-recent-depth)) ; ... not there yet
2888 (allout-next-heading) ; ... go further
2889 (< start-depth allout-recent-depth))) ; ... still in topic
2890 (if (and (> (allout-depth) 0)
2891 (= allout-recent-depth depth))
2893 (goto-char start-point)
2896 ;;;_ > allout-up-current-level (arg)
2897 (defun allout-up-current-level (arg)
2898 "Move out ARG levels from current visible topic."
2900 (let ((start-point (point)))
2901 (allout-back-to-current-heading)
2902 (if (not (allout-ascend))
2903 (progn (goto-char start-point)
2904 (error "Can't ascend past outermost level"))
2905 (if (interactive-p) (allout-end-of-prefix))
2906 allout-recent-prefix-beginning)))
2909 ;;;_ > allout-next-sibling (&optional depth backward)
2910 (defun allout-next-sibling (&optional depth backward)
2911 "Like `allout-forward-current-level', but respects invisible topics.
2913 Traverse at optional DEPTH, or current depth if none specified.
2915 Go backward if optional arg BACKWARD is non-nil.
2917 Return the start point of the new topic if successful, nil otherwise."
2919 (if (if backward (bobp) (eobp))
2921 (let ((target-depth (or depth (allout-depth)))
2922 (start-point (point))
2927 ;; done too few single steps to resort to the leap routine:
2930 (not (if backward (bobp) (eobp)))
2931 ;; still traversable:
2932 (if backward (allout-previous-heading) (allout-next-heading))
2933 ;; we're below the target depth
2934 (> (setq last-depth allout-recent-depth) target-depth))
2935 (setq count (1+ count))
2936 (if (> count 7) ; lists are commonly 7 +- 2, right?-)
2939 (or (allout-next-sibling-leap target-depth backward)
2941 (goto-char start-point)
2942 (if depth (allout-depth) target-depth)
2945 (and (> (or last-depth (allout-depth)) 0)
2946 (= allout-recent-depth target-depth)))
2947 allout-recent-prefix-beginning)
2949 (goto-char start-point)
2950 (if depth (allout-depth) target-depth)
2952 ;;;_ > allout-next-sibling-leap (&optional depth backward)
2953 (defun allout-next-sibling-leap (&optional depth backward)
2954 "Like `allout-next-sibling', but by direct search for topic at depth.
2956 Traverse at optional DEPTH, or current depth if none specified.
2958 Go backward if optional arg BACKWARD is non-nil.
2960 Return the start point of the new topic if successful, nil otherwise.
2962 Costs more than regular `allout-next-sibling' for short traversals:
2964 - we have to check the prior \(next, if travelling backwards)
2965 item to confirm connectivity with the prior topic, and
2966 - if confirmed, we have to reestablish the allout-recent-* settings with
2967 some extra navigation
2968 - if confirmation fails, we have to do more work to recover
2970 It is an increasingly big win when there are many intervening
2971 offspring before the next sibling, however, so
2972 `allout-next-sibling' resorts to this if it finds itself in that
2975 (if (if backward (bobp) (eobp))
2977 (let* ((start-point (point))
2978 (target-depth (or depth (allout-depth)))
2979 (search-whitespace-regexp nil)
2980 (depth-biased (- target-depth 2))
2981 (expression (if (<= target-depth 1)
2982 allout-depth-one-regexp
2983 (format allout-depth-specific-regexp
2984 depth-biased depth-biased)))
2988 (setq found (if backward
2989 (re-search-backward expression nil 'to-limit)
2991 (re-search-forward expression nil 'to-limit)))
2992 (if (and found (allout-aberrant-container-p))
2994 (setq done (or found (if backward (bobp) (eobp)))))
2996 (progn (goto-char start-point)
2998 ;; rationale: if any intervening items were at a lower depth, we
2999 ;; would now be on the first offspring at the target depth - ie,
3000 ;; the preceeding item (per the search direction) must be at a
3001 ;; lesser depth. that's all we need to check.
3002 (if backward (allout-next-heading) (allout-previous-heading))
3003 (if (< allout-recent-depth target-depth)
3004 ;; return to start and reestablish allout-recent-*:
3006 (goto-char start-point)
3010 ;; locate cursor and set allout-recent-*:
3011 (allout-goto-prefix))))))
3012 ;;;_ > allout-previous-sibling (&optional depth backward)
3013 (defun allout-previous-sibling (&optional depth backward)
3014 "Like `allout-forward-current-level' backwards, respecting invisible topics.
3016 Optional DEPTH specifies depth to traverse, default current depth.
3018 Optional BACKWARD reverses direction.
3020 Return depth if successful, nil otherwise."
3021 (allout-next-sibling depth (not backward))
3023 ;;;_ > allout-snug-back ()
3024 (defun allout-snug-back ()
3025 "Position cursor at end of previous topic.
3027 Presumes point is at the start of a topic prefix."
3028 (if (or (bobp) (eobp))
3031 (if (or (bobp) (not (= ?\n (preceding-char))))
3035 ;;;_ > allout-beginning-of-level ()
3036 (defun allout-beginning-of-level ()
3037 "Go back to the first sibling at this level, visible or not."
3038 (allout-end-of-level 'backward))
3039 ;;;_ > allout-end-of-level (&optional backward)
3040 (defun allout-end-of-level (&optional backward)
3041 "Go to the last sibling at this level, visible or not."
3043 (let ((depth (allout-depth)))
3044 (while (allout-previous-sibling depth nil))
3045 (prog1 allout-recent-depth
3046 (if (interactive-p) (allout-end-of-prefix)))))
3047 ;;;_ > allout-next-visible-heading (arg)
3048 (defun allout-next-visible-heading (arg)
3049 "Move to the next ARG'th visible heading line, backward if arg is negative.
3051 Move to buffer limit in indicated direction if headings are exhausted."
3054 (let* ((inhibit-field-text-motion t)
3055 (backward (if (< arg 0) (setq arg (* -1 arg))))
3056 (step (if backward -1 1))
3061 ;; Boundary condition:
3062 (not (if backward (bobp)(eobp)))
3063 ;; Move, skipping over all concealed lines in one fell swoop:
3064 (prog1 (condition-case nil (or (line-move step) t)
3066 (allout-beginning-of-current-line))
3067 ;; Deal with apparent header line:
3068 (if (not (looking-at allout-regexp))
3069 ;; not a header line, keep looking:
3071 (allout-prefix-data)
3072 (if (and (<= allout-recent-depth
3073 allout-doublecheck-at-and-shallower)
3074 (allout-aberrant-container-p))
3075 ;; skip this aberrant prospective header line:
3077 ;; this prospective headerline qualifies - register:
3078 (setq got allout-recent-prefix-beginning)
3079 ;; and break the loop:
3081 ;; Register this got, it may be the last:
3082 (if got (setq prev got))
3083 (setq arg (1- arg)))
3084 (cond (got ; Last move was to a prefix:
3085 (allout-end-of-prefix))
3086 (prev ; Last move wasn't, but prev was:
3088 (allout-end-of-prefix))
3089 ((not backward) (end-of-line) nil))))
3090 ;;;_ > allout-previous-visible-heading (arg)
3091 (defun allout-previous-visible-heading (arg)
3092 "Move to the previous heading line.
3094 With argument, repeats or can move forward if negative.
3095 A heading line is one that starts with a `*' (or that `allout-regexp'
3098 (prog1 (allout-next-visible-heading (- arg))
3099 (if (interactive-p) (allout-end-of-prefix))))
3100 ;;;_ > allout-forward-current-level (arg)
3101 (defun allout-forward-current-level (arg)
3102 "Position point at the next heading of the same level.
3104 Takes optional repeat-count, goes backward if count is negative.
3106 Returns resulting position, else nil if none found."
3108 (let ((start-depth (allout-current-depth))
3110 (backward (> 0 arg)))
3111 (if (= 0 start-depth)
3112 (error "No siblings, not in a topic..."))
3113 (if backward (setq arg (* -1 arg)))
3114 (allout-back-to-current-heading)
3115 (while (and (not (zerop arg))
3117 (allout-previous-sibling)
3118 (allout-next-sibling)))
3119 (setq arg (1- arg)))
3120 (if (not (interactive-p))
3122 (allout-end-of-prefix)
3123 (if (not (zerop arg))
3124 (error "Hit %s level %d topic, traversed %d of %d requested"
3125 (if backward "first" "last")
3127 (- (abs start-arg) arg)
3128 (abs start-arg))))))
3129 ;;;_ > allout-backward-current-level (arg)
3130 (defun allout-backward-current-level (arg)
3131 "Inverse of `allout-forward-current-level'."
3134 (let ((current-prefix-arg (* -1 arg)))
3135 (call-interactively 'allout-forward-current-level))
3136 (allout-forward-current-level (* -1 arg))))
3141 ;;;_ = allout-post-goto-bullet
3142 (defvar allout-post-goto-bullet nil
3143 "Outline internal var, for `allout-pre-command-business' hot-spot operation.
3145 When set, tells post-processing to reposition on topic bullet, and
3146 then unset it. Set by `allout-pre-command-business' when implementing
3147 hot-spot operation, where literal characters typed over a topic bullet
3148 are mapped to the command of the corresponding control-key on the
3149 `allout-mode-map'.")
3150 (make-variable-buffer-local 'allout-post-goto-bullet)
3151 ;;;_ = allout-command-counter
3152 (defvar allout-command-counter 0
3153 "Counter that monotonically increases in allout-mode buffers.
3155 Set by `allout-pre-command-business', to support allout addons in
3156 coordinating with allout activity.")
3157 (make-variable-buffer-local 'allout-command-counter)
3158 ;;;_ > allout-post-command-business ()
3159 (defun allout-post-command-business ()
3160 "Outline `post-command-hook' function.
3162 - Implement (and clear) `allout-post-goto-bullet', for hot-spot
3165 - Decrypt topic currently being edited if it was encrypted for a save."
3167 ; Apply any external change func:
3168 (if (not (allout-mode-p)) ; In allout-mode.
3171 (if (and (boundp 'allout-after-save-decrypt)
3172 allout-after-save-decrypt)
3173 (allout-after-saves-handler))
3175 ;; Implement allout-post-goto-bullet, if set:
3176 (if (and allout-post-goto-bullet
3177 (allout-current-bullet-pos))
3178 (progn (goto-char (allout-current-bullet-pos))
3179 (setq allout-post-goto-bullet nil)))
3181 ;;;_ > allout-pre-command-business ()
3182 (defun allout-pre-command-business ()
3183 "Outline `pre-command-hook' function for outline buffers.
3185 Among other things, implements special behavior when the cursor is on the
3186 topic bullet character.
3188 When the cursor is on the bullet character, self-insert characters are
3189 reinterpreted as the corresponding control-character in the
3190 `allout-mode-map'. The `allout-mode' `post-command-hook' insures that
3191 the cursor which has moved as a result of such reinterpretation is
3192 positioned on the bullet character of the destination topic.
3194 The upshot is that you can get easy, single \(ie, unmodified\) key
3195 outline maneuvering operations by positioning the cursor on the bullet
3196 char. When in this mode you can use regular cursor-positioning
3197 command/keystrokes to relocate the cursor off of a bullet character to
3198 return to regular interpretation of self-insert characters."
3200 (if (not (allout-mode-p))
3202 ;; Increment allout-command-counter
3203 (setq allout-command-counter (1+ allout-command-counter))
3204 ;; Do hot-spot navigation.
3205 (if (and (eq this-command 'self-insert-command)
3206 (eq (point)(allout-current-bullet-pos)))
3207 (allout-hotspot-key-handler))))
3208 ;;;_ > allout-hotspot-key-handler ()
3209 (defun allout-hotspot-key-handler ()
3210 "Catchall handling of key bindings in hot-spots.
3212 Translates unmodified keystrokes to corresponding allout commands, when
3213 they would qualify if prefixed with the allout-command-prefix, and sets
3214 this-command accordingly.
3216 Returns the qualifying command, if any, else nil."
3218 (let* ((key-string (if (numberp last-command-char)
3219 (char-to-string last-command-char)))
3220 (key-num (cond ((numberp last-command-char) last-command-char)
3221 ;; for XEmacs character type:
3222 ((and (fboundp 'characterp)
3223 (apply 'characterp (list last-command-char)))
3224 (apply 'char-to-int (list last-command-char)))
3232 ;; exclude control chars and escape:
3234 (setq mapped-binding
3235 (or (and (assoc key-string allout-keybindings-list)
3236 ;; translate literal membership on list:
3237 (cadr (assoc key-string allout-keybindings-list)))
3238 ;; translate as a keybinding:
3239 (key-binding (concat allout-command-prefix
3241 (if (and (<= 97 key-num) ; "a"
3242 (>= 122 key-num)) ; "z"
3243 (- key-num 96) key-num)))
3245 ;; Qualified as an allout command - do hot-spot operation.
3246 (setq allout-post-goto-bullet t)
3247 ;; accept-defaults nil, or else we'll get allout-item-icon-key-handler.
3248 (setq mapped-binding (key-binding (char-to-string key-num))))
3250 (while (keymapp mapped-binding)
3251 (setq mapped-binding
3252 (lookup-key mapped-binding (vector (read-char)))))
3255 (setq this-command mapped-binding)))))
3257 ;;;_ > allout-find-file-hook ()
3258 (defun allout-find-file-hook ()
3259 "Activate `allout-mode' on non-nil `allout-auto-activation', `allout-layout'.
3261 See `allout-init' for setup instructions."
3262 (if (and allout-auto-activation
3263 (not (allout-mode-p))
3267 ;;;_ - Topic Format Assessment
3268 ;;;_ > allout-solicit-alternate-bullet (depth &optional current-bullet)
3269 (defun allout-solicit-alternate-bullet (depth &optional current-bullet)
3271 "Prompt for and return a bullet char as an alternative to the current one.
3273 Offer one suitable for current depth DEPTH as default."
3275 (let* ((default-bullet (or (and (stringp current-bullet) current-bullet)
3276 (allout-bullet-for-depth depth)))
3277 (sans-escapes (regexp-sans-escapes allout-bullets-string))
3280 (goto-char (allout-current-bullet-pos))
3281 (setq choice (solicit-char-in-string
3282 (format "Select bullet: %s ('%s' default): "
3284 (substring-no-properties default-bullet))
3288 (if (string= choice "") default-bullet choice))
3290 ;;;_ > allout-distinctive-bullet (bullet)
3291 (defun allout-distinctive-bullet (bullet)
3292 "True if BULLET is one of those on `allout-distinctive-bullets-string'."
3293 (string-match (regexp-quote bullet) allout-distinctive-bullets-string))
3294 ;;;_ > allout-numbered-type-prefix (&optional prefix)
3295 (defun allout-numbered-type-prefix (&optional prefix)
3296 "True if current header prefix bullet is numbered bullet."
3297 (and allout-numbered-bullet
3298 (string= allout-numbered-bullet
3300 (allout-get-prefix-bullet prefix)
3301 (allout-get-bullet)))))
3302 ;;;_ > allout-encrypted-type-prefix (&optional prefix)
3303 (defun allout-encrypted-type-prefix (&optional prefix)
3304 "True if current header prefix bullet is for an encrypted entry \(body)."
3305 (and allout-topic-encryption-bullet
3306 (string= allout-topic-encryption-bullet
3308 (allout-get-prefix-bullet prefix)
3309 (allout-get-bullet)))))
3310 ;;;_ > allout-bullet-for-depth (&optional depth)
3311 (defun allout-bullet-for-depth (&optional depth)
3312 "Return outline topic bullet suited to optional DEPTH, or current depth."
3313 ;; Find bullet in plain-bullets-string modulo DEPTH.
3314 (if allout-stylish-prefixes
3315 (char-to-string (aref allout-plain-bullets-string
3316 (% (max 0 (- depth 2))
3317 allout-plain-bullets-string-len)))
3318 allout-primary-bullet)
3321 ;;;_ - Topic Production
3322 ;;;_ > allout-make-topic-prefix (&optional prior-bullet
3323 (defun allout-make-topic-prefix (&optional prior-bullet
3329 ;; Depth null means use current depth, non-null means we're either
3330 ;; opening a new topic after current topic, lower or higher, or we're
3331 ;; changing level of current topic.
3332 ;; Solicit dominates specified bullet-char.
3334 "Generate a topic prefix suitable for optional arg DEPTH, or current depth.
3336 All the arguments are optional.
3338 PRIOR-BULLET indicates the bullet of the prefix being changed, or
3339 nil if none. This bullet may be preserved (other options
3340 notwithstanding) if it is on the `allout-distinctive-bullets-string',
3343 Second arg NEW indicates that a new topic is being opened after the
3344 topic at point, if non-nil. Default bullet for new topics, eg, may
3345 be set (contingent to other args) to numbered bullets if previous
3346 sibling is one. The implication otherwise is that the current topic
3347 is being adjusted - shifted or rebulleted - and we don't consider
3348 bullet or previous sibling.
3350 Third arg DEPTH forces the topic prefix to that depth, regardless of
3351 the current topics' depth.
3353 If SOLICIT is non-nil, then the choice of bullet is solicited from
3354 user. If it's a character, then that character is offered as the
3355 default, otherwise the one suited to the context \(according to
3356 distinction or depth) is offered. \(This overrides other options,
3357 including, eg, a distinctive PRIOR-BULLET.) If non-nil, then the
3358 context-specific bullet is used.
3360 Fifth arg, NUMBER-CONTROL, matters only if `allout-numbered-bullet'
3361 is non-nil *and* soliciting was not explicitly invoked. Then
3362 NUMBER-CONTROL non-nil forces prefix to either numbered or
3363 denumbered format, depending on the value of the sixth arg, INDEX.
3365 \(Note that NUMBER-CONTROL does *not* apply to level 1 topics. Sorry...)
3367 If NUMBER-CONTROL is non-nil and sixth arg INDEX is non-nil then
3368 the prefix of the topic is forced to be numbered. Non-nil
3369 NUMBER-CONTROL and nil INDEX forces non-numbered format on the
3370 bullet. Non-nil NUMBER-CONTROL and non-nil, non-number INDEX means
3371 that the index for the numbered prefix will be derived, by counting
3372 siblings back to start of level. If INDEX is a number, then that
3373 number is used as the index for the numbered prefix (allowing, eg,
3374 sequential renumbering to not require this function counting back the
3375 index for each successive sibling)."
3377 ;; The options are ordered in likely frequence of use, most common
3378 ;; highest, least lowest. Ie, more likely to be doing prefix
3379 ;; adjustments than soliciting, and yet more than numbering.
3380 ;; Current prefix is least dominant, but most likely to be commonly
3386 (depth (or depth (allout-depth)))
3387 (header-lead allout-header-prefix)
3390 ;; Getting value for bullet char is practically the whole job:
3393 ; Simplest situation - level 1:
3394 ((<= depth 1) (setq header-lead "") allout-primary-bullet)
3395 ; Simple, too: all asterisks:
3396 (allout-old-style-prefixes
3397 ;; Cheat - make body the whole thing, null out header-lead and
3399 (setq body (make-string depth
3400 (string-to-char allout-primary-bullet)))
3401 (setq header-lead "")
3404 ;; (Neither level 1 nor old-style, so we're space padding.
3405 ;; Sneak it in the condition of the next case, whatever it is.)
3407 ;; Solicitation overrides numbering and other cases:
3408 ((progn (setq body (make-string (- depth 2) ?\ ))
3409 ;; The actual condition:
3411 (let* ((got (allout-solicit-alternate-bullet depth solicit)))
3412 ;; Gotta check whether we're numbering and got a numbered bullet:
3413 (setq numbering (and allout-numbered-bullet
3414 (not (and number-control (not index)))
3415 (string= got allout-numbered-bullet)))
3416 ;; Now return what we got, regardless:
3419 ;; Numbering invoked through args:
3420 ((and allout-numbered-bullet number-control)
3421 (if (setq numbering (not (setq denumbering (not index))))
3422 allout-numbered-bullet
3423 (if (and prior-bullet
3424 (not (string= allout-numbered-bullet
3427 (allout-bullet-for-depth depth))))
3429 ;;; Neither soliciting nor controlled numbering ;;;
3430 ;;; (may be controlled denumbering, tho) ;;;
3432 ;; Check wrt previous sibling:
3433 ((and new ; only check for new prefixes
3434 (<= depth (allout-depth))
3435 allout-numbered-bullet ; ... & numbering enabled
3437 (let ((sibling-bullet
3439 ;; Locate correct sibling:
3440 (or (>= depth (allout-depth))
3441 (allout-ascend-to-depth depth))
3442 (allout-get-bullet))))
3443 (if (and sibling-bullet
3444 (string= allout-numbered-bullet sibling-bullet))
3445 (setq numbering sibling-bullet)))))
3447 ;; Distinctive prior bullet?
3449 (allout-distinctive-bullet prior-bullet)
3450 ;; Either non-numbered:
3451 (or (not (and allout-numbered-bullet
3452 (string= prior-bullet allout-numbered-bullet)))
3453 ;; or numbered, and not denumbering:
3454 (setq numbering (not denumbering)))
3458 ;; Else, standard bullet per depth:
3459 ((allout-bullet-for-depth depth)))))
3465 (format "%d" (cond ((and index (numberp index)) index)
3466 (new (1+ (allout-sibling-index depth)))
3467 ((allout-sibling-index))))))
3470 ;;;_ > allout-open-topic (relative-depth &optional before offer-recent-bullet)
3471 (defun allout-open-topic (relative-depth &optional before offer-recent-bullet)
3472 "Open a new topic at depth DEPTH.
3474 New topic is situated after current one, unless optional flag BEFORE
3475 is non-nil, or unless current line is completely empty - lacking even
3476 whitespace - in which case open is done on the current line.
3478 When adding an offspring, it will be added immediately after the parent if
3479 the other offspring are exposed, or after the last child if the offspring
3480 are hidden. \(The intervening offspring will be exposed in the latter
3483 If OFFER-RECENT-BULLET is true, offer to use the bullet of the prior sibling.
3489 - Creation of new topics is with respect to the visible topic
3490 containing the cursor, regardless of intervening concealed ones.
3492 - New headers are generally created after/before the body of a
3493 topic. However, they are created right at cursor location if the
3494 cursor is on a blank line, even if that breaks the current topic
3495 body. This is intentional, to provide a simple means for
3496 deliberately dividing topic bodies.
3498 - Double spacing of topic lists is preserved. Also, the first
3499 level two topic is created double-spaced (and so would be
3500 subsequent siblings, if that's left intact). Otherwise,
3501 single-spacing is used.
3503 - Creation of sibling or nested topics is with respect to the topic
3504 you're starting from, even when creating backwards. This way you
3505 can easily create a sibling in front of the current topic without
3506 having to go to its preceding sibling, and then open forward
3509 (allout-beginning-of-current-line)
3510 (let* ((inhibit-field-text-motion t)
3511 (depth (+ (allout-current-depth) relative-depth))
3512 (opening-on-blank (if (looking-at "^\$")
3513 (not (setq before nil))))
3514 ;; bunch o vars set while computing ref-topic
3518 (ref-topic (save-excursion
3519 (cond ((< relative-depth 0)
3520 (allout-ascend-to-depth depth))
3521 ((>= relative-depth 1) nil)
3522 (t (allout-back-to-current-heading)))
3523 (setq ref-depth allout-recent-depth)
3525 (if (> allout-recent-prefix-end 1)
3526 (allout-recent-bullet)
3528 (setq opening-numbered
3530 (and allout-numbered-bullet
3531 (or (<= relative-depth 0)
3532 (allout-descend-to-depth depth))
3533 (if (allout-numbered-type-prefix)
3534 allout-numbered-bullet))))
3540 (if (not opening-on-blank)
3541 ; Positioning and vertical
3542 ; padding - only if not
3545 (goto-char ref-topic)
3546 (setq dbl-space ; Determine double space action:
3547 (or (and (<= relative-depth 0) ; not descending;
3549 ;; at b-o-b or preceded by a blank line?
3550 (or (> 0 (forward-line -1))
3551 (looking-at "^\\s-*$")
3554 ;; succeeded by a blank line?
3555 (allout-end-of-current-subtree)
3556 (looking-at "\n\n")))
3557 (and (= ref-depth 1)
3561 ;; Don't already have following
3562 ;; vertical padding:
3563 (not (allout-pre-next-prefix)))))))
3565 ;; Position to prior heading, if inserting backwards, and not
3567 (if (and before (>= relative-depth 0))
3568 (progn (allout-back-to-current-heading)
3569 (setq doing-beginning (bobp))
3571 (allout-previous-heading)))
3572 (if (and before (bobp))
3575 (if (<= relative-depth 0)
3576 ;; Not going inwards, don't snug up:
3582 (progn (end-of-line)
3583 (allout-pre-next-prefix)
3584 (while (and (= ?\n (following-char))
3589 (if (not (looking-at "^$"))
3591 (allout-end-of-current-subtree)
3592 (if (looking-at "\n\n") (forward-char 1))))
3593 ;; Going inwards - double-space if first offspring is
3594 ;; double-spaced, otherwise snug up.
3595 (allout-end-of-entry)
3599 (allout-beginning-of-current-line)
3602 ;; Blank lines between current header body and next
3603 ;; header - get to last substantive (non-white-space)
3605 (progn (setq dbl-space t)
3606 (re-search-backward "[^ \t\n]" nil t)))
3607 (if (looking-at "\n\n")
3610 (allout-next-heading)
3611 (when (> allout-recent-depth ref-depth)
3612 ;; This is an offspring.
3614 (looking-at "^\\s-*$")))
3615 (progn (forward-line 1)
3618 (allout-end-of-current-line))
3620 ;;(if doing-beginning (goto-char doing-beginning))
3622 ;; We insert a newline char rather than using open-line to
3623 ;; avoid rear-stickiness inheritence of read-only property.
3624 (progn (if (and (not (> depth ref-depth))
3627 (if (and (not dbl-space) (> depth ref-depth))
3633 (if (and dbl-space (not (> relative-depth 0)))
3635 (if (and (not (eobp))
3638 ;; bolp doesnt detect concealed
3639 ;; trailing newlines, compensate:
3642 (allout-hidden-p)))))
3645 (setq start (point))
3646 (insert (concat (allout-make-topic-prefix opening-numbered t depth)
3648 (setq end (1+ (point)))
3650 (allout-rebullet-heading (and offer-recent-bullet ref-bullet)
3652 (if (> relative-depth 0)
3653 (save-excursion (goto-char ref-topic)
3654 (allout-show-children)))
3657 (run-hook-with-args 'allout-structure-added-hook start end)
3660 ;;;_ > allout-open-subtopic (arg)
3661 (defun allout-open-subtopic (arg)
3662 "Open new topic header at deeper level than the current one.
3664 Negative universal arg means to open deeper, but place the new topic
3665 prior to the current one."
3667 (allout-open-topic 1 (> 0 arg) (< 1 arg)))
3668 ;;;_ > allout-open-sibtopic (arg)
3669 (defun allout-open-sibtopic (arg)
3670 "Open new topic header at same level as the current one.
3672 Positive universal arg means to use the bullet of the prior sibling.
3674 Negative universal arg means to place the new topic prior to the current
3677 (allout-open-topic 0 (> 0 arg) (not (= 1 arg))))
3678 ;;;_ > allout-open-supertopic (arg)
3679 (defun allout-open-supertopic (arg)
3680 "Open new topic header at shallower level than the current one.
3682 Negative universal arg means to open shallower, but place the new
3683 topic prior to the current one."
3686 (allout-open-topic -1 (> 0 arg) (< 1 arg)))
3688 ;;;_ - Outline Alteration
3689 ;;;_ : Topic Modification
3690 ;;;_ = allout-former-auto-filler
3691 (defvar allout-former-auto-filler nil
3692 "Name of modal fill function being wrapped by `allout-auto-fill'.")
3693 ;;;_ > allout-auto-fill ()
3694 (defun allout-auto-fill ()
3695 "`allout-mode' autofill function.
3697 Maintains outline hanging topic indentation if
3698 `allout-use-hanging-indents' is set."
3700 (when (not allout-inhibit-auto-fill)
3701 (let ((fill-prefix (if allout-use-hanging-indents
3702 ;; Check for topic header indentation:
3705 (if (looking-at allout-regexp)
3706 ;; ... construct indentation to account for
3707 ;; length of topic prefix:
3708 (make-string (progn (allout-end-of-prefix)
3711 (use-auto-fill-function (or allout-outside-normal-auto-fill-function
3714 (if (or allout-former-auto-filler allout-use-hanging-indents)
3715 (funcall use-auto-fill-function)))))
3716 ;;;_ > allout-reindent-body (old-depth new-depth &optional number)
3717 (defun allout-reindent-body (old-depth new-depth &optional number)
3718 "Reindent body lines which were indented at OLD-DEPTH to NEW-DEPTH.
3720 Optional arg NUMBER indicates numbering is being added, and it must
3723 Note that refill of indented paragraphs is not done."
3726 (allout-end-of-prefix)
3727 (let* ((new-margin (current-column))
3728 excess old-indent-begin old-indent-end
3729 ;; We want the column where the header-prefix text started
3730 ;; *before* the prefix was changed, so we infer it relative
3731 ;; to the new margin and the shift in depth:
3732 (old-margin (+ old-depth (- new-margin new-depth))))
3734 ;; Process lines up to (but excluding) next topic header:
3738 (and (re-search-forward "\n\\(\\s-*\\)"
3741 ;; Register the indent data, before we reset the
3742 ;; match data with a subsequent `looking-at':
3743 (setq old-indent-begin (match-beginning 1)
3744 old-indent-end (match-end 1))
3745 (not (looking-at allout-regexp)))
3746 (if (> 0 (setq excess (- (- old-indent-end old-indent-begin)
3748 ;; Text starts left of old margin - don't adjust:
3750 ;; Text was hanging at or right of old left margin -
3751 ;; reindent it, preserving its existing indentation
3752 ;; beyond the old margin:
3753 (delete-region old-indent-begin old-indent-end)
3754 (indent-to (+ new-margin excess (current-column))))))))))
3755 ;;;_ > allout-rebullet-current-heading (arg)
3756 (defun allout-rebullet-current-heading (arg)
3757 "Solicit new bullet for current visible heading."
3759 (let ((initial-col (current-column))
3760 (on-bullet (eq (point)(allout-current-bullet-pos)))
3762 (backwards (if (< arg 0)
3763 (setq arg (* arg -1)))))
3765 (save-excursion (allout-back-to-current-heading)
3766 (allout-end-of-prefix)
3767 (setq from allout-recent-prefix-beginning
3768 to allout-recent-prefix-end)
3769 (allout-rebullet-heading t ;;; solicit
3771 nil ;;; number-control
3773 t) ;;; do-successors
3774 (run-hook-with-args 'allout-exposure-change-hook
3779 (setq initial-col nil) ; Override positioning back to init col
3781 (allout-next-visible-heading 1)
3782 (allout-goto-prefix-doublechecked)
3783 (allout-next-visible-heading -1))))
3785 (cond (on-bullet (goto-char (allout-current-bullet-pos)))
3786 (initial-col (move-to-column initial-col)))))
3787 ;;;_ > allout-rebullet-heading (&optional solicit ...)
3788 (defun allout-rebullet-heading (&optional solicit
3794 "Adjust bullet of current topic prefix.
3796 All args are optional.
3798 If SOLICIT is non-nil, then the choice of bullet is solicited from
3799 user. If it's a character, then that character is offered as the
3800 default, otherwise the one suited to the context \(according to
3801 distinction or depth) is offered. If non-nil, then the
3802 context-specific bullet is just used.
3804 Second arg DEPTH forces the topic prefix to that depth, regardless
3805 of the topic's current depth.
3807 Third arg NUMBER-CONTROL can force the prefix to or away from
3808 numbered form. It has effect only if `allout-numbered-bullet' is
3809 non-nil and soliciting was not explicitly invoked (via first arg).
3810 Its effect, numbering or denumbering, then depends on the setting
3811 of the forth arg, INDEX.
3813 If NUMBER-CONTROL is non-nil and forth arg INDEX is nil, then the
3814 prefix of the topic is forced to be non-numbered. Null index and
3815 non-nil NUMBER-CONTROL forces denumbering. Non-nil INDEX (and
3816 non-nil NUMBER-CONTROL) forces a numbered-prefix form. If non-nil
3817 INDEX is a number, then that number is used for the numbered
3818 prefix. Non-nil and non-number means that the index for the
3819 numbered prefix will be derived by allout-make-topic-prefix.
3821 Fifth arg DO-SUCCESSORS t means re-resolve count on succeeding
3824 Cf vars `allout-stylish-prefixes', `allout-old-style-prefixes',
3825 and `allout-numbered-bullet', which all affect the behavior of
3828 (let* ((current-depth (allout-depth))
3829 (new-depth (or new-depth current-depth))
3830 (mb allout-recent-prefix-beginning)
3831 (me allout-recent-prefix-end)
3832 (current-bullet (buffer-substring-no-properties (- me 1) me))
3833 (new-prefix (allout-make-topic-prefix current-bullet
3840 ;; Is new one is identical to old?
3841 (if (and (= current-depth new-depth)
3842 (string= current-bullet
3843 (substring new-prefix (1- (length new-prefix)))))
3847 ;; New prefix probably different from old:
3848 ; get rid of old one:
3849 (allout-unprotected (delete-region mb me))
3851 ; Dispense with number if
3852 ; numbered-bullet prefix:
3853 (if (and allout-numbered-bullet
3854 (string= allout-numbered-bullet current-bullet)
3855 (looking-at "[0-9]+"))
3857 (delete-region (match-beginning 0)(match-end 0))))
3859 ; Put in new prefix:
3860 (allout-unprotected (insert new-prefix))
3862 ;; Reindent the body if elected, margin changed, and not encrypted body:
3863 (if (and allout-reindent-bodies
3864 (not (= new-depth current-depth))
3865 (not (allout-encrypted-topic-p)))
3866 (allout-reindent-body current-depth new-depth))
3868 ;; Recursively rectify successive siblings of orig topic if
3869 ;; caller elected for it:
3872 (while (allout-next-sibling new-depth nil)
3874 (cond ((numberp index) (1+ index))
3875 ((not number-control) (allout-sibling-index))))
3876 (if (allout-numbered-type-prefix)
3877 (allout-rebullet-heading nil ;;; solicit
3878 new-depth ;;; new-depth
3879 number-control;;; number-control
3881 nil))))) ;;;(dont!)do-successors
3882 ) ; (if (and (= current-depth new-depth)...))
3883 ) ; let* ((current-depth (allout-depth))...)
3885 ;;;_ > allout-rebullet-topic (arg)
3886 (defun allout-rebullet-topic (arg &optional sans-offspring)
3887 "Rebullet the visible topic containing point and all contained subtopics.
3889 Descends into invisible as well as visible topics, however.
3891 When optional sans-offspring is non-nil, subtopics are not
3892 shifted. \(Shifting a topic outwards without shifting its
3893 offspring is disallowed, since this would create a \"containment
3894 discontinuity\", where the depth difference between a topic and
3895 its immediate offspring is greater than one.)
3897 With repeat count, shift topic depth by that amount."
3899 (let ((start-col (current-column)))
3902 (cond ((null arg) (setq arg 0))
3903 ((listp arg) (setq arg (car arg))))
3904 ;; Fill the user in, in case we're shifting a big topic:
3905 (if (not (zerop arg)) (message "Shifting..."))
3906 (allout-back-to-current-heading)
3907 (if (<= (+ allout-recent-depth arg) 0)
3908 (error "Attempt to shift topic below level 1"))
3909 (allout-rebullet-topic-grunt arg nil nil nil nil sans-offspring)
3910 (if (not (zerop arg)) (message "Shifting... done.")))
3911 (move-to-column (max 0 (+ start-col arg)))))
3912 ;;;_ > allout-rebullet-topic-grunt (&optional relative-depth ...)
3913 (defun allout-rebullet-topic-grunt (&optional relative-depth
3919 "Like `allout-rebullet-topic', but on nearest containing topic
3922 See `allout-rebullet-heading' for rebulleting behavior.
3924 All arguments are optional.
3926 First arg RELATIVE-DEPTH means to shift the depth of the entire
3929 Several subsequent args are for internal recursive use by the function
3930 itself: STARTING-DEPTH, STARTING-POINT, and INDEX.
3932 Finally, if optional SANS-OFFSPRING is non-nil then the offspring
3933 are not shifted. \(Shifting a topic outwards without shifting
3934 its offspring is disallowed, since this would create a
3935 \"containment discontinuity\", where the depth difference between
3936 a topic and its immediate offspring is greater than one..)"
3938 ;; XXX the recursion here is peculiar, and in general the routine may
3939 ;; need simplification with refactoring.
3941 (if (and sans-offspring
3943 (< relative-depth 0))
3944 (error (concat "Attempt to shift topic outwards without offspring,"
3945 " would cause containment discontinuity.")))
3947 (let* ((relative-depth (or relative-depth 0))
3948 (new-depth (allout-depth))
3949 (starting-depth (or starting-depth new-depth))
3950 (on-starting-call (null starting-point))
3952 ;; Leave index null on starting call, so rebullet-heading
3953 ;; calculates it at what might be new depth:
3954 (and (or (zerop relative-depth)
3955 (not on-starting-call))
3956 (allout-sibling-index))))
3957 (starting-index index)
3958 (moving-outwards (< 0 relative-depth))
3959 (starting-point (or starting-point (point)))
3960 (local-point (point)))
3962 ;; Sanity check for excessive promotion done only on starting call:
3963 (and on-starting-call
3965 (> 0 (+ starting-depth relative-depth))
3966 (error "Attempt to shift topic out beyond level 1"))
3968 (cond ((= starting-depth new-depth)
3969 ;; We're at depth to work on this one.
3971 ;; When shifting out we work on the children before working on
3972 ;; the parent to avoid interim `allout-aberrant-container-p'
3973 ;; aberrancy, and vice-versa when shifting in:
3974 (if (>= relative-depth 0)
3975 (allout-rebullet-heading nil
3976 (+ starting-depth relative-depth)
3979 nil)) ;;; do-successors
3980 (when (not sans-offspring)
3981 ;; ... and work on subsequent ones which are at greater depth:
3983 (allout-next-heading)
3984 (while (and (not (eobp))
3985 (< starting-depth (allout-depth)))
3986 (setq index (1+ index))
3987 (allout-rebullet-topic-grunt relative-depth
3991 (when (< relative-depth 0)
3993 (goto-char local-point)
3994 (allout-rebullet-heading nil ;;; solicit
3995 (+ starting-depth relative-depth)
3998 nil)))) ;;; do-successors
4000 ((< starting-depth new-depth)
4001 ;; Rare case - subtopic more than one level deeper than parent.
4002 ;; Treat this one at an even deeper level:
4003 (allout-rebullet-topic-grunt relative-depth
4009 (if on-starting-call
4011 ;; Rectify numbering of former siblings of the adjusted topic,
4012 ;; if topic has changed depth
4013 (if (or do-successors
4014 (and (not (zerop relative-depth))
4015 (or (= allout-recent-depth starting-depth)
4016 (= allout-recent-depth (+ starting-depth
4018 (allout-rebullet-heading nil nil nil nil t))
4019 ;; Now rectify numbering of new siblings of the adjusted topic,
4020 ;; if depth has been changed:
4021 (progn (goto-char starting-point)
4022 (if (not (zerop relative-depth))
4023 (allout-rebullet-heading nil nil nil nil t)))))
4026 ;;;_ > allout-renumber-to-depth (&optional depth)
4027 (defun allout-renumber-to-depth (&optional depth)
4028 "Renumber siblings at current depth.
4030 Affects superior topics if optional arg DEPTH is less than current depth.
4032 Returns final depth."
4034 ;; Proceed by level, processing subsequent siblings on each,
4035 ;; ascending until we get shallower than the start depth:
4037 (let ((ascender (allout-depth))
4039 (while (and (not (eobp))
4041 (>= allout-recent-depth depth)
4042 (>= ascender depth))
4043 ; Skip over all topics at
4044 ; lesser depths, which can not
4045 ; have been disturbed:
4046 (while (and (not (setq was-eobp (eobp)))
4047 (> allout-recent-depth ascender))
4048 (allout-next-heading))
4049 ; Prime ascender for ascension:
4050 (setq ascender (1- allout-recent-depth))
4051 (if (>= allout-recent-depth depth)
4052 (allout-rebullet-heading nil ;;; solicit
4054 nil ;;; number-control
4056 t)) ;;; do-successors
4057 (if was-eobp (goto-char (point-max)))))
4058 allout-recent-depth)
4059 ;;;_ > allout-number-siblings (&optional denumber)
4060 (defun allout-number-siblings (&optional denumber)
4061 "Assign numbered topic prefix to this topic and its siblings.
4063 With universal argument, denumber - assign default bullet to this
4064 topic and its siblings.
4066 With repeated universal argument (`^U^U'), solicit bullet for each
4067 rebulleting each topic at this level."
4072 (allout-back-to-current-heading)
4073 (allout-beginning-of-level)
4074 (let ((depth allout-recent-depth)
4075 (index (if (not denumber) 1))
4076 (use-bullet (equal '(16) denumber))
4079 (allout-rebullet-heading use-bullet ;;; solicit
4081 t ;;; number-control
4083 nil) ;;; do-successors
4084 (if index (setq index (1+ index)))
4085 (setq more (allout-next-sibling depth nil))))))
4086 ;;;_ > allout-shift-in (arg)
4087 (defun allout-shift-in (arg)
4088 "Increase depth of current heading and any items collapsed within it.
4090 With a negative argument, the item is shifted out using
4091 `allout-shift-out', instead.
4093 With an argument greater than one, shift-in the item but not its
4094 offspring, making the item into a sibling of its former children,
4095 and a child of sibling that formerly preceeded it.
4097 You are not allowed to shift the first offspring of a topic
4098 inwards, because that would yield a \"containment
4099 discontinuity\", where the depth difference between a topic and
4100 its immediate offspring is greater than one. The first topic in
4101 the file can be adjusted to any positive depth, however."
4105 (allout-shift-out (* arg -1))
4106 ;; refuse to create a containment discontinuity:
4108 (allout-back-to-current-heading)
4110 (let* ((current-depth allout-recent-depth)
4111 (start-point (point))
4112 (predecessor-depth (progn
4114 (allout-goto-prefix-doublechecked)
4115 (if (< (point) start-point)
4118 (if (and (> predecessor-depth 0)
4119 (> (1+ current-depth)
4120 (1+ predecessor-depth)))
4121 (error (concat "Disallowed shift deeper than"
4122 " containing topic's children."))))))
4123 (let ((where (point)))
4124 (allout-rebullet-topic 1 (and (> arg 1) 'sans-offspring))
4125 (run-hook-with-args 'allout-structure-shifted-hook arg where))))
4126 ;;;_ > allout-shift-out (arg)
4127 (defun allout-shift-out (arg)
4128 "Decrease depth of current heading and any topics collapsed within it.
4129 This will make the item a sibling of its former container.
4131 With a negative argument, the item is shifted in using
4132 `allout-shift-in', instead.
4134 With an argument greater than one, shift-out the item's offspring
4135 but not the item itself, making the former children siblings of
4138 With an argument greater than 1, the item's offspring are shifted
4139 out without shifting the item. This will make the immediate
4140 subtopics into siblings of the item."
4143 (allout-shift-in (* arg -1))
4144 ;; Get proper exposure in this area:
4145 (save-excursion (if (allout-ascend)
4146 (allout-show-children)))
4147 ;; Show collapsed children if there's a successor which will become
4149 (if (and (allout-current-topic-collapsed-p)
4150 (save-excursion (allout-next-sibling)))
4151 (allout-show-children))
4152 (let ((where (and (allout-depth) allout-recent-prefix-beginning)))
4155 ;; Shift the offspring but not the topic:
4156 (let ((children-chart (allout-chart-subtree 1)))
4157 (if (listp (car children-chart))
4159 (setq children-chart (allout-flatten children-chart)))
4161 (dolist (child-point children-chart)
4162 (goto-char child-point)
4163 (allout-shift-out 1))))
4164 (allout-rebullet-topic (* arg -1))))
4165 (run-hook-with-args 'allout-structure-shifted-hook (* arg -1) where))))
4166 ;;;_ : Surgery (kill-ring) functions with special provisions for outlines:
4167 ;;;_ > allout-kill-line (&optional arg)
4168 (defun allout-kill-line (&optional arg)
4169 "Kill line, adjusting subsequent lines suitably for outline mode."
4173 (if (or (not (allout-mode-p))
4175 (not (looking-at allout-regexp)))
4176 ;; Just do a regular kill:
4178 ;; Ah, have to watch out for adjustments:
4179 (let* ((beg (point))
4181 (beg-hidden (allout-hidden-p))
4182 (end-hidden (save-excursion (allout-end-of-current-line)
4185 (depth (allout-depth)))
4187 (allout-annotate-hidden beg end)
4189 (if (and (not beg-hidden) (not end-hidden))
4190 (allout-unprotected (kill-line arg))
4192 (if allout-numbered-bullet
4193 (save-excursion ; Renumber subsequent topics if needed:
4194 (if (not (looking-at allout-regexp))
4195 (allout-next-heading))
4196 (allout-renumber-to-depth depth)))
4197 (run-hook-with-args 'allout-structure-deleted-hook depth (point)))))
4198 ;;;_ > allout-copy-line-as-kill ()
4199 (defun allout-copy-line-as-kill ()
4200 "Like allout-kill-topic, but save to kill ring instead of deleting."
4202 (let ((buffer-read-only t))
4205 (buffer-read-only nil))))
4206 ;;;_ > allout-kill-topic ()
4207 (defun allout-kill-topic ()
4208 "Kill topic together with subtopics.
4210 Trailing whitespace is killed with a topic if that whitespace:
4212 - would separate the topic from a subsequent sibling
4213 - would separate the topic from the end of buffer
4214 - would not be added to whitespace already separating the topic from the
4217 Topic exposure is marked with text-properties, to be used by
4218 allout-yank-processing for exposure recovery."
4221 (let* ((inhibit-field-text-motion t)
4222 (beg (prog1 (allout-back-to-current-heading) (beginning-of-line)))
4223 (depth allout-recent-depth))
4224 (allout-end-of-current-subtree)
4225 (if (and (/= (current-column) 0) (not (eobp)))
4228 (if (and (looking-at "\n")
4230 (or (not (allout-next-heading))
4231 (= depth allout-recent-depth)))
4232 (and (> (- beg (point-min)) 3)
4233 (string= (buffer-substring (- beg 2) beg) "\n\n"))))
4236 (allout-annotate-hidden beg (point))
4238 (allout-unprotected (kill-region beg (point)))
4240 (allout-renumber-to-depth depth))
4241 (run-hook-with-args 'allout-structure-deleted-hook depth (point))))
4242 ;;;_ > allout-copy-topic-as-kill ()
4243 (defun allout-copy-topic-as-kill ()
4244 "Like allout-kill-topic, but save to kill ring instead of deleting."
4246 (let ((buffer-read-only t))
4249 (buffer-read-only (message "Topic copied...")))))
4250 ;;;_ > allout-annotate-hidden (begin end)
4251 (defun allout-annotate-hidden (begin end)
4252 "Qualify text with properties to indicate exposure status."
4254 (let ((was-modified (buffer-modified-p))
4255 (buffer-read-only nil))
4257 (remove-text-properties begin end '(allout-was-hidden t)))
4260 (let (done next prev overlay)
4262 ;; at or advance to start of next hidden region:
4263 (if (not (allout-hidden-p))
4266 (next-single-char-property-change (point)
4269 (if (or (not next) (eq prev next))
4270 ;; still not at start of hidden area - must not be any left.
4274 (if (not (allout-hidden-p))
4275 ;; still not at start of hidden area.
4277 (setq overlay (allout-get-invisibility-overlay))
4278 (setq next (overlay-end overlay)
4280 ;; advance to end of this hidden area:
4284 (put-text-property (overlay-start overlay) next
4285 'allout-was-hidden t))))))))
4286 (set-buffer-modified-p was-modified)))
4287 ;;;_ > allout-hide-by-annotation (begin end)
4288 (defun allout-hide-by-annotation (begin end)
4289 "Translate text properties indicating exposure status into actual exposure."
4292 (let ((was-modified (buffer-modified-p))
4295 ;; at or advance to start of next annotation:
4296 (if (not (get-text-property (point) 'allout-was-hidden))
4297 (setq next (next-single-char-property-change (point)
4300 (if (or (not next) (eq prev next))
4301 ;; no more or not advancing - must not be any left.
4305 (if (not (get-text-property (point) 'allout-was-hidden))
4306 ;; still not at start of annotation.
4308 ;; advance to just after end of this annotation:
4309 (setq next (next-single-char-property-change (point)
4312 (overlay-put (make-overlay prev next)
4313 'category 'allout-exposure-category)
4315 (remove-text-properties prev next '(allout-was-hidden t)))
4317 (if next (goto-char next)))))
4318 (set-buffer-modified-p was-modified))))
4319 ;;;_ > allout-remove-exposure-annotation (begin end)
4320 (defun allout-remove-exposure-annotation (begin end)
4321 "Remove text properties indicating exposure status."
4322 (remove-text-properties begin end '(allout-was-hidden t)))
4324 ;;;_ > allout-yank-processing ()
4325 (defun allout-yank-processing (&optional arg)
4327 "Incidental allout-specific business to be done just after text yanks.
4329 Does depth adjustment of yanked topics, when:
4331 1 the stuff being yanked starts with a valid outline header prefix, and
4332 2 it is being yanked at the end of a line which consists of only a valid
4335 Also, adjusts numbering of subsequent siblings when appropriate.
4337 Depth adjustment alters the depth of all the topics being yanked
4338 the amount it takes to make the first topic have the depth of the
4339 header into which it's being yanked.
4341 The point is left in front of yanked, adjusted topics, rather than
4342 at the end (and vice-versa with the mark). Non-adjusted yanks,
4343 however, are left exactly like normal, non-allout-specific yanks."
4346 ; Get to beginning, leaving
4347 ; region around subject:
4348 (if (< (allout-mark-marker t) (point))
4349 (exchange-point-and-mark))
4351 (let* ((subj-beg (point))
4353 (subj-end (allout-mark-marker t))
4354 ;; 'resituate' if yanking an entire topic into topic header:
4355 (resituate (and (allout-e-o-prefix-p)
4356 (looking-at allout-regexp)
4357 (allout-prefix-data)))
4358 ;; `rectify-numbering' if resituating (where several topics may
4359 ;; be resituating) or yanking a topic into a topic slot (bol):
4360 (rectify-numbering (or resituate
4361 (and into-bol (looking-at allout-regexp)))))
4363 ; The yanked stuff is a topic:
4364 (let* ((prefix-len (- (match-end 1) subj-beg))
4365 (subj-depth allout-recent-depth)
4366 (prefix-bullet (allout-recent-bullet))
4368 ;; Nil if adjustment unnecessary, otherwise depth to which
4369 ;; adjustment should be made:
4371 (and (goto-char subj-end)
4373 (goto-char subj-beg)
4374 (and (looking-at allout-regexp)
4377 (not (= (point) subj-beg)))
4378 (looking-at allout-regexp)
4379 (allout-prefix-data))
4380 allout-recent-depth)))
4382 (setq rectify-numbering allout-numbered-bullet)
4384 ; Do the adjustment:
4387 (narrow-to-region subj-beg subj-end)
4388 ; Trim off excessive blank
4389 ; line at end, if any:
4390 (goto-char (point-max))
4391 (if (looking-at "^$")
4392 (allout-unprotected (delete-char -1)))
4393 ; Work backwards, with each
4395 ; successively excluding the
4396 ; last processed topic from
4397 ; the narrow region:
4399 (allout-back-to-current-heading)
4400 ; go as high as we can in each bunch:
4401 (while (allout-ascend))
4403 (allout-rebullet-topic-grunt (- adjust-to-depth
4406 (if (setq more (not (bobp)))
4409 (narrow-to-region subj-beg (point))))))
4410 ;; Preserve new bullet if it's a distinctive one, otherwise
4412 (if (string-match (regexp-quote prefix-bullet)
4413 allout-distinctive-bullets-string)
4414 ; Delete from bullet of old to
4415 ; before bullet of new:
4418 (delete-region (point) subj-beg)
4419 (set-marker (allout-mark-marker t) subj-end)
4420 (goto-char subj-beg)
4421 (allout-end-of-prefix))
4422 ; Delete base subj prefix,
4424 (delete-region (point) (+ (point)
4426 (- adjust-to-depth subj-depth)))
4427 ; and delete residual subj
4428 ; prefix digits and space:
4429 (while (looking-at "[0-9]") (delete-char 1))
4430 (if (looking-at " ") (delete-char 1))))
4431 (exchange-point-and-mark))))
4432 (if rectify-numbering
4435 ; Give some preliminary feedback:
4436 (message "... reconciling numbers")
4437 ; ... and renumber, in case necessary:
4438 (goto-char subj-beg)
4439 (if (allout-goto-prefix-doublechecked)
4440 (allout-rebullet-heading nil ;;; solicit
4441 (allout-depth) ;;; depth
4442 nil ;;; number-control
4446 (if (or into-bol resituate)
4447 (allout-hide-by-annotation (point) (allout-mark-marker t))
4448 (allout-remove-exposure-annotation (allout-mark-marker t) (point)))
4450 (exchange-point-and-mark))
4451 (run-hook-with-args 'allout-structure-added-hook subj-beg subj-end))))
4452 ;;;_ > allout-yank (&optional arg)
4453 (defun allout-yank (&optional arg)
4454 "`allout-mode' yank, with depth and numbering adjustment of yanked topics.
4456 Non-topic yanks work no differently than normal yanks.
4458 If a topic is being yanked into a bare topic prefix, the depth of the
4459 yanked topic is adjusted to the depth of the topic prefix.
4461 1 we're yanking in an `allout-mode' buffer
4462 2 the stuff being yanked starts with a valid outline header prefix, and
4463 3 it is being yanked at the end of a line which consists of only a valid
4466 If these conditions hold then the depth of the yanked topics are all
4467 adjusted the amount it takes to make the first one at the depth of the
4468 header into which it's being yanked.
4470 The point is left in front of yanked, adjusted topics, rather than
4471 at the end (and vice-versa with the mark). Non-adjusted yanks,
4472 however, (ones that don't qualify for adjustment) are handled
4473 exactly like normal yanks.
4475 Numbering of yanked topics, and the successive siblings at the depth
4476 into which they're being yanked, is adjusted.
4478 `allout-yank-pop' works with `allout-yank' just like normal `yank-pop'
4479 works with normal `yank' in non-outline buffers."
4482 (setq this-command 'yank)
4486 (allout-yank-processing)))
4487 ;;;_ > allout-yank-pop (&optional arg)
4488 (defun allout-yank-pop (&optional arg)
4489 "Yank-pop like `allout-yank' when popping to bare outline prefixes.
4491 Adapts level of popped topics to level of fresh prefix.
4493 Note - prefix changes to distinctive bullets will stick, if followed
4494 by pops to non-distinctive yanks. Bug..."
4497 (setq this-command 'yank)
4500 (allout-yank-processing)))
4502 ;;;_ - Specialty bullet functions
4503 ;;;_ : File Cross references
4504 ;;;_ > allout-resolve-xref ()
4505 (defun allout-resolve-xref ()
4506 "Pop to file associated with current heading, if it has an xref bullet.
4508 \(Works according to setting of `allout-file-xref-bullet')."
4510 (if (not allout-file-xref-bullet)
4512 "Outline cross references disabled - no `allout-file-xref-bullet'")
4513 (if (not (string= (allout-current-bullet) allout-file-xref-bullet))
4514 (error "Current heading lacks cross-reference bullet `%s'"
4515 allout-file-xref-bullet)
4516 (let ((inhibit-field-text-motion t)
4519 (let* ((text-start allout-recent-prefix-end)
4520 (heading-end (progn (end-of-line) (point))))
4521 (goto-char text-start)
4523 (if (re-search-forward "\\s-\\(\\S-*\\)" heading-end t)
4524 (buffer-substring (match-beginning 1) (match-end 1))))))
4525 (setq file-name (expand-file-name file-name))
4526 (if (or (file-exists-p file-name)
4527 (if (file-writable-p file-name)
4528 (y-or-n-p (format "%s not there, create one? "
4530 (error "%s not found and can't be created" file-name)))
4531 (condition-case failure
4532 (find-file-other-window file-name)
4534 (error "%s not found" file-name))
4540 ;;;_ #6 Exposure Control
4543 ;;;_ > allout-flag-region (from to flag)
4544 (defun allout-flag-region (from to flag)
4545 "Conceal text between FROM and TO if FLAG is non-nil, else reveal it.
4547 Exposure-change hook `allout-exposure-change-hook' is run with the same
4548 arguments as this function, after the exposure changes are made. \(The old
4549 `allout-view-change-hook' is being deprecated, and eventually will not be
4552 ;; We use outline invisibility spec.
4553 (remove-overlays from to 'category 'allout-exposure-category)
4555 (let ((o (make-overlay from to)))
4556 (overlay-put o 'category 'allout-exposure-category)
4557 (when (featurep 'xemacs)
4558 (let ((props (symbol-plist 'allout-exposure-category)))
4560 (overlay-put o (pop props) (pop props)))))))
4561 (run-hooks 'allout-view-change-hook)
4562 (run-hook-with-args 'allout-exposure-change-hook from to flag))
4563 ;;;_ > allout-flag-current-subtree (flag)
4564 (defun allout-flag-current-subtree (flag)
4565 "Conceal currently-visible topic's subtree if FLAG non-nil, else reveal it."
4568 (allout-back-to-current-heading)
4569 (let ((inhibit-field-text-motion t))
4571 (allout-flag-region (point)
4572 ;; Exposing must not leave trailing blanks hidden,
4573 ;; but can leave them exposed when hiding, so we
4574 ;; can use flag's inverse as the
4575 ;; include-trailing-blank cue:
4576 (allout-end-of-current-subtree (not flag))
4579 ;;;_ - Topic-specific
4580 ;;;_ > allout-show-entry ()
4581 (defun allout-show-entry ()
4582 "Like `allout-show-current-entry', but reveals entries in hidden topics.
4584 This is a way to give restricted peek at a concealed locality without the
4585 expense of exposing its context, but can leave the outline with aberrant
4586 exposure. `allout-show-offshoot' should be used after the peek to rectify
4592 (allout-goto-prefix-doublechecked)
4593 (setq beg (if (allout-hidden-p) (1- (point)) (point)))
4594 (setq end (allout-pre-next-prefix))
4595 (allout-flag-region beg end nil)
4597 ;;;_ > allout-show-children (&optional level strict)
4598 (defun allout-show-children (&optional level strict)
4600 "If point is visible, show all direct subheadings of this heading.
4602 Otherwise, do `allout-show-to-offshoot', and then show subheadings.
4604 Optional LEVEL specifies how many levels below the current level
4605 should be shown, or all levels if t. Default is 1.
4607 Optional STRICT means don't resort to -show-to-offshoot, no matter
4608 what. This is basically so -show-to-offshoot, which is called by
4609 this function, can employ the pure offspring-revealing capabilities of
4612 Returns point at end of subtree that was opened, if any. (May get a
4613 point of non-opened subtree?)"
4616 (let ((start-point (point)))
4617 (if (and (not strict)
4620 (progn (allout-show-to-offshoot) ; Point's concealed, open to
4622 ;; Then recurse, but with "strict" set so we don't
4623 ;; infinite regress:
4624 (allout-show-children level t))
4627 (allout-beginning-of-current-line)
4630 ;; translate the level spec for this routine to the ones
4631 ;; used by -chart-subtree and -chart-to-reveal:
4632 (chart-level (cond ((not level) 1)
4635 (chart (allout-chart-subtree chart-level))
4636 (to-reveal (or (allout-chart-to-reveal chart chart-level)
4637 ;; interactive, show discontinuous children:
4641 (allout-back-to-current-heading)
4642 (setq depth (allout-current-depth))
4643 (and (allout-next-heading)
4644 (> allout-recent-depth
4647 "Discontinuous offspring; use `%s %s'%s."
4648 (substitute-command-keys
4649 "\\[universal-argument]")
4650 (substitute-command-keys
4651 "\\[allout-shift-out]")
4652 " to elevate them.")
4653 (allout-chart-to-reveal
4654 chart (- allout-recent-depth depth))))))
4655 (goto-char start-point)
4656 (when (and strict (allout-hidden-p))
4657 ;; Concealed root would already have been taken care of,
4658 ;; unless strict was set.
4659 (allout-flag-region (point) (allout-snug-back) nil)
4660 (when allout-show-bodies
4661 (goto-char (car to-reveal))
4662 (allout-show-current-entry)))
4664 (goto-char (car to-reveal))
4665 (allout-flag-region (save-excursion (allout-snug-back) (point))
4666 (progn (search-forward "\n" nil t)
4669 (when allout-show-bodies
4670 (goto-char (car to-reveal))
4671 (allout-show-current-entry))
4672 (setq to-reveal (cdr to-reveal)))))))
4673 ;; Compensate for `save-excursion's maintenance of point
4674 ;; within invisible text:
4675 (goto-char start-point)))
4676 ;;;_ > allout-show-to-offshoot ()
4677 (defun allout-show-to-offshoot ()
4678 "Like `allout-show-entry', but reveals all concealed ancestors, as well.
4680 Useful for coherently exposing to a random point in a hidden region."
4683 (let ((inhibit-field-text-motion t)
4685 (orig-pref (allout-goto-prefix-doublechecked))
4688 (while (or (> bag-it 1) (allout-hidden-p))
4689 (while (allout-hidden-p)
4690 (move-beginning-of-line 1)
4691 (if (allout-hidden-p) (forward-char -1)))
4692 (if (= last-at (setq last-at (point)))
4693 ;; Oops, we're not making any progress! Show the current topic
4694 ;; completely, and try one more time here, if we haven't already.
4695 (progn (beginning-of-line)
4696 (allout-show-current-subtree)
4698 (setq bag-it (1+ bag-it))
4700 (error "allout-show-to-offshoot: %s"
4701 "Stumped by aberrant nesting.")))
4702 (if (> bag-it 0) (setq bag-it 0))
4703 (allout-show-children)
4704 (goto-char orig-pref)))
4705 (goto-char orig-pt)))
4706 (if (allout-hidden-p)
4707 (allout-show-entry)))
4708 ;;;_ > allout-hide-current-entry ()
4709 (defun allout-hide-current-entry ()
4710 "Hide the body directly following this heading."
4712 (allout-back-to-current-heading)
4714 (let ((inhibit-field-text-motion t))
4716 (allout-flag-region (point)
4717 (progn (allout-end-of-entry) (point))
4719 ;;;_ > allout-show-current-entry (&optional arg)
4720 (defun allout-show-current-entry (&optional arg)
4721 "Show body following current heading, or hide entry with universal argument."
4725 (allout-hide-current-entry)
4726 (save-excursion (allout-show-to-offshoot))
4728 (allout-flag-region (point)
4729 (progn (allout-end-of-entry t) (point))
4732 ;;;_ > allout-show-current-subtree (&optional arg)
4733 (defun allout-show-current-subtree (&optional arg)
4734 "Show everything within the current topic. With a repeat-count,
4735 expose this topic and its siblings."
4738 (if (<= (allout-current-depth) 0)
4739 ;; Outside any topics - try to get to the first:
4740 (if (not (allout-next-heading))
4742 ;; got to first, outermost topic - set to expose it and siblings:
4743 (message "Above outermost topic - exposing all.")
4744 (allout-flag-region (point-min)(point-max) nil))
4745 (allout-beginning-of-current-line)
4747 (allout-flag-current-subtree nil)
4748 (allout-beginning-of-level)
4749 (allout-expose-topic '(* :))))))
4750 ;;;_ > allout-current-topic-collapsed-p (&optional include-single-liners)
4751 (defun allout-current-topic-collapsed-p (&optional include-single-liners)
4752 "True if the currently visible containing topic is already collapsed.
4754 Single line topics intrinsically can be considered as being both
4755 collapsed and uncollapsed. If optional INCLUDE-SINGLE-LINERS is
4756 true, then single-line topics are considered to be collapsed. By
4757 default, they are treated as being uncollapsed."
4760 ;; Is the topic all on one line (allowing for trailing blank line)?
4761 (>= (progn (allout-back-to-current-heading)
4762 (move-end-of-line 1)
4764 (allout-end-of-current-subtree (not (looking-at "\n\n"))))
4766 (or include-single-liners
4767 (progn (backward-char 1) (allout-hidden-p))))))
4768 ;;;_ > allout-hide-current-subtree (&optional just-close)
4769 (defun allout-hide-current-subtree (&optional just-close)
4770 "Close the current topic, or containing topic if this one is already closed.
4772 If this topic is closed and it's a top level topic, close this topic
4775 If optional arg JUST-CLOSE is non-nil, do not close the parent or
4776 siblings, even if the target topic is already closed."
4779 (let* ((from (point))
4780 (sibs-msg "Top-level topic already closed - closing siblings...")
4781 (current-exposed (not (allout-current-topic-collapsed-p t))))
4782 (cond (current-exposed (allout-flag-current-subtree t))
4784 ((allout-ascend) (allout-hide-current-subtree))
4787 (allout-goto-prefix-doublechecked)
4788 (allout-expose-topic '(0 :))
4789 (message (concat sibs-msg " Done."))))
4791 ;;;_ > allout-show-current-branches ()
4792 (defun allout-show-current-branches ()
4793 "Show all subheadings of this heading, but not their bodies."
4795 (let ((inhibit-field-text-motion t))
4796 (beginning-of-line))
4797 (allout-show-children t))
4798 ;;;_ > allout-hide-current-leaves ()
4799 (defun allout-hide-current-leaves ()
4800 "Hide the bodies of the current topic and all its offspring."
4802 (allout-back-to-current-heading)
4803 (allout-hide-region-body (point) (progn (allout-end-of-current-subtree)
4806 ;;;_ - Region and beyond
4807 ;;;_ > allout-show-all ()
4808 (defun allout-show-all ()
4809 "Show all of the text in the buffer."
4811 (message "Exposing entire buffer...")
4812 (allout-flag-region (point-min) (point-max) nil)
4813 (message "Exposing entire buffer... Done."))
4814 ;;;_ > allout-hide-bodies ()
4815 (defun allout-hide-bodies ()
4816 "Hide all of buffer except headings."
4818 (allout-hide-region-body (point-min) (point-max)))
4819 ;;;_ > allout-hide-region-body (start end)
4820 (defun allout-hide-region-body (start end)
4821 "Hide all body lines in the region, but not headings."
4824 (narrow-to-region start end)
4825 (goto-char (point-min))
4826 (let ((inhibit-field-text-motion t))
4829 (allout-flag-region (point) (allout-end-of-entry) t)
4832 (if (looking-at "\n\n")
4835 ;;;_ > allout-expose-topic (spec)
4836 (defun allout-expose-topic (spec)
4837 "Apply exposure specs to successive outline topic items.
4839 Use the more convenient frontend, `allout-new-exposure', if you don't
4840 need evaluation of the arguments, or even better, the `allout-layout'
4841 variable-keyed mode-activation/auto-exposure feature of allout outline
4842 mode. See the respective documentation strings for more details.
4844 Cursor is left at start position.
4846 SPEC is either a number or a list.
4848 Successive specs on a list are applied to successive sibling topics.
4850 A simple spec \(either a number, one of a few symbols, or the null
4851 list) dictates the exposure for the corresponding topic.
4853 Non-null lists recursively designate exposure specs for respective
4854 subtopics of the current topic.
4856 The `:' repeat spec is used to specify exposure for any number of
4857 successive siblings, up to the trailing ones for which there are
4858 explicit specs following the `:'.
4860 Simple (numeric and null-list) specs are interpreted as follows:
4862 Numbers indicate the relative depth to open the corresponding topic.
4863 - negative numbers force the topic to be closed before opening to the
4864 absolute value of the number, so all siblings are open only to
4866 - positive numbers open to the relative depth indicated by the
4867 number, but do not force already opened subtopics to be closed.
4868 - 0 means to close topic - hide all offspring.
4870 apply prior element to all siblings at current level, *up to*
4871 those siblings that would be covered by specs following the `:'
4872 on the list. Ie, apply to all topics at level but the last
4873 ones. \(Only first of multiple colons at same level is
4874 respected - subsequent ones are discarded.)
4875 * - completely opens the topic, including bodies.
4876 + - shows all the sub headers, but not the bodies
4877 - - exposes the body of the corresponding topic.
4880 \(allout-expose-topic '(-1 : 0))
4881 Close this and all following topics at current level, exposing
4882 only their immediate children, but close down the last topic
4883 at this current level completely.
4884 \(allout-expose-topic '(-1 () : 1 0))
4885 Close current topic so only the immediate subtopics are shown;
4886 show the children in the second to last topic, and completely
4888 \(allout-expose-topic '(-2 : -1 *))
4889 Expose children and grandchildren of all topics at current
4890 level except the last two; expose children of the second to
4891 last and completely open the last one."
4893 (interactive "xExposure spec: ")
4894 (if (not (listp spec))
4896 (let ((depth (allout-depth))
4901 (setq prev-elem curr-elem
4902 curr-elem (car spec)
4904 (cond ; Do current element:
4905 ((null curr-elem) nil)
4906 ((symbolp curr-elem)
4907 (cond ((eq curr-elem '*) (allout-show-current-subtree)
4908 (if (> allout-recent-end-of-subtree max-pos)
4909 (setq max-pos allout-recent-end-of-subtree)))
4911 (if (not (allout-hidden-p))
4912 (save-excursion (allout-hide-current-subtree t)))
4913 (allout-show-current-branches)
4914 (if (> allout-recent-end-of-subtree max-pos)
4915 (setq max-pos allout-recent-end-of-subtree)))
4916 ((eq curr-elem '-) (allout-show-current-entry))
4919 ;; Expand the `repeat' spec to an explicit version,
4920 ;; w.r.t. remaining siblings:
4921 (let ((residue ; = # of sibs not covered by remaining spec
4922 ;; Dang - could be nice to make use of the chart, sigh:
4923 (- (length (allout-chart-siblings))
4926 ;; Some residue - cover it with prev-elem:
4927 (setq spec (append (make-list residue prev-elem)
4929 ((numberp curr-elem)
4930 (if (and (>= 0 curr-elem) (not (allout-hidden-p)))
4931 (save-excursion (allout-hide-current-subtree t)
4934 (if (> allout-recent-end-of-subtree max-pos)
4936 allout-recent-end-of-subtree)))))
4937 (if (> (abs curr-elem) 0)
4938 (progn (allout-show-children (abs curr-elem))
4939 (if (> allout-recent-end-of-subtree max-pos)
4940 (setq max-pos allout-recent-end-of-subtree)))))
4942 (if (allout-descend-to-depth (1+ depth))
4943 (let ((got (allout-expose-topic curr-elem)))
4944 (if (and got (> got max-pos)) (setq max-pos got))))))
4945 (cond (stay (setq stay nil))
4946 ((listp (car spec)) nil)
4947 ((> max-pos (point))
4948 ;; Capitalize on max-pos state to get us nearer next sibling:
4949 (progn (goto-char (min (point-max) max-pos))
4950 (allout-next-heading)))
4951 ((allout-next-sibling depth))))
4953 ;;;_ > allout-old-expose-topic (spec &rest followers)
4954 (defun allout-old-expose-topic (spec &rest followers)
4956 "Deprecated. Use `allout-expose-topic' \(with different schema
4959 Dictate wholesale exposure scheme for current topic, according to SPEC.
4961 SPEC is either a number or a list. Optional successive args
4962 dictate exposure for subsequent siblings of current topic.
4964 A simple spec (either a number, a special symbol, or the null list)
4965 dictates the overall exposure for a topic. Non null lists are
4966 composite specs whose first element dictates the overall exposure for
4967 a topic, with the subsequent elements in the list interpreted as specs
4968 that dictate the exposure for the successive offspring of the topic.
4970 Simple (numeric and null-list) specs are interpreted as follows:
4972 - Numbers indicate the relative depth to open the corresponding topic:
4973 - negative numbers force the topic to be close before opening to the
4974 absolute value of the number.
4975 - positive numbers just open to the relative depth indicated by the number.
4977 - `*' completely opens the topic, including bodies.
4978 - `+' shows all the sub headers, but not the bodies
4979 - `-' exposes the body and immediate offspring of the corresponding topic.
4981 If the spec is a list, the first element must be a number, which
4982 dictates the exposure depth of the topic as a whole. Subsequent
4983 elements of the list are nested SPECs, dictating the specific exposure
4984 for the corresponding offspring of the topic.
4986 Optional FOLLOWERS arguments dictate exposure for succeeding siblings."
4988 (interactive "xExposure spec: ")
4989 (let ((inhibit-field-text-motion t)
4990 (depth (allout-current-depth))
4992 (cond ((null spec) nil)
4994 (if (eq spec '*) (allout-show-current-subtree))
4995 (if (eq spec '+) (allout-show-current-branches))
4996 (if (eq spec '-) (allout-show-current-entry)))
4999 (save-excursion (allout-hide-current-subtree t)
5001 (if (or (not max-pos)
5002 (> (point) max-pos))
5003 (setq max-pos (point)))
5005 (setq spec (* -1 spec)))))
5007 (allout-show-children spec)))
5009 ;(let ((got (allout-old-expose-topic (car spec))))
5010 ; (if (and got (or (not max-pos) (> got max-pos)))
5011 ; (setq max-pos got)))
5012 (let ((new-depth (+ (allout-current-depth) 1))
5014 (setq max-pos (allout-old-expose-topic (car spec)))
5015 (setq spec (cdr spec))
5017 (allout-descend-to-depth new-depth)
5018 (not (allout-hidden-p)))
5019 (progn (setq got (apply 'allout-old-expose-topic spec))
5020 (if (and got (or (not max-pos) (> got max-pos)))
5021 (setq max-pos got)))))))
5022 (while (and followers
5023 (progn (if (and max-pos (< (point) max-pos))
5024 (progn (goto-char max-pos)
5025 (setq max-pos nil)))
5027 (allout-next-sibling depth)))
5028 (allout-old-expose-topic (car followers))
5029 (setq followers (cdr followers)))
5031 ;;;_ > allout-new-exposure '()
5032 (defmacro allout-new-exposure (&rest spec)
5033 "Literal frontend for `allout-expose-topic', doesn't evaluate arguments.
5034 Some arguments that would need to be quoted in `allout-expose-topic'
5035 need not be quoted in `allout-new-exposure'.
5037 Cursor is left at start position.
5039 Use this instead of obsolete `allout-exposure'.
5042 \(allout-new-exposure (-1 () () () 1) 0)
5043 Close current topic at current level so only the immediate
5044 subtopics are shown, except also show the children of the
5045 third subtopic; and close the next topic at the current level.
5046 \(allout-new-exposure : -1 0)
5047 Close all topics at current level to expose only their
5048 immediate children, except for the last topic at the current
5049 level, in which even its immediate children are hidden.
5050 \(allout-new-exposure -2 : -1 *)
5051 Expose children and grandchildren of first topic at current
5052 level, and expose children of subsequent topics at current
5053 level *except* for the last, which should be opened completely."
5054 (list 'save-excursion
5055 '(if (not (or (allout-goto-prefix-doublechecked)
5056 (allout-next-heading)))
5057 (error "allout-new-exposure: Can't find any outline topics"))
5058 (list 'allout-expose-topic (list 'quote spec))))
5060 ;;;_ #7 Systematic outline presentation - copying, printing, flattening
5062 ;;;_ - Mapping and processing of topics
5063 ;;;_ ( See also Subtree Charting, in Navigation code.)
5064 ;;;_ > allout-stringify-flat-index (flat-index)
5065 (defun allout-stringify-flat-index (flat-index &optional context)
5066 "Convert list representing section/subsection/... to document string.
5068 Optional arg CONTEXT indicates interior levels to include."
5072 (context-depth (or (and context 2) 1)))
5073 ;; Take care of the explicit context:
5074 (while (> context-depth 0)
5075 (setq numstr (int-to-string (car flat-index))
5076 flat-index (cdr flat-index)
5077 result (if flat-index
5078 (cons delim (cons numstr result))
5079 (cons numstr result))
5080 context-depth (if flat-index (1- context-depth) 0)))
5082 ;; Take care of the indentation:
5089 (1+ (truncate (if (zerop (car flat-index))
5091 (log10 (car flat-index)))))
5094 (setq flat-index (cdr flat-index)))
5095 ;; Dispose of single extra delim:
5096 (setq result (cdr result))))
5097 (apply 'concat result)))
5098 ;;;_ > allout-stringify-flat-index-plain (flat-index)
5099 (defun allout-stringify-flat-index-plain (flat-index)
5100 "Convert list representing section/subsection/... to document string."
5104 (setq result (cons (int-to-string (car flat-index))
5106 (cons delim result))))
5107 (setq flat-index (cdr flat-index)))
5108 (apply 'concat result)))
5109 ;;;_ > allout-stringify-flat-index-indented (flat-index)
5110 (defun allout-stringify-flat-index-indented (flat-index)
5111 "Convert list representing section/subsection/... to document string."
5115 ;; Take care of the explicit context:
5116 (setq numstr (int-to-string (car flat-index))
5117 flat-index (cdr flat-index)
5118 result (if flat-index
5119 (cons delim (cons numstr result))
5120 (cons numstr result)))
5122 ;; Take care of the indentation:
5129 (1+ (truncate (if (zerop (car flat-index))
5131 (log10 (car flat-index)))))
5134 (setq flat-index (cdr flat-index)))
5135 ;; Dispose of single extra delim:
5136 (setq result (cdr result))))
5137 (apply 'concat result)))
5138 ;;;_ > allout-listify-exposed (&optional start end format)
5139 (defun allout-listify-exposed (&optional start end format)
5141 "Produce a list representing exposed topics in current region.
5143 This list can then be used by `allout-process-exposed' to manipulate
5146 Optional START and END indicate bounds of region.
5148 optional arg, FORMAT, designates an alternate presentation form for
5151 list - Present prefix as numeric section.subsection..., starting with
5152 section indicated by the list, innermost nesting first.
5153 `indent' \(symbol) - Convert header prefixes to all white space,
5154 except for distinctive bullets.
5156 The elements of the list produced are lists that represents a topic
5157 header and body. The elements of that list are:
5159 - a number representing the depth of the topic,
5160 - a string representing the header-prefix, including trailing whitespace and
5162 - a string representing the bullet character,
5163 - and a series of strings, each containing one line of the exposed
5164 portion of the topic entry."
5169 ((inhibit-field-text-motion t)
5171 strings prefix result depth new-depth out gone-out bullet beg
5176 ;; Goto initial topic, and register preceeding stuff, if any:
5177 (if (> (allout-goto-prefix-doublechecked) start)
5178 ;; First topic follows beginning point - register preliminary stuff:
5179 (setq result (list (list 0 "" nil
5180 (buffer-substring start (1- (point)))))))
5181 (while (and (not done)
5182 (not (eobp)) ; Loop until we've covered the region.
5183 (not (> (point) end)))
5184 (setq depth allout-recent-depth ; Current topics depth,
5185 bullet (allout-recent-bullet) ; ... bullet,
5186 prefix (allout-recent-prefix)
5187 beg (progn (allout-end-of-prefix t) (point))) ; and beginning.
5188 (setq done ; The boundary for the current topic:
5189 (not (allout-next-visible-heading 1)))
5190 (setq new-depth allout-recent-depth)
5192 out (< new-depth depth))
5197 (while (> next (point)) ; Get all the exposed text in
5199 (cons (buffer-substring
5201 ;To hidden text or end of line:
5204 (allout-back-to-visible-text)))
5206 (when (< (point) next) ; Resume from after hid text, if any.
5208 (beginning-of-line))
5210 ;; Accumulate list for this topic:
5211 (setq strings (nreverse strings))
5215 (let ((special (if (string-match
5216 (regexp-quote bullet)
5217 allout-distinctive-bullets-string)
5219 (cond ((listp format)
5221 (if allout-abbreviate-flattened-numbering
5222 (allout-stringify-flat-index format
5224 (allout-stringify-flat-index-plain
5228 ((eq format 'indent)
5231 (concat (make-string (1+ depth) ? )
5232 (substring prefix -1))
5235 (make-string depth ? )
5237 (t (error "allout-listify-exposed: %s %s"
5238 "invalid format" format))))
5239 (list depth prefix strings))
5241 ;; Reasses format, if any:
5242 (if (and format (listp format))
5243 (cond ((= new-depth depth)
5244 (setq format (cons (1+ (car format))
5246 ((> new-depth depth) ; descending - assume by 1:
5247 (setq format (cons 1 format)))
5250 (while (< new-depth depth)
5251 (setq format (cdr format))
5252 (setq depth (1- depth)))
5253 ; And increment the current one:
5255 (cons (1+ (or (car format)
5258 ;; Put the list with first at front, to last at back:
5259 (nreverse result))))
5260 ;;;_ > my-region-active-p ()
5261 (defmacro my-region-active-p ()
5262 (if (fboundp 'region-active-p)
5265 ;;;_ > allout-process-exposed (&optional func from to frombuf
5267 (defun allout-process-exposed (&optional func from to frombuf tobuf
5269 "Map function on exposed parts of current topic; results to another buffer.
5271 All args are options; default values itemized below.
5273 Apply FUNCTION to exposed portions FROM position TO position in buffer
5274 FROMBUF to buffer TOBUF. Sixth optional arg, FORMAT, designates an
5275 alternate presentation form:
5277 `flat' - Present prefix as numeric section.subsection..., starting with
5278 section indicated by the start-num, innermost nesting first.
5279 X`flat-indented' - Prefix is like `flat' for first topic at each
5280 X level, but subsequent topics have only leaf topic
5281 X number, padded with blanks to line up with first.
5282 `indent' \(symbol) - Convert header prefixes to all white space,
5283 except for distinctive bullets.
5286 FUNCTION: `allout-insert-listified'
5287 FROM: region start, if region active, else start of buffer
5288 TO: region end, if region active, else end of buffer
5289 FROMBUF: current buffer
5290 TOBUF: buffer name derived: \"*current-buffer-name exposed*\"
5293 ; Resolve arguments,
5294 ; defaulting if necessary:
5295 (if (not func) (setq func 'allout-insert-listified))
5296 (if (not (and from to))
5297 (if (my-region-active-p)
5298 (setq from (region-beginning) to (region-end))
5299 (setq from (point-min) to (point-max))))
5301 (if (not (bufferp frombuf))
5302 ;; Specified but not a buffer - get it:
5303 (let ((got (get-buffer frombuf)))
5305 (error (concat "allout-process-exposed: source buffer "
5308 (setq frombuf got))))
5309 ;; not specified - default it:
5310 (setq frombuf (current-buffer)))
5312 (if (not (bufferp tobuf))
5313 (setq tobuf (get-buffer-create tobuf)))
5314 ;; not specified - default it:
5315 (setq tobuf (concat "*" (buffer-name frombuf) " exposed*")))
5320 (progn (set-buffer frombuf)
5321 (allout-listify-exposed from to format))))
5323 (mapcar func listified)
5324 (pop-to-buffer tobuf)))
5327 ;;;_ > allout-insert-listified (listified)
5328 (defun allout-insert-listified (listified)
5329 "Insert contents of listified outline portion in current buffer.
5331 LISTIFIED is a list representing each topic header and body:
5333 \`(depth prefix text)'
5335 or \`(depth prefix text bullet-plus)'
5337 If `bullet-plus' is specified, it is inserted just after the entire prefix."
5338 (setq listified (cdr listified))
5339 (let ((prefix (prog1
5341 (setq listified (cdr listified))))
5344 (setq listified (cdr listified))))
5345 (bullet-plus (car listified)))
5347 (if bullet-plus (insert (concat " " bullet-plus)))
5350 (if (setq text (cdr text))
5353 ;;;_ > allout-copy-exposed-to-buffer (&optional arg tobuf format)
5354 (defun allout-copy-exposed-to-buffer (&optional arg tobuf format)
5355 "Duplicate exposed portions of current outline to another buffer.
5357 Other buffer has current buffers name with \" exposed\" appended to it.
5359 With repeat count, copy the exposed parts of only the current topic.
5361 Optional second arg TOBUF is target buffer name.
5363 Optional third arg FORMAT, if non-nil, symbolically designates an
5364 alternate presentation format for the outline:
5366 `flat' - Convert topic header prefixes to numeric
5367 section.subsection... identifiers.
5368 `indent' - Convert header prefixes to all white space, except for
5369 distinctive bullets.
5370 `indent-flat' - The best of both - only the first of each level has
5371 the full path, the rest have only the section number
5372 of the leaf, preceded by the right amount of indentation."
5376 (setq tobuf (get-buffer-create (concat "*" (buffer-name) " exposed*"))))
5377 (let* ((start-pt (point))
5378 (beg (if arg (allout-back-to-current-heading) (point-min)))
5379 (end (if arg (allout-end-of-current-subtree) (point-max)))
5380 (buf (current-buffer))
5382 (if (eq format 'flat)
5383 (setq format (if arg (save-excursion
5385 (allout-topic-flat-index))
5387 (save-excursion (set-buffer tobuf)(erase-buffer))
5388 (allout-process-exposed 'allout-insert-listified
5394 (goto-char (point-min))
5396 (goto-char start-pt)))
5397 ;;;_ > allout-flatten-exposed-to-buffer (&optional arg tobuf)
5398 (defun allout-flatten-exposed-to-buffer (&optional arg tobuf)
5399 "Present numeric outline of outline's exposed portions in another buffer.
5401 The resulting outline is not compatible with outline mode - use
5402 `allout-copy-exposed-to-buffer' if you want that.
5404 Use `allout-indented-exposed-to-buffer' for indented presentation.
5406 With repeat count, copy the exposed portions of only current topic.
5408 Other buffer has current buffer's name with \" exposed\" appended to
5409 it, unless optional second arg TOBUF is specified, in which case it is
5412 (allout-copy-exposed-to-buffer arg tobuf 'flat))
5413 ;;;_ > allout-indented-exposed-to-buffer (&optional arg tobuf)
5414 (defun allout-indented-exposed-to-buffer (&optional arg tobuf)
5415 "Present indented outline of outline's exposed portions in another buffer.
5417 The resulting outline is not compatible with outline mode - use
5418 `allout-copy-exposed-to-buffer' if you want that.
5420 Use `allout-flatten-exposed-to-buffer' for numeric sectional presentation.
5422 With repeat count, copy the exposed portions of only current topic.
5424 Other buffer has current buffer's name with \" exposed\" appended to
5425 it, unless optional second arg TOBUF is specified, in which case it is
5428 (allout-copy-exposed-to-buffer arg tobuf 'indent))
5430 ;;;_ - LaTeX formatting
5431 ;;;_ > allout-latex-verb-quote (string &optional flow)
5432 (defun allout-latex-verb-quote (string &optional flow)
5433 "Return copy of STRING for literal reproduction across LaTeX processing.
5434 Expresses the original characters \(including carriage returns) of the
5435 string across LaTeX processing."
5436 (mapconcat (function
5438 (cond ((memq char '(?\\ ?$ ?% ?# ?& ?{ ?} ?_ ?^ ?- ?*))
5439 (concat "\\char" (number-to-string char) "{}"))
5440 ((= char ?\n) "\\\\")
5441 (t (char-to-string char)))))
5444 ;;;_ > allout-latex-verbatim-quote-curr-line ()
5445 (defun allout-latex-verbatim-quote-curr-line ()
5446 "Express line for exact \(literal) representation across LaTeX processing.
5448 Adjust line contents so it is unaltered \(from the original line)
5449 across LaTeX processing, within the context of a `verbatim'
5450 environment. Leaves point at the end of the line."
5451 (let ((inhibit-field-text-motion t))
5454 (end (progn (end-of-line)(point))))
5456 (while (re-search-forward "\\\\"
5457 ;;"\\\\\\|\\{\\|\\}\\|\\_\\|\\$\\|\\\"\\|\\&\\|\\^\\|\\-\\|\\*\\|#"
5458 end ; bounded by end-of-line
5459 1) ; no matches, move to end & return nil
5460 (goto-char (match-beginning 2))
5463 (goto-char (1+ (match-end 2)))))))
5464 ;;;_ > allout-insert-latex-header (buffer)
5465 (defun allout-insert-latex-header (buffer)
5466 "Insert initial LaTeX commands at point in BUFFER."
5467 ;; Much of this is being derived from the stuff in appendix of E in
5468 ;; the TeXBook, pg 421.
5470 (let ((doc-style (format "\n\\documentstyle{%s}\n"
5472 (page-numbering (if allout-number-pages
5473 "\\pagestyle{empty}\n"
5475 (titlecmd (format "\\newcommand{\\titlecmd}[1]{{%s #1}}\n"
5476 allout-title-style))
5477 (labelcmd (format "\\newcommand{\\labelcmd}[1]{{%s #1}}\n"
5478 allout-label-style))
5479 (headlinecmd (format "\\newcommand{\\headlinecmd}[1]{{%s #1}}\n"
5480 allout-head-line-style))
5481 (bodylinecmd (format "\\newcommand{\\bodylinecmd}[1]{{%s #1}}\n"
5482 allout-body-line-style))
5483 (setlength (format "%s%s%s%s"
5484 "\\newlength{\\stepsize}\n"
5485 "\\setlength{\\stepsize}{"
5488 (oneheadline (format "%s%s%s%s%s%s%s"
5489 "\\newcommand{\\OneHeadLine}[3]{%\n"
5491 "\\hspace*{#2\\stepsize}%\n"
5492 "\\labelcmd{#1}\\hspace*{.2cm}"
5493 "\\headlinecmd{#3}\\\\["
5496 (onebodyline (format "%s%s%s%s%s%s"
5497 "\\newcommand{\\OneBodyLine}[2]{%\n"
5499 "\\hspace*{#1\\stepsize}%\n"
5500 "\\bodylinecmd{#2}\\\\["
5503 (begindoc "\\begin{document}\n\\begin{center}\n")
5504 (title (format "%s%s%s%s"
5506 (allout-latex-verb-quote (if allout-title
5509 (error "<unnamed buffer>"))
5512 "\\end{center}\n\n"))
5513 (hsize "\\hsize = 7.5 true in\n")
5514 (hoffset "\\hoffset = -1.5 true in\n")
5515 (vspace "\\vspace{.1cm}\n\n"))
5516 (insert (concat doc-style
5531 ;;;_ > allout-insert-latex-trailer (buffer)
5532 (defun allout-insert-latex-trailer (buffer)
5533 "Insert concluding LaTeX commands at point in BUFFER."
5535 (insert "\n\\end{document}\n"))
5536 ;;;_ > allout-latexify-one-item (depth prefix bullet text)
5537 (defun allout-latexify-one-item (depth prefix bullet text)
5538 "Insert LaTeX commands for formatting one outline item.
5540 Args are the topics numeric DEPTH, the header PREFIX lead string, the
5541 BULLET string, and a list of TEXT strings for the body."
5542 (let* ((head-line (if text (car text)))
5543 (body-lines (cdr text))
5547 (insert (concat "\\OneHeadLine{\\verb\1 "
5548 (allout-latex-verb-quote bullet)
5553 (allout-latex-verb-quote head-line)
5556 (if (not body-lines)
5558 ;;(insert "\\beginlines\n")
5559 (insert "\\begin{verbatim}\n")
5561 (setq curr-line (car body-lines))
5562 (if (and (not body-content)
5563 (not (string-match "^\\s-*$" curr-line)))
5564 (setq body-content t))
5565 ; Mangle any occurrences of
5566 ; "\end{verbatim}" in text,
5568 (if (and body-content
5569 (setq bop (string-match "\\end{verbatim}" curr-line)))
5570 (setq curr-line (concat (substring curr-line 0 bop)
5572 (substring curr-line bop))))
5573 ;;(insert "|" (car body-lines) "|")
5575 (allout-latex-verbatim-quote-curr-line)
5577 (setq body-lines (cdr body-lines)))
5579 (setq body-content nil)
5583 ;;(insert "\\endlines\n")
5584 (insert "\\end{verbatim}\n")
5586 ;;;_ > allout-latexify-exposed (arg &optional tobuf)
5587 (defun allout-latexify-exposed (arg &optional tobuf)
5588 "Format current topics exposed portions to TOBUF for LaTeX processing.
5589 TOBUF defaults to a buffer named the same as the current buffer, but
5590 with \"*\" prepended and \" latex-formed*\" appended.
5592 With repeat count, copy the exposed portions of entire buffer."
5597 (get-buffer-create (concat "*" (buffer-name) " latexified*"))))
5598 (let* ((start-pt (point))
5599 (beg (if arg (point-min) (allout-back-to-current-heading)))
5600 (end (if arg (point-max) (allout-end-of-current-subtree)))
5601 (buf (current-buffer)))
5604 (allout-insert-latex-header tobuf)
5605 (goto-char (point-max))
5606 (allout-process-exposed 'allout-latexify-one-item
5611 (goto-char (point-max))
5612 (allout-insert-latex-trailer tobuf)
5613 (goto-char (point-min))
5615 (goto-char start-pt)))
5618 ;;;_ > allout-toggle-current-subtree-encryption (&optional fetch-pass)
5619 (defun allout-toggle-current-subtree-encryption (&optional fetch-pass)
5620 "Encrypt clear or decrypt encoded text of visibly-containing topic's contents.
5622 Optional FETCH-PASS universal argument provokes key-pair encryption with
5623 single universal argument. With doubled universal argument \(value = 16),
5624 it forces prompting for the passphrase regardless of availability from the
5625 passphrase cache. With no universal argument, the appropriate passphrase
5626 is obtained from the cache, if available, else from the user.
5628 Currently only GnuPG encryption is supported.
5630 \**NOTE WELL** that the encrypted text must be ascii-armored. For gnupg
5631 encryption, include the option ``armor'' in your ~/.gnupg/gpg.conf file.
5633 Both symmetric-key and key-pair encryption is implemented. Symmetric is
5634 the default, use a single \(x4) universal argument for keypair mode.
5636 Encrypted topic's bullet is set to a `~' to signal that the contents of the
5637 topic \(body and subtopics, but not heading) is pending encryption or
5638 encrypted. `*' asterisk immediately after the bullet signals that the body
5639 is encrypted, its' absence means the topic is meant to be encrypted but is
5640 not. When a file with topics pending encryption is saved, topics pending
5641 encryption are encrypted. See allout-encrypt-unencrypted-on-saves for
5642 auto-encryption specifics.
5644 \**NOTE WELL** that automatic encryption that happens during saves will
5645 default to symmetric encryption - you must manually \(re)encrypt key-pair
5646 encrypted topics if you want them to continue to use the key-pair cipher.
5648 Level-one topics, with prefix consisting solely of an `*' asterisk, cannot be
5649 encrypted. If you want to encrypt the contents of a top-level topic, use
5650 \\[allout-shift-in] to increase its depth.
5654 The encryption passphrase is solicited if not currently available in the
5655 passphrase cache from a recent encryption action.
5657 The solicited passphrase is retained for reuse in a buffer-specific cache
5658 for some set period of time \(default, 60 seconds), after which the string
5659 is nulled. The passphrase cache timeout is customized by setting
5660 `pgg-passphrase-cache-expiry'.
5662 Symmetric Passphrase Hinting and Verification
5664 If the file previously had no associated passphrase, or had a different
5665 passphrase than specified, the user is prompted to repeat the new one for
5666 corroboration. A random string encrypted by the new passphrase is set on
5667 the buffer-specific variable `allout-passphrase-verifier-string', for
5668 confirmation of the passphrase when next obtained, before encrypting or
5669 decrypting anything with it. This helps avoid mistakenly shifting between
5672 If allout customization var `allout-passphrase-verifier-handling' is
5673 non-nil, an entry for `allout-passphrase-verifier-string' and its value is
5674 added to an Emacs 'local variables' section at the end of the file, which
5675 is created if necessary. That setting is for retention of the passphrase
5676 verifier across emacs sessions.
5678 Similarly, `allout-passphrase-hint-string' stores a user-provided reminder
5679 about their passphrase, and `allout-passphrase-hint-handling' specifies
5680 when the hint is presented, or if passphrase hints are disabled. If
5681 enabled \(see the `allout-passphrase-hint-handling' docstring for details),
5682 the hint string is stored in the local-variables section of the file, and
5683 solicited whenever the passphrase is changed."
5686 (allout-back-to-current-heading)
5687 (allout-toggle-subtree-encryption fetch-pass)
5690 ;;;_ > allout-toggle-subtree-encryption (&optional fetch-pass)
5691 (defun allout-toggle-subtree-encryption (&optional fetch-pass)
5692 "Encrypt clear text or decrypt encoded topic contents \(body and subtopics.)
5694 Optional FETCH-PASS universal argument provokes key-pair encryption with
5695 single universal argument. With doubled universal argument \(value = 16),
5696 it forces prompting for the passphrase regardless of availability from the
5697 passphrase cache. With no universal argument, the appropriate passphrase
5698 is obtained from the cache, if available, else from the user.
5700 Currently only GnuPG encryption is supported.
5702 \**NOTE WELL** that the encrypted text must be ascii-armored. For gnupg
5703 encryption, include the option ``armor'' in your ~/.gnupg/gpg.conf file.
5705 See `allout-toggle-current-subtree-encryption' for more details."
5709 (allout-end-of-prefix t)
5711 (if (= allout-recent-depth 1)
5712 (error (concat "Cannot encrypt or decrypt level 1 topics -"
5713 " shift it in to make it encryptable")))
5715 (let* ((allout-buffer (current-buffer))
5717 (bullet-pos allout-recent-prefix-beginning)
5718 (after-bullet-pos (point))
5720 (progn (if (= (point-max) after-bullet-pos)
5721 (error "no body to encrypt"))
5722 (allout-encrypted-topic-p)))
5723 (was-collapsed (if (not (search-forward "\n" nil t))
5727 (subtree-beg (1+ (point)))
5728 (subtree-end (allout-end-of-subtree))
5729 (subject-text (buffer-substring-no-properties subtree-beg
5731 (subtree-end-char (char-after (1- subtree-end)))
5732 (subtree-trailing-char (char-after subtree-end))
5733 ;; kluge - result-text needs to be nil, but we also want to
5734 ;; check for the error condition
5735 (result-text (if (or (string= "" subject-text)
5736 (string= "\n" subject-text))
5737 (error "No topic contents to %scrypt"
5738 (if was-encrypted "de" "en"))
5740 ;; Assess key parameters:
5742 ;; detect the type by which it is already encrypted
5744 (allout-encrypted-key-info subject-text))
5745 (and (member fetch-pass '(4 (4)))
5748 (for-key-type (car key-info))
5749 (for-key-identity (cadr key-info))
5750 (fetch-pass (and fetch-pass (member fetch-pass '(16 (16))))))
5753 (allout-encrypt-string subject-text was-encrypted
5755 for-key-type for-key-identity fetch-pass))
5757 ;; Replace the subtree with the processed product.
5760 (set-buffer allout-buffer)
5761 (delete-region subtree-beg subtree-end)
5762 (insert result-text)
5764 (allout-flag-region (1- subtree-beg) (point) t))
5765 ;; adjust trailing-blank-lines to preserve topic spacing:
5766 (if (not was-encrypted)
5767 (if (and (= subtree-end-char ?\n)
5768 (= subtree-trailing-char ?\n))
5769 (insert subtree-trailing-char)))
5770 ;; Ensure that the item has an encrypted-entry bullet:
5771 (if (not (string= (buffer-substring-no-properties
5772 (1- after-bullet-pos) after-bullet-pos)
5773 allout-topic-encryption-bullet))
5774 (progn (goto-char (1- after-bullet-pos))
5776 (insert allout-topic-encryption-bullet)))
5778 ;; Remove the is-encrypted bullet qualifier:
5779 (progn (goto-char after-bullet-pos)
5781 ;; Add the is-encrypted bullet qualifier:
5782 (goto-char after-bullet-pos)
5784 (run-hook-with-args 'allout-structure-added-hook
5785 bullet-pos subtree-end))))
5786 ;;;_ > allout-encrypt-string (text decrypt allout-buffer key-type for-key
5787 ;;; fetch-pass &optional retried verifying
5789 (defun allout-encrypt-string (text decrypt allout-buffer key-type for-key
5790 fetch-pass &optional retried rejected
5791 verifying passphrase)
5792 "Encrypt or decrypt message TEXT.
5794 If DECRYPT is true (default false), then decrypt instead of encrypt.
5796 FETCH-PASS (default false) forces fresh prompting for the passphrase.
5798 KEY-TYPE indicates whether to use a 'symmetric or 'keypair cipher.
5800 FOR-KEY is human readable identification of the first of the user's
5801 eligible secret keys a keypair decryption targets, or else nil.
5803 Optional RETRIED is for internal use - conveys the number of failed keys
5804 that have been solicited in sequence leading to this current call.
5806 Optional PASSPHRASE enables explicit delivery of the decryption passphrase,
5807 for verification purposes.
5809 Optional REJECTED is for internal use - conveys the number of
5810 rejections due to matches against
5811 `allout-encryption-ciphertext-rejection-regexps', as limited by
5812 `allout-encryption-ciphertext-rejection-ceiling'.
5814 Returns the resulting string, or nil if the transformation fails."
5818 (if (not (fboundp 'pgg-encrypt-symmetric))
5819 (error "Allout encryption depends on a newer version of pgg"))
5821 (let* ((scheme (upcase
5822 (format "%s" (or pgg-scheme pgg-default-scheme "GPG"))))
5823 (for-key (and (equal key-type 'keypair)
5825 (split-string (read-string
5826 (format "%s message recipients: "
5829 (target-prompt-id (if (equal key-type 'keypair)
5830 (if (= (length for-key) 1)
5831 (car for-key) for-key)
5832 (buffer-name allout-buffer)))
5833 (target-cache-id (format "%s-%s"
5835 (if (equal key-type 'keypair)
5837 (or (buffer-file-name allout-buffer)
5838 target-prompt-id))))
5839 (strip-plaintext-regexps
5841 (allout-get-configvar-values
5842 'allout-encryption-plaintext-sanitization-regexps)))
5843 (reject-ciphertext-regexps
5845 (allout-get-configvar-values
5846 'allout-encryption-ciphertext-rejection-regexps)))
5847 (rejected (or rejected 0))
5848 (rejections-left (- allout-encryption-ciphertext-rejection-ceiling
5852 (if (and fetch-pass (not passphrase))
5853 ;; Force later fetch by evicting passphrase from the cache.
5854 (pgg-remove-passphrase-from-cache target-cache-id t))
5856 (catch 'encryption-failed
5858 ;; Obtain the passphrase if we don't already have one and we're not
5859 ;; doing a keypair encryption:
5860 (if (not (or passphrase
5861 (and (equal key-type 'keypair)
5864 (setq passphrase (allout-obtain-passphrase for-key
5869 retried fetch-pass)))
5875 (when (and strip-plaintext-regexps (not decrypt))
5876 (dolist (re strip-plaintext-regexps)
5877 (let ((re (if (listp re) (car re) re))
5878 (replacement (if (listp re) (cadr re) "")))
5879 (goto-char (point-min))
5880 (while (re-search-forward re nil t)
5881 (replace-match replacement nil nil)))))
5886 ((equal key-type 'symmetric)
5890 (pgg-decrypt (point-min) (point-max) passphrase)
5892 (pgg-encrypt-symmetric (point-min) (point-max)
5896 (pgg-situate-output (point-min) (point-max))
5897 ;; failed - handle passphrase caching
5899 (throw 'encryption-failed nil)
5900 (pgg-remove-passphrase-from-cache target-cache-id t)
5901 (error "Symmetric-cipher %scryption failed - %s"
5902 (if decrypt "de" "en")
5903 "try again with different passphrase."))))
5905 ;; encrypt 'keypair:
5910 (pgg-encrypt for-key
5911 nil (point-min) (point-max) passphrase))
5914 (pgg-situate-output (point-min) (point-max))
5915 (error (pgg-remove-passphrase-from-cache target-cache-id t)
5916 (error "encryption failed"))))
5918 ;; decrypt 'keypair:
5922 (pgg-decrypt (point-min) (point-max) passphrase))
5925 (pgg-situate-output (point-min) (point-max))
5926 (error (pgg-remove-passphrase-from-cache target-cache-id t)
5927 (error "decryption failed")))))
5930 (buffer-substring-no-properties
5931 1 (- (point-max) (if decrypt 0 1))))
5934 ;; validate result - non-empty
5935 (cond ((not result-text)
5938 ;; transform was fruitless, retry w/new passphrase.
5939 (pgg-remove-passphrase-from-cache target-cache-id t)
5940 (allout-encrypt-string text decrypt allout-buffer
5941 key-type for-key nil
5942 (if retried (1+ retried) 1)
5943 rejected verifying nil)))
5945 ;; Retry (within limit) if ciphertext contains rejections:
5947 ;; Check for disqualification of this ciphertext:
5948 (let ((regexps reject-ciphertext-regexps)
5950 (while (and regexps (not reject-it))
5951 (setq reject-it (string-match (car regexps)
5955 (setq rejections-left (1- rejections-left))
5956 (if (<= rejections-left 0)
5957 (error (concat "Ciphertext rejected too many times"
5959 allout-encryption-ciphertext-rejection-ceiling
5960 'allout-encryption-ciphertext-rejection-regexps)
5961 (allout-encrypt-string text decrypt allout-buffer
5962 key-type for-key nil
5963 retried (1+ rejected)
5964 verifying passphrase)))
5965 ;; Barf if encryption yields extraordinary control chars:
5967 (string-match "[\C-a\C-k\C-o-\C-z\C-@]"
5969 (error (concat "Encryption produced non-armored text, which"
5970 "conflicts with allout mode - reconfigure!")))
5972 ;; valid result and just verifying or non-symmetric:
5973 ((or verifying (not (equal key-type 'symmetric)))
5974 (if (or verifying decrypt)
5975 (pgg-add-passphrase-to-cache target-cache-id
5979 ;; valid result and regular symmetric - "register"
5980 ;; passphrase with mnemonic aids/cache.
5982 (set-buffer allout-buffer)
5984 (pgg-add-passphrase-to-cache target-cache-id
5986 (allout-update-passphrase-mnemonic-aids for-key passphrase
5993 ;;;_ > allout-obtain-passphrase (for-key cache-id prompt-id key-type
5994 ;;; allout-buffer retried fetch-pass)
5995 (defun allout-obtain-passphrase (for-key cache-id prompt-id key-type
5996 allout-buffer retried fetch-pass)
5997 "Obtain passphrase for a key from the cache or else from the user.
5999 When obtaining from the user, symmetric-cipher passphrases are verified
6000 against either, if available and enabled, a random string that was
6001 encrypted against the passphrase, or else against repeated entry by the
6002 user for corroboration.
6004 FOR-KEY is the key for which the passphrase is being obtained.
6006 CACHE-ID is the cache id of the key for the passphrase.
6008 PROMPT-ID is the id for use when prompting the user.
6010 KEY-TYPE is either 'symmetric or 'keypair.
6012 ALLOUT-BUFFER is the buffer containing the entry being en/decrypted.
6014 RETRIED is the number of this attempt to obtain this passphrase.
6016 FETCH-PASS causes the passphrase to be solicited from the user, regardless
6017 of the availability of a cached copy."
6019 (if (not (equal key-type 'symmetric))
6020 ;; do regular passphrase read on non-symmetric passphrase:
6021 (pgg-read-passphrase (format "%s passphrase%s: "
6022 (upcase (format "%s" (or pgg-scheme
6026 (format " for %s" prompt-id)
6030 ;; Symmetric hereon:
6033 (set-buffer allout-buffer)
6034 (let* ((hint (if (and (not (string= allout-passphrase-hint-string ""))
6035 (or (equal allout-passphrase-hint-handling 'always)
6036 (and (equal allout-passphrase-hint-handling
6039 (format " [%s]" allout-passphrase-hint-string)
6041 (retry-message (if retried (format " (%s retry)" retried) ""))
6042 (prompt-sans-hint (format "'%s' symmetric passphrase%s: "
6043 prompt-id retry-message))
6044 (full-prompt (format "'%s' symmetric passphrase%s%s: "
6045 prompt-id hint retry-message))
6046 (prompt full-prompt)
6047 (verifier-string (allout-get-encryption-passphrase-verifier))
6049 (cached (and (not fetch-pass)
6050 (pgg-read-passphrase-from-cache cache-id t)))
6051 (got-pass (or cached
6052 (pgg-read-passphrase full-prompt cache-id t)))
6058 ;; Duplicate our handle on the passphrase so it's not clobbered by
6059 ;; deactivate-passwd memory clearing:
6060 (setq got-pass (copy-sequence got-pass))
6062 (cond (verifier-string
6063 (save-window-excursion
6064 (if (allout-encrypt-string verifier-string 'decrypt
6065 allout-buffer 'symmetric
6066 for-key nil 0 0 'verifying
6067 (copy-sequence got-pass))
6068 (setq confirmation (format "%s" got-pass))))
6070 (if (and (not confirmation)
6072 (concat "Passphrase differs from established"
6073 " - use new one instead? "))
6074 ;; deactivate password for subsequent
6077 (pgg-remove-passphrase-from-cache cache-id t)
6078 (setq prompt prompt-sans-hint)
6081 (progn (pgg-remove-passphrase-from-cache cache-id t)
6082 (error "Wrong passphrase."))))
6083 ;; No verifier string - force confirmation by repetition of
6084 ;; (new) passphrase:
6085 ((or fetch-pass (not cached))
6086 (pgg-remove-passphrase-from-cache cache-id t))))
6087 ;; confirmation vs new input - doing pgg-read-passphrase will do the
6088 ;; right thing, in either case:
6089 (if (not confirmation)
6091 (pgg-read-passphrase (concat prompt
6092 " ... confirm spelling: ")
6095 (if (equal got-pass confirmation)
6097 (if (yes-or-no-p (concat "spelling of original and"
6098 " confirmation differ - retry? "))
6099 (progn (setq retried (if retried (1+ retried) 1))
6100 (pgg-remove-passphrase-from-cache cache-id t)
6101 ;; recurse to this routine:
6102 (pgg-read-passphrase prompt-sans-hint cache-id t))
6103 (pgg-remove-passphrase-from-cache cache-id t)
6104 (error "Confirmation failed."))))))))
6105 ;;;_ > allout-encrypted-topic-p ()
6106 (defun allout-encrypted-topic-p ()
6107 "True if the current topic is encryptable and encrypted."
6109 (allout-end-of-prefix t)
6110 (and (string= (buffer-substring-no-properties (1- (point)) (point))
6111 allout-topic-encryption-bullet)
6115 ;;;_ > allout-encrypted-key-info (text)
6116 ;; XXX gpg-specific, alas
6117 (defun allout-encrypted-key-info (text)
6118 "Return a pair of the key type and identity of a recipient's secret key.
6120 The key type is one of 'symmetric or 'keypair.
6122 if 'keypair, and some of the user's secret keys are among those for which
6123 the message was encoded, return the identity of the first. otherwise,
6124 return nil for the second item of the pair.
6126 An error is raised if the text is not encrypted."
6127 (require 'pgg-parse)
6131 (let* ((parsed-armor (pgg-parse-armor-region (point-min) (point-max)))
6132 (type (if (pgg-gpg-symmetric-key-p parsed-armor)
6135 secret-keys first-secret-key for-key-owner)
6136 (if (equal type 'keypair)
6137 (setq secret-keys (pgg-gpg-lookup-all-secret-keys)
6138 first-secret-key (pgg-gpg-select-matching-key parsed-armor
6140 for-key-owner (and first-secret-key
6141 (pgg-gpg-lookup-key-owner
6142 first-secret-key))))
6143 (list type (pgg-gpg-key-id-from-key-owner for-key-owner))
6148 ;;;_ > allout-create-encryption-passphrase-verifier (passphrase)
6149 (defun allout-create-encryption-passphrase-verifier (passphrase)
6150 "Encrypt random message for later validation of symmetric key's passphrase."
6151 ;; use 20 random ascii characters, across the entire ascii range.
6153 (let ((spew (make-string 20 ?\0)))
6154 (dotimes (i (length spew))
6155 (aset spew i (1+ (random 254))))
6156 (allout-encrypt-string spew nil (current-buffer) 'symmetric
6157 nil nil 0 0 passphrase))
6159 ;;;_ > allout-update-passphrase-mnemonic-aids (for-key passphrase
6161 (defun allout-update-passphrase-mnemonic-aids (for-key passphrase
6163 "Update passphrase verifier and hint strings if necessary.
6165 See `allout-passphrase-verifier-string' and `allout-passphrase-hint-string'
6168 PASSPHRASE is the passphrase being mnemonicized
6170 OUTLINE-BUFFER is the buffer of the outline being adjusted.
6172 These are used to help the user keep track of the passphrase they use for
6173 symmetric encryption in the file.
6175 Behavior is governed by `allout-passphrase-verifier-handling',
6176 `allout-passphrase-hint-handling', and also, controlling whether the values
6177 are preserved on Emacs local file variables,
6178 `allout-enable-file-variable-adjustment'."
6180 ;; If passphrase doesn't agree with current verifier:
6181 ;; - adjust the verifier
6182 ;; - if passphrase hint handling is enabled, adjust the passphrase hint
6183 ;; - if file var settings are enabled, adjust the file vars
6185 (let* ((new-verifier-needed (not (allout-verify-passphrase
6186 for-key passphrase outline-buffer)))
6187 (new-verifier-string
6188 (if new-verifier-needed
6189 ;; Collapse to a single line and enclose in string quotes:
6190 (subst-char-in-string
6191 ?\n ?\C-a (allout-create-encryption-passphrase-verifier
6194 (when new-verifier-string
6195 ;; do the passphrase hint first, since it's interactive
6196 (when (and allout-passphrase-hint-handling
6197 (not (equal allout-passphrase-hint-handling 'disabled)))
6199 (read-from-minibuffer "Passphrase hint to jog your memory: "
6200 allout-passphrase-hint-string))
6201 (when (not (string= new-hint allout-passphrase-hint-string))
6202 (setq allout-passphrase-hint-string new-hint)
6203 (allout-adjust-file-variable "allout-passphrase-hint-string"
6204 allout-passphrase-hint-string)))
6205 (when allout-passphrase-verifier-handling
6206 (setq allout-passphrase-verifier-string new-verifier-string)
6207 (allout-adjust-file-variable "allout-passphrase-verifier-string"
6208 allout-passphrase-verifier-string))
6212 ;;;_ > allout-get-encryption-passphrase-verifier ()
6213 (defun allout-get-encryption-passphrase-verifier ()
6214 "Return text of the encrypt passphrase verifier, unmassaged, or nil if none.
6216 Derived from value of `allout-passphrase-verifier-string'."
6218 (let ((verifier-string (and (boundp 'allout-passphrase-verifier-string)
6219 allout-passphrase-verifier-string)))
6221 ;; Return it uncollapsed
6222 (subst-char-in-string ?\C-a ?\n verifier-string))
6225 ;;;_ > allout-verify-passphrase (key passphrase allout-buffer)
6226 (defun allout-verify-passphrase (key passphrase allout-buffer)
6227 "True if passphrase successfully decrypts verifier, nil otherwise.
6229 \"Otherwise\" includes absence of passphrase verifier."
6231 (set-buffer allout-buffer)
6232 (and (boundp 'allout-passphrase-verifier-string)
6233 allout-passphrase-verifier-string
6234 (allout-encrypt-string (allout-get-encryption-passphrase-verifier)
6235 'decrypt allout-buffer 'symmetric
6236 key nil 0 0 'verifying passphrase)
6238 ;;;_ > allout-next-topic-pending-encryption (&optional except-mark)
6239 (defun allout-next-topic-pending-encryption (&optional except-mark)
6240 "Return the point of the next topic pending encryption, or nil if none.
6242 EXCEPT-MARK identifies a point whose containing topics should be excluded
6243 from encryption. This supports 'except-current mode of
6244 `allout-encrypt-unencrypted-on-saves'.
6246 Such a topic has the allout-topic-encryption-bullet without an
6247 immediately following '*' that would mark the topic as being encrypted. It
6248 must also have content."
6249 (let (done got content-beg)
6252 (if (not (re-search-forward
6253 (format "\\(\\`\\|\n\\)%s *%s[^*]"
6254 (regexp-quote allout-header-prefix)
6255 (regexp-quote allout-topic-encryption-bullet))
6259 (goto-char (setq got (match-beginning 0)))
6260 (if (looking-at "\n")
6267 ((not (search-forward "\n"))
6276 (setq content-beg (point))
6278 (allout-end-of-subtree)
6279 (if (or (<= (point) content-beg)
6281 (<= content-beg except-mark)
6282 (>= (point) except-mark)))
6293 ;;;_ > allout-encrypt-decrypted (&optional except-mark)
6294 (defun allout-encrypt-decrypted (&optional except-mark)
6295 "Encrypt topics pending encryption except those containing exemption point.
6297 EXCEPT-MARK identifies a point whose containing topics should be excluded
6298 from encryption. This supports 'except-current mode of
6299 `allout-encrypt-unencrypted-on-saves'.
6301 If a topic that is currently being edited was encrypted, we return a list
6302 containing the location of the topic and the location of the cursor just
6303 before the topic was encrypted. This can be used, eg, to decrypt the topic
6304 and exactly resituate the cursor if this is being done as part of a file
6305 save. See `allout-encrypt-unencrypted-on-saves' for more info."
6309 (let* ((current-mark (point-marker))
6310 (current-mark-position (marker-position current-mark))
6313 editing-topic editing-point)
6314 (goto-char (point-min))
6315 (while (allout-next-topic-pending-encryption except-mark)
6316 (setq was-modified (buffer-modified-p))
6317 (when (save-excursion
6318 (and (boundp 'allout-encrypt-unencrypted-on-saves)
6319 allout-encrypt-unencrypted-on-saves
6320 (setq bo-subtree (re-search-forward "$"))
6321 (not (allout-hidden-p))
6322 (>= current-mark (point))
6323 (allout-end-of-current-subtree)
6324 (<= current-mark (point))))
6325 (setq editing-topic (point)
6326 ;; we had to wait for this 'til now so prior topics are
6327 ;; encrypted, any relevant text shifts are in place:
6328 editing-point (- current-mark-position
6329 (count-trailing-whitespace-region
6330 bo-subtree current-mark-position))))
6331 (allout-toggle-subtree-encryption)
6332 (if (not was-modified)
6333 (set-buffer-modified-p nil))
6335 (if (not was-modified)
6336 (set-buffer-modified-p nil))
6337 (if editing-topic (list editing-topic editing-point))
6342 ;;;_ #9 miscellaneous
6344 ;;;_ > outlineify-sticky ()
6345 ;; outlinify-sticky is correct spelling; provide this alias for sticklers:
6347 (defalias 'outlinify-sticky 'outlineify-sticky)
6349 (defun outlineify-sticky (&optional arg)
6350 "Activate outline mode and establish file var so it is started subsequently.
6352 See doc-string for `allout-layout' and `allout-init' for details on
6353 setup for auto-startup."
6360 (goto-char (point-min))
6361 (if (looking-at allout-regexp)
6363 (allout-open-topic 2)
6364 (insert (concat "Dummy outline topic header - see"
6365 "`allout-mode' docstring: `^Hm'."))
6366 (allout-adjust-file-variable
6367 "allout-layout" (or allout-layout '(-1 : 0))))))
6368 ;;;_ > allout-file-vars-section-data ()
6369 (defun allout-file-vars-section-data ()
6370 "Return data identifying the file-vars section, or nil if none.
6372 Returns list `(beginning-point prefix-string suffix-string)'."
6373 ;; minimally gleaned from emacs 21.4 files.el hack-local-variables function.
6374 (let (beg prefix suffix)
6376 (goto-char (point-max))
6377 (search-backward "\n\^L" (max (- (point-max) 3000) (point-min)) 'move)
6378 (if (let ((case-fold-search t))
6379 (not (search-forward "Local Variables:" nil t)))
6381 (setq beg (- (point) 16))
6382 (setq suffix (buffer-substring-no-properties
6384 (progn (if (search-forward "\n" nil t)
6387 (setq prefix (buffer-substring-no-properties
6388 (progn (if (search-backward "\n" nil t)
6392 (list beg prefix suffix))
6396 ;;;_ > allout-adjust-file-variable (varname value)
6397 (defun allout-adjust-file-variable (varname value)
6398 "Adjust the setting of an emacs file variable named VARNAME to VALUE.
6400 This activity is inhibited if either `enable-local-variables'
6401 `allout-enable-file-variable-adjustment' are nil.
6403 When enabled, an entry for the variable is created if not already present,
6404 or changed if established with a different value. The section for the file
6405 variables, itself, is created if not already present. When created, the
6406 section lines \(including the section line) exist as second-level topics in
6407 a top-level topic at the end of the file.
6409 enable-local-variables must be true for any of this to happen."
6410 (if (not (and enable-local-variables
6411 allout-enable-file-variable-adjustment))
6414 (let ((inhibit-field-text-motion t)
6415 (section-data (allout-file-vars-section-data))
6418 (setq beg (car section-data)
6419 prefix (cadr section-data)
6420 suffix (car (cddr section-data)))
6421 ;; create the section
6422 (goto-char (point-max))
6424 (allout-open-topic 0)
6426 (insert "Local emacs vars.\n")
6427 (allout-open-topic 1)
6430 prefix (buffer-substring-no-properties (progn
6435 (insert "Local variables:\n")
6436 (allout-open-topic 0)
6439 ;; look for existing entry or create one, leaving point for insertion
6442 (allout-show-to-offshoot)
6443 (if (search-forward (concat "\n" prefix varname ":") nil t)
6444 (let* ((value-beg (point))
6445 (line-end (progn (if (search-forward "\n" nil t)
6448 (value-end (- line-end (length suffix))))
6449 (if (> value-end value-beg)
6450 (delete-region value-beg value-end)))
6454 (insert (concat prefix varname ":")))
6455 (insert (format " %S%s" value suffix))
6460 ;;;_ > allout-get-configvar-values (varname)
6461 (defun allout-get-configvar-values (configvar-name)
6462 "Return a list of values of the symbols in list bound to CONFIGVAR-NAME.
6464 The user is prompted for removal of symbols that are unbound, and they
6465 otherwise are ignored.
6467 CONFIGVAR-NAME should be the name of the configuration variable,
6470 (let ((configvar-value (symbol-value configvar-name))
6472 (dolist (sym configvar-value)
6473 (if (not (boundp sym))
6474 (if (yes-or-no-p (format "%s entry `%s' is unbound - remove it? "
6475 configvar-name sym))
6476 (delq sym (symbol-value configvar-name)))
6477 (push (symbol-value sym) got)))
6480 ;;;_ > allout-mark-topic ()
6481 (defun allout-mark-topic ()
6482 "Put the region around topic currently containing point."
6484 (let ((inhibit-field-text-motion t))
6485 (beginning-of-line))
6486 (allout-goto-prefix-doublechecked)
6488 (allout-end-of-current-subtree)
6489 (exchange-point-and-mark))
6491 ;;;_ > solicit-char-in-string (prompt string &optional do-defaulting)
6492 (defun solicit-char-in-string (prompt string &optional do-defaulting)
6493 "Solicit (with first arg PROMPT) choice of a character from string STRING.
6495 Optional arg DO-DEFAULTING indicates to accept empty input (CR)."
6497 (let ((new-prompt prompt)
6501 (message "%s" new-prompt)
6503 ;; We do our own reading here, so we can circumvent, eg, special
6504 ;; treatment for `?' character. (Oughta use minibuffer keymap instead.)
6506 (char-to-string (let ((cursor-in-echo-area nil)) (read-char))))
6509 (cond ((string-match (regexp-quote got) string) got)
6510 ((and do-defaulting (string= got "\r"))
6511 ;; Return empty string to default:
6513 ((string= got "\C-g") (signal 'quit nil))
6515 (setq new-prompt (concat prompt
6521 ;; got something out of loop - return it:
6525 ;;;_ > regexp-sans-escapes (string)
6526 (defun regexp-sans-escapes (regexp &optional successive-backslashes)
6527 "Return a copy of REGEXP with all character escapes stripped out.
6529 Representations of actual backslashes - '\\\\\\\\' - are left as a
6532 Optional arg SUCCESSIVE-BACKSLASHES is used internally for recursion."
6534 (if (string= regexp "")
6536 ;; Set successive-backslashes to number if current char is
6537 ;; backslash, or else to nil:
6538 (setq successive-backslashes
6539 (if (= (aref regexp 0) ?\\)
6540 (if successive-backslashes (1+ successive-backslashes) 1)
6542 (if (or (not successive-backslashes) (= 2 successive-backslashes))
6543 ;; Include first char:
6544 (concat (substring regexp 0 1)
6545 (regexp-sans-escapes (substring regexp 1)))
6546 ;; Exclude first char, but maintain count:
6547 (regexp-sans-escapes (substring regexp 1) successive-backslashes))))
6548 ;;;_ > count-trailing-whitespace-region (beg end)
6549 (defun count-trailing-whitespace-region (beg end)
6550 "Return number of trailing whitespace chars between BEG and END.
6552 If BEG is bigger than END we return 0."
6558 (while (re-search-forward "[ ][ ]*$" end t)
6559 (goto-char (1+ (match-beginning 2)))
6560 (setq count (1+ count)))
6562 ;;;_ > allout-format-quote (string)
6563 (defun allout-format-quote (string)
6564 "Return a copy of string with all \"%\" characters doubled."
6566 (mapcar (lambda (char) (if (= char ?%) "%%" (char-to-string char)))
6569 ;;;_ > allout-flatten (list)
6570 (defun allout-flatten (list)
6571 "Return a list of all atoms in list."
6573 (cond ((null list) nil)
6574 ((atom (car list)) (cons (car list) (allout-flatten (cdr list))))
6575 (t (append (allout-flatten (car list)) (allout-flatten (cdr list))))))
6576 ;;;_ : Compatability:
6577 ;;;_ > allout-mark-marker to accommodate divergent emacsen:
6578 (defun allout-mark-marker (&optional force buffer)
6579 "Accommodate the different signature for `mark-marker' across Emacsen.
6581 XEmacs takes two optional args, while mainline GNU Emacs does not,
6582 so pass them along when appropriate."
6583 (if (featurep 'xemacs)
6584 (apply 'mark-marker force buffer)
6586 ;;;_ > subst-char-in-string if necessary
6587 (if (not (fboundp 'subst-char-in-string))
6588 (defun subst-char-in-string (fromchar tochar string &optional inplace)
6589 "Replace FROMCHAR with TOCHAR in STRING each time it occurs.
6590 Unless optional argument INPLACE is non-nil, return a new string."
6591 (let ((i (length string))
6592 (newstr (if inplace string (copy-sequence string))))
6595 (if (eq (aref newstr i) fromchar)
6596 (aset newstr i tochar)))
6598 ;;;_ > wholenump if necessary
6599 (if (not (fboundp 'wholenump))
6600 (defalias 'wholenump 'natnump))
6601 ;;;_ > remove-overlays if necessary
6602 (if (not (fboundp 'remove-overlays))
6603 (defun remove-overlays (&optional beg end name val)
6604 "Clear BEG and END of overlays whose property NAME has value VAL.
6605 Overlays might be moved and/or split.
6606 BEG and END default respectively to the beginning and end of buffer."
6607 (unless beg (setq beg (point-min)))
6608 (unless end (setq end (point-max)))
6610 (setq beg (prog1 end (setq end beg))))
6612 (dolist (o (overlays-in beg end))
6613 (when (eq (overlay-get o name) val)
6614 ;; Either push this overlay outside beg...end
6615 ;; or split it to exclude beg...end
6616 ;; or delete it entirely (if it is contained in beg...end).
6617 (if (< (overlay-start o) beg)
6618 (if (> (overlay-end o) end)
6620 (move-overlay (copy-overlay o)
6621 (overlay-start o) beg)
6622 (move-overlay o end (overlay-end o)))
6623 (move-overlay o (overlay-start o) beg))
6624 (if (> (overlay-end o) end)
6625 (move-overlay o end (overlay-end o))
6626 (delete-overlay o)))))))
6628 ;;;_ > copy-overlay if necessary - xemacs ~ 21.4
6629 (if (not (fboundp 'copy-overlay))
6630 (defun copy-overlay (o)
6631 "Return a copy of overlay O."
6632 (let ((o1 (make-overlay (overlay-start o) (overlay-end o)
6633 ;; FIXME: there's no easy way to find the
6634 ;; insertion-type of the two markers.
6635 (overlay-buffer o)))
6636 (props (overlay-properties o)))
6638 (overlay-put o1 (pop props) (pop props)))
6640 ;;;_ > add-to-invisibility-spec if necessary - xemacs ~ 21.4
6641 (if (not (fboundp 'add-to-invisibility-spec))
6642 (defun add-to-invisibility-spec (element)
6643 "Add ELEMENT to `buffer-invisibility-spec'.
6644 See documentation for `buffer-invisibility-spec' for the kind of elements
6646 (if (eq buffer-invisibility-spec t)
6647 (setq buffer-invisibility-spec (list t)))
6648 (setq buffer-invisibility-spec
6649 (cons element buffer-invisibility-spec))))
6650 ;;;_ > remove-from-invisibility-spec if necessary - xemacs ~ 21.4
6651 (if (not (fboundp 'remove-from-invisibility-spec))
6652 (defun remove-from-invisibility-spec (element)
6653 "Remove ELEMENT from `buffer-invisibility-spec'."
6654 (if (consp buffer-invisibility-spec)
6655 (setq buffer-invisibility-spec (delete element
6656 buffer-invisibility-spec)))))
6657 ;;;_ > move-beginning-of-line if necessary - older emacs, xemacs
6658 (if (not (fboundp 'move-beginning-of-line))
6659 (defun move-beginning-of-line (arg)
6660 "Move point to beginning of current line as displayed.
6661 \(This disregards invisible newlines such as those
6662 which are part of the text that an image rests on.)
6664 With argument ARG not nil or 1, move forward ARG - 1 lines first.
6665 If point reaches the beginning or end of buffer, it stops there.
6666 To ignore intangibility, bind `inhibit-point-motion-hooks' to t."
6668 (or arg (setq arg 1))
6670 (condition-case nil (line-move (1- arg)) (error nil)))
6672 ;; Move to beginning-of-line, ignoring fields and invisibles.
6673 (skip-chars-backward "^\n")
6674 (while (and (not (bobp)) (line-move-invisible-p (1- (point))))
6675 (goto-char (if (featurep 'xemacs)
6676 (previous-property-change (point))
6677 (previous-char-property-change (point))))
6678 (skip-chars-backward "^\n"))
6679 (vertical-motion 0))
6681 ;;;_ > move-end-of-line if necessary - older emacs, xemacs
6682 (if (not (fboundp 'move-end-of-line))
6683 (defun move-end-of-line (arg)
6684 "Move point to end of current line as displayed.
6685 \(This disregards invisible newlines such as those
6686 which are part of the text that an image rests on.)
6688 With argument ARG not nil or 1, move forward ARG - 1 lines first.
6689 If point reaches the beginning or end of buffer, it stops there.
6690 To ignore intangibility, bind `inhibit-point-motion-hooks' to t."
6692 (or arg (setq arg 1))
6697 (let ((goal-column 0))
6698 (and (condition-case nil
6699 (or (line-move arg) t)
6703 (while (and (not (bobp))
6704 (line-move-invisible-p (1- (point))))
6706 (previous-char-property-change (point))))
6710 (if (and (> (point) newpos)
6711 (eq (preceding-char) ?\n))
6713 (if (and (> (point) newpos) (not (eobp))
6714 (not (eq (following-char) ?\n)))
6715 ;; If we skipped something intangible
6716 ;; and now we're not really at eol,
6721 ;;;_ > line-move-invisible-p if necessary
6722 (if (not (fboundp 'line-move-invisible-p))
6723 (defun line-move-invisible-p (pos)
6724 "Return non-nil if the character after POS is currently invisible."
6726 (get-char-property pos 'invisible)))
6727 (if (eq buffer-invisibility-spec t)
6729 (or (memq prop buffer-invisibility-spec)
6730 (assq prop buffer-invisibility-spec))))))
6733 ;;;_ > allout-bullet-isearch (&optional bullet)
6734 (defun allout-bullet-isearch (&optional bullet)
6735 "Isearch \(regexp) for topic with bullet BULLET."
6738 (setq bullet (solicit-char-in-string
6739 "ISearch for topic with bullet: "
6740 (regexp-sans-escapes allout-bullets-string))))
6742 (let ((isearch-regexp t)
6743 (isearch-string (concat "^"
6744 allout-header-prefix
6747 (isearch-repeat 'forward)
6750 ;;;_ #11 Unit tests - this should be last item before "Provide"
6751 ;;;_ > allout-run-unit-tests ()
6752 (defun allout-run-unit-tests ()
6753 "Run the various allout unit tests."
6754 (message "Running allout tests...")
6755 (allout-test-resumptions)
6756 (message "Running allout tests... Done.")
6758 ;;;_ : test resumptions:
6759 ;;;_ > allout-tests-obliterate-variable (name)
6760 (defun allout-tests-obliterate-variable (name)
6761 "Completely unbind variable with NAME."
6762 (if (local-variable-p name) (kill-local-variable name))
6763 (while (boundp name) (makunbound name)))
6764 ;;;_ > allout-test-resumptions ()
6765 (defvar allout-tests-globally-unbound nil
6766 "Fodder for allout resumptions tests - defvar just for byte compiler.")
6767 (defvar allout-tests-globally-true nil
6768 "Fodder for allout resumptions tests - defvar just just for byte compiler.")
6769 (defvar allout-tests-locally-true nil
6770 "Fodder for allout resumptions tests - defvar just for byte compiler.")
6771 (defun allout-test-resumptions ()
6772 "Exercise allout resumptions."
6773 ;; for each resumption case, we also test that the right local/global
6774 ;; scopes are affected during resumption effects:
6776 ;; ensure that previously unbound variables return to the unbound state.
6778 (allout-tests-obliterate-variable 'allout-tests-globally-unbound)
6779 (allout-add-resumptions '(allout-tests-globally-unbound t))
6780 (assert (not (default-boundp 'allout-tests-globally-unbound)))
6781 (assert (local-variable-p 'allout-tests-globally-unbound))
6782 (assert (boundp 'allout-tests-globally-unbound))
6783 (assert (equal allout-tests-globally-unbound t))
6784 (allout-do-resumptions)
6785 (assert (not (local-variable-p 'allout-tests-globally-unbound)))
6786 (assert (not (boundp 'allout-tests-globally-unbound))))
6788 ;; ensure that variable with prior global value is resumed
6790 (allout-tests-obliterate-variable 'allout-tests-globally-true)
6791 (setq allout-tests-globally-true t)
6792 (allout-add-resumptions '(allout-tests-globally-true nil))
6793 (assert (equal (default-value 'allout-tests-globally-true) t))
6794 (assert (local-variable-p 'allout-tests-globally-true))
6795 (assert (equal allout-tests-globally-true nil))
6796 (allout-do-resumptions)
6797 (assert (not (local-variable-p 'allout-tests-globally-true)))
6798 (assert (boundp 'allout-tests-globally-true))
6799 (assert (equal allout-tests-globally-true t)))
6801 ;; ensure that prior local value is resumed
6803 (allout-tests-obliterate-variable 'allout-tests-locally-true)
6804 (set (make-local-variable 'allout-tests-locally-true) t)
6805 (assert (not (default-boundp 'allout-tests-locally-true))
6806 nil (concat "Test setup mistake - variable supposed to"
6807 " not have global binding, but it does."))
6808 (assert (local-variable-p 'allout-tests-locally-true)
6809 nil (concat "Test setup mistake - variable supposed to have"
6810 " local binding, but it lacks one."))
6811 (allout-add-resumptions '(allout-tests-locally-true nil))
6812 (assert (not (default-boundp 'allout-tests-locally-true)))
6813 (assert (local-variable-p 'allout-tests-locally-true))
6814 (assert (equal allout-tests-locally-true nil))
6815 (allout-do-resumptions)
6816 (assert (boundp 'allout-tests-locally-true))
6817 (assert (local-variable-p 'allout-tests-locally-true))
6818 (assert (equal allout-tests-locally-true t))
6819 (assert (not (default-boundp 'allout-tests-locally-true))))
6821 ;; ensure that last of multiple resumptions holds, for various scopes.
6823 (allout-tests-obliterate-variable 'allout-tests-globally-unbound)
6824 (allout-tests-obliterate-variable 'allout-tests-globally-true)
6825 (setq allout-tests-globally-true t)
6826 (allout-tests-obliterate-variable 'allout-tests-locally-true)
6827 (set (make-local-variable 'allout-tests-locally-true) t)
6828 (allout-add-resumptions '(allout-tests-globally-unbound t)
6829 '(allout-tests-globally-true nil)
6830 '(allout-tests-locally-true nil))
6831 (allout-add-resumptions '(allout-tests-globally-unbound 2)
6832 '(allout-tests-globally-true 3)
6833 '(allout-tests-locally-true 4))
6834 ;; reestablish many of the basic conditions are maintained after re-add:
6835 (assert (not (default-boundp 'allout-tests-globally-unbound)))
6836 (assert (local-variable-p 'allout-tests-globally-unbound))
6837 (assert (equal allout-tests-globally-unbound 2))
6838 (assert (default-boundp 'allout-tests-globally-true))
6839 (assert (local-variable-p 'allout-tests-globally-true))
6840 (assert (equal allout-tests-globally-true 3))
6841 (assert (not (default-boundp 'allout-tests-locally-true)))
6842 (assert (local-variable-p 'allout-tests-locally-true))
6843 (assert (equal allout-tests-locally-true 4))
6844 (allout-do-resumptions)
6845 (assert (not (local-variable-p 'allout-tests-globally-unbound)))
6846 (assert (not (boundp 'allout-tests-globally-unbound)))
6847 (assert (not (local-variable-p 'allout-tests-globally-true)))
6848 (assert (boundp 'allout-tests-globally-true))
6849 (assert (equal allout-tests-globally-true t))
6850 (assert (boundp 'allout-tests-locally-true))
6851 (assert (local-variable-p 'allout-tests-locally-true))
6852 (assert (equal allout-tests-locally-true t))
6853 (assert (not (default-boundp 'allout-tests-locally-true))))
6855 ;; ensure that deliberately unbinding registered variables doesn't foul things
6857 (allout-tests-obliterate-variable 'allout-tests-globally-unbound)
6858 (allout-tests-obliterate-variable 'allout-tests-globally-true)
6859 (setq allout-tests-globally-true t)
6860 (allout-tests-obliterate-variable 'allout-tests-locally-true)
6861 (set (make-local-variable 'allout-tests-locally-true) t)
6862 (allout-add-resumptions '(allout-tests-globally-unbound t)
6863 '(allout-tests-globally-true nil)
6864 '(allout-tests-locally-true nil))
6865 (allout-tests-obliterate-variable 'allout-tests-globally-unbound)
6866 (allout-tests-obliterate-variable 'allout-tests-globally-true)
6867 (allout-tests-obliterate-variable 'allout-tests-locally-true)
6868 (allout-do-resumptions))
6870 ;;;_ % Run unit tests if `allout-run-unit-tests-after-load' is true:
6871 (when allout-run-unit-tests-on-load
6872 (allout-run-unit-tests))
6877 ;;;_* Local emacs vars.
6878 ;; The following `allout-layout' local variable setting:
6879 ;; - closes all topics from the first topic to just before the third-to-last,
6880 ;; - shows the children of the third to last (config vars)
6881 ;; - and the second to last (code section),
6882 ;; - and closes the last topic (this local-variables section).
6884 ;;allout-layout: (0 : -1 -1 0)
6887 ;; arch-tag: cf38fbc3-c044-450f-8bff-afed8ba5681c
6888 ;;; allout.el ends here