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 2
895 "Validate 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.
902 A level of 2 is safest, so that yanks, which must ignore
903 aberrance while rectifying the yanked text to their new location,
904 is least likely to be fooled by aberrant topics in the yanked
906 ;;;_ X allout-reset-header-lead (header-lead)
907 (defun allout-reset-header-lead (header-lead)
908 "*Reset the leading string used to identify topic headers."
909 (interactive "sNew lead string: ")
910 (setq allout-header-prefix header-lead)
911 (setq allout-header-subtraction (1- (length allout-header-prefix)))
913 ;;;_ X allout-lead-with-comment-string (header-lead)
914 (defun allout-lead-with-comment-string (&optional header-lead)
915 "*Set the topic-header leading string to specified string.
917 Useful when for encapsulating outline structure in programming
918 language comments. Returns the leading string."
921 (if (not (stringp header-lead))
922 (setq header-lead (read-string
923 "String prefix for topic headers: ")))
924 (setq allout-reindent-bodies nil)
925 (allout-reset-header-lead header-lead)
927 ;;;_ > allout-infer-header-lead-and-primary-bullet ()
928 (defun allout-infer-header-lead-and-primary-bullet ()
929 "Determine appropriate `allout-header-prefix' and `allout-primary-bullet'.
931 Works according to settings of:
934 `allout-header-prefix' (default)
935 `allout-use-mode-specific-leader'
936 and `allout-mode-leaders'.
938 Apply this via \(re)activation of `allout-mode', rather than
939 invoking it directly."
940 (let* ((use-leader (and (boundp 'allout-use-mode-specific-leader)
941 (if (or (stringp allout-use-mode-specific-leader)
942 (memq allout-use-mode-specific-leader
943 '(allout-mode-leaders
946 allout-use-mode-specific-leader
947 ;; Oops - garbled value, equate with effect of 't:
951 ((not use-leader) nil)
952 ;; Use the explicitly designated leader:
953 ((stringp use-leader) use-leader)
954 (t (or (and (memq use-leader '(t allout-mode-leaders))
955 ;; Get it from outline mode leaders?
956 (cdr (assq major-mode allout-mode-leaders)))
957 ;; ... didn't get from allout-mode-leaders...
958 (and (memq use-leader '(t comment-start))
960 ;; Use comment-start, maybe tripled, and with
964 (substring comment-start
965 (1- (length comment-start))))
966 ;; Use comment-start, sans trailing space:
967 (substring comment-start 0 -1)
968 (concat comment-start comment-start comment-start))
969 ;; ... and append underscore, whichever:
973 (setq allout-header-prefix leader)
974 (if (not allout-old-style-prefixes)
975 ;; setting allout-primary-bullet makes the top level topics use -
976 ;; actually, be - the special prefix:
977 (setq allout-primary-bullet leader))
978 allout-header-prefix)))
979 (defalias 'allout-infer-header-lead
980 'allout-infer-header-lead-and-primary-bullet)
981 ;;;_ > allout-infer-body-reindent ()
982 (defun allout-infer-body-reindent ()
983 "Determine proper setting for `allout-reindent-bodies'.
985 Depends on default setting of `allout-reindent-bodies' \(which see)
986 and presence of setting for `comment-start', to tell whether the
987 file is programming code."
988 (if (and allout-reindent-bodies
990 (not (eq 'force allout-reindent-bodies)))
991 (setq allout-reindent-bodies nil)))
992 ;;;_ > set-allout-regexp ()
993 (defun set-allout-regexp ()
994 "Generate proper topic-header regexp form for outline functions.
996 Works with respect to `allout-plain-bullets-string' and
997 `allout-distinctive-bullets-string'.
999 Also refresh various data structures that hinge on the regexp."
1002 ;; Derive allout-bullets-string from user configured components:
1003 (setq allout-bullets-string "")
1004 (let ((strings (list 'allout-plain-bullets-string
1005 'allout-distinctive-bullets-string
1006 'allout-primary-bullet))
1013 (setq cur-len (length (setq cur-string (symbol-value (car strings)))))
1014 (while (< index cur-len)
1015 (setq cur-char (aref cur-string index))
1016 (setq allout-bullets-string
1017 (concat allout-bullets-string
1019 ; Single dash would denote a
1020 ; sequence, repeated denotes
1022 ((eq cur-char ?-) "--")
1023 ; literal close-square-bracket
1024 ; doesn't work right in the
1026 ((eq cur-char ?\]) "")
1027 (t (regexp-quote (char-to-string cur-char))))))
1028 (setq index (1+ index)))
1029 (setq strings (cdr strings)))
1031 ;; Derive next for repeated use in allout-pending-bullet:
1032 (setq allout-plain-bullets-string-len (length allout-plain-bullets-string))
1033 (setq allout-header-subtraction (1- (length allout-header-prefix)))
1035 (let (new-part old-part)
1036 (setq new-part (concat "\\("
1037 (regexp-quote allout-header-prefix)
1039 ;; already regexp-quoted in a custom way:
1040 "[" allout-bullets-string "]"
1042 old-part (concat "\\("
1043 (regexp-quote allout-primary-bullet)
1045 (regexp-quote allout-header-prefix)
1048 " ?[^" allout-primary-bullet "]")
1049 allout-regexp (concat new-part
1054 allout-line-boundary-regexp (concat "\n" new-part
1058 allout-bob-regexp (concat "\\`" new-part
1062 (setq allout-depth-specific-regexp
1063 (concat "\\(^\\|\\`\\)"
1066 ;; new-style spacers-then-bullet string:
1068 (allout-format-quote (regexp-quote allout-header-prefix))
1070 "[" (allout-format-quote allout-bullets-string) "]"
1073 ;; old-style all-bullets string, if primary not multi-char:
1074 (if (< 0 allout-header-subtraction)
1077 (allout-format-quote
1078 (regexp-quote allout-primary-bullet))
1079 (allout-format-quote
1080 (regexp-quote allout-primary-bullet))
1081 (allout-format-quote
1082 (regexp-quote allout-primary-bullet))
1084 ;; disqualify greater depths:
1086 (allout-format-quote allout-primary-bullet)
1091 (setq allout-depth-one-regexp
1092 (concat "\\(^\\|\\`\\)"
1096 (regexp-quote allout-header-prefix)
1097 ;; disqualify any bullet char following any amount of
1098 ;; intervening whitespace:
1100 (concat "[^ " allout-bullets-string "]")
1102 (if (< 0 allout-header-subtraction)
1103 ;; Need not support anything like the old
1104 ;; bullet style if the prefix is multi-char.
1107 (regexp-quote allout-primary-bullet)
1108 ;; disqualify deeper primary-bullet sequences:
1109 "[^" allout-primary-bullet "]"))
1113 ;;;_ = allout-mode-map
1114 (defvar allout-mode-map nil "Keybindings for (allout) outline minor mode.")
1115 ;;;_ > produce-allout-mode-map (keymap-alist &optional base-map)
1116 (defun produce-allout-mode-map (keymap-list &optional base-map)
1117 "Produce keymap for use as allout-mode-map, from KEYMAP-LIST.
1119 Built on top of optional BASE-MAP, or empty sparse map if none specified.
1120 See doc string for allout-keybindings-list for format of binding list."
1121 (let ((map (or base-map (make-sparse-keymap)))
1122 (pref (list allout-command-prefix)))
1125 (let ((add-pref (null (cdr (cdr cell))))
1126 (key-suff (list (car cell))))
1129 (apply 'concat (if add-pref
1130 (append pref key-suff)
1132 (car (cdr cell)))))))
1136 (defvar allout-mode-exposure-menu)
1137 (defvar allout-mode-editing-menu)
1138 (defvar allout-mode-navigation-menu)
1139 (defvar allout-mode-misc-menu)
1140 (defun produce-allout-mode-menubar-entries ()
1142 (easy-menu-define allout-mode-exposure-menu
1144 "Allout outline exposure menu."
1146 ["Show Entry" allout-show-current-entry t]
1147 ["Show Children" allout-show-children t]
1148 ["Show Subtree" allout-show-current-subtree t]
1149 ["Hide Subtree" allout-hide-current-subtree t]
1150 ["Hide Leaves" allout-hide-current-leaves t]
1152 ["Show All" allout-show-all t]))
1153 (easy-menu-define allout-mode-editing-menu
1155 "Allout outline editing menu."
1157 ["Open Sibling" allout-open-sibtopic t]
1158 ["Open Subtopic" allout-open-subtopic t]
1159 ["Open Supertopic" allout-open-supertopic t]
1161 ["Shift Topic In" allout-shift-in t]
1162 ["Shift Topic Out" allout-shift-out t]
1163 ["Rebullet Topic" allout-rebullet-topic t]
1164 ["Rebullet Heading" allout-rebullet-current-heading t]
1165 ["Number Siblings" allout-number-siblings t]
1167 ["Toggle Topic Encryption"
1168 allout-toggle-current-subtree-encryption
1169 (> (allout-current-depth) 1)]))
1170 (easy-menu-define allout-mode-navigation-menu
1172 "Allout outline navigation menu."
1174 ["Next Visible Heading" allout-next-visible-heading t]
1175 ["Previous Visible Heading"
1176 allout-previous-visible-heading t]
1178 ["Up Level" allout-up-current-level t]
1179 ["Forward Current Level" allout-forward-current-level t]
1180 ["Backward Current Level"
1181 allout-backward-current-level t]
1183 ["Beginning of Entry"
1184 allout-beginning-of-current-entry t]
1185 ["End of Entry" allout-end-of-entry t]
1186 ["End of Subtree" allout-end-of-current-subtree t]))
1187 (easy-menu-define allout-mode-misc-menu
1189 "Allout outlines miscellaneous bindings."
1191 ["Version" allout-version t]
1193 ["Duplicate Exposed" allout-copy-exposed-to-buffer t]
1194 ["Duplicate Exposed, numbered"
1195 allout-flatten-exposed-to-buffer t]
1196 ["Duplicate Exposed, indented"
1197 allout-indented-exposed-to-buffer t]
1199 ["Set Header Lead" allout-reset-header-lead t]
1200 ["Set New Exposure" allout-expose-topic t])))
1201 ;;;_ : Allout Modal-Variables Utilities
1202 ;;;_ = allout-mode-prior-settings
1203 (defvar allout-mode-prior-settings nil
1204 "Internal `allout-mode' use; settings to be resumed on mode deactivation.
1206 See `allout-add-resumptions' and `allout-do-resumptions'.")
1207 (make-variable-buffer-local 'allout-mode-prior-settings)
1208 ;;;_ > allout-add-resumptions (&rest pairs)
1209 (defun allout-add-resumptions (&rest pairs)
1210 "Set name/value PAIRS.
1212 Old settings are preserved for later resumption using `allout-do-resumptions'.
1214 The new values are set as a buffer local. On resumption, the prior buffer
1215 scope of the variable is restored along with its value. If it was a void
1216 buffer-local value, then it is left as nil on resumption.
1218 The pairs are lists whose car is the name of the variable and car of the
1219 cdr is the new value: '(some-var some-value)'. The pairs can actually be
1220 triples, where the third element qualifies the disposition of the setting,
1221 as described further below.
1223 If the optional third element is the symbol 'extend, then the new value
1224 created by `cons'ing the second element of the pair onto the front of the
1227 If the optional third element is the symbol 'append, then the new value is
1228 extended from the existing one by `append'ing a list containing the second
1229 element of the pair onto the end of the existing value.
1231 Extension, and resumptions in general, should not be used for hook
1232 functions - use the 'local mode of `add-hook' for that, instead.
1234 The settings are stored on `allout-mode-prior-settings'."
1236 (let* ((pair (pop pairs))
1239 (qualifier (if (> (length pair) 2)
1242 (if (not (symbolp name))
1243 (error "Pair's name, %S, must be a symbol, not %s"
1244 name (type-of name)))
1245 (setq prior-value (condition-case nil
1247 (void-variable nil)))
1248 (when (not (assoc name allout-mode-prior-settings))
1249 ;; Not already added as a resumption, create the prior setting entry.
1250 (if (local-variable-p name)
1251 ;; is already local variable - preserve the prior value:
1252 (push (list name prior-value) allout-mode-prior-settings)
1253 ;; wasn't local variable, indicate so for resumption by killing
1254 ;; local value, and make it local:
1255 (push (list name) allout-mode-prior-settings)
1256 (make-local-variable name)))
1258 (cond ((eq qualifier 'extend)
1259 (if (not (listp prior-value))
1260 (error "extension of non-list prior value attempted")
1261 (set name (cons value prior-value))))
1262 ((eq qualifier 'append)
1263 (if (not (listp prior-value))
1264 (error "appending of non-list prior value attempted")
1265 (set name (append prior-value (list value)))))
1266 (t (error "unrecognized setting qualifier `%s' encountered"
1268 (set name value)))))
1269 ;;;_ > allout-do-resumptions ()
1270 (defun allout-do-resumptions ()
1271 "Resume all name/value settings registered by `allout-add-resumptions'.
1273 This is used when concluding allout-mode, to resume selected variables to
1274 their settings before allout-mode was started."
1276 (while allout-mode-prior-settings
1277 (let* ((pair (pop allout-mode-prior-settings))
1279 (value-cell (cdr pair)))
1280 (if (not value-cell)
1281 ;; Prior value was global:
1282 (kill-local-variable name)
1283 ;; Prior value was explicit:
1284 (set name (car value-cell))))))
1285 ;;;_ : Mode-specific incidentals
1286 ;;;_ > allout-unprotected (expr)
1287 (defmacro allout-unprotected (expr)
1288 "Enable internal outline operations to alter invisible text."
1289 `(let ((inhibit-read-only (if (not buffer-read-only) t))
1290 (inhibit-field-text-motion t))
1292 ;;;_ = allout-mode-hook
1293 (defvar allout-mode-hook nil
1294 "*Hook that's run when allout mode starts.")
1295 ;;;_ = allout-mode-deactivate-hook
1296 (defvar allout-mode-deactivate-hook nil
1297 "*Hook that's run when allout mode ends.")
1298 ;;;_ = allout-exposure-category
1299 (defvar allout-exposure-category nil
1300 "Symbol for use as allout invisible-text overlay category.")
1301 ;;;_ x allout-view-change-hook
1302 (defvar allout-view-change-hook nil
1303 "*\(Deprecated\) A hook run after allout outline exposure changes.
1305 Switch to using `allout-exposure-change-hook' instead. Both hooks are
1306 currently respected, but the other conveys the details of the exposure
1307 change via explicit parameters, and this one will eventually be disabled in
1308 a subsequent allout version.")
1309 ;;;_ = allout-exposure-change-hook
1310 (defvar allout-exposure-change-hook nil
1311 "*Hook that's run after allout outline subtree exposure changes.
1313 It is run at the conclusion of `allout-flag-region'.
1315 Functions on the hook must take three arguments:
1317 - from - integer indicating the point at the start of the change.
1318 - to - integer indicating the point of the end of the change.
1319 - flag - change mode: nil for exposure, otherwise concealment.
1321 This hook might be invoked multiple times by a single command.
1323 This hook is replacing `allout-view-change-hook', which is being deprecated
1324 and eventually will not be invoked.")
1325 ;;;_ = allout-structure-added-hook
1326 (defvar allout-structure-added-hook nil
1327 "*Hook that's run after addition of items to the outline.
1329 Functions on the hook should take two arguments:
1331 - new-start - integer indicating the point at the start of the first new item.
1332 - new-end - integer indicating the point of the end of the last new item.
1334 Some edits that introduce new items may missed by this hook -
1335 specifically edits that native allout routines do not control.
1337 This hook might be invoked multiple times by a single command.")
1338 ;;;_ = allout-structure-deleted-hook
1339 (defvar allout-structure-deleted-hook nil
1340 "*Hook that's run after disciplined deletion of subtrees from the outline.
1342 Functions on the hook must take two arguments:
1344 - depth - integer indicating the depth of the subtree that was deleted.
1345 - removed-from - integer indicating the point where the subtree was removed.
1347 Some edits that remove or invalidate items may missed by this hook -
1348 specifically edits that native allout routines do not control.
1350 This hook might be invoked multiple times by a single command.")
1351 ;;;_ = allout-structure-shifted-hook
1352 (defvar allout-structure-shifted-hook nil
1353 "*Hook that's run after shifting of items in the outline.
1355 Functions on the hook should take two arguments:
1357 - depth-change - integer indicating depth increase, negative for decrease
1358 - start - integer indicating the start point of the shifted parent item.
1360 Some edits that shift items can be missed by this hook - specifically edits
1361 that native allout routines do not control.
1363 This hook might be invoked multiple times by a single command.")
1364 ;;;_ = allout-outside-normal-auto-fill-function
1365 (defvar allout-outside-normal-auto-fill-function nil
1366 "Value of normal-auto-fill-function outside of allout mode.
1368 Used by allout-auto-fill to do the mandated normal-auto-fill-function
1369 wrapped within allout's automatic fill-prefix setting.")
1370 (make-variable-buffer-local 'allout-outside-normal-auto-fill-function)
1371 ;;;_ = file-var-bug hack
1372 (defvar allout-v18/19-file-var-hack nil
1373 "Horrible hack used to prevent invalid multiple triggering of outline
1374 mode from prop-line file-var activation. Used by `allout-mode' function
1376 ;;;_ = allout-passphrase-verifier-string
1377 (defvar allout-passphrase-verifier-string nil
1378 "Setting used to test solicited encryption passphrases against the one
1379 already associated with a file.
1381 It consists of an encrypted random string useful only to verify that a
1382 passphrase entered by the user is effective for decryption. The passphrase
1383 itself is \*not* recorded in the file anywhere, and the encrypted contents
1384 are random binary characters to avoid exposing greater susceptibility to
1387 The verifier string is retained as an Emacs file variable, as well as in
1388 the Emacs buffer state, if file variable adjustments are enabled. See
1389 `allout-enable-file-variable-adjustment' for details about that.")
1390 (make-variable-buffer-local 'allout-passphrase-verifier-string)
1392 (put 'allout-passphrase-verifier-string 'safe-local-variable 'stringp)
1393 ;;;_ = allout-passphrase-hint-string
1394 (defvar allout-passphrase-hint-string ""
1395 "Variable used to retain reminder string for file's encryption passphrase.
1397 See the description of `allout-passphrase-hint-handling' for details about how
1398 the reminder is deployed.
1400 The hint is retained as an Emacs file variable, as well as in the Emacs buffer
1401 state, if file variable adjustments are enabled. See
1402 `allout-enable-file-variable-adjustment' for details about that.")
1403 (make-variable-buffer-local 'allout-passphrase-hint-string)
1404 (setq-default allout-passphrase-hint-string "")
1406 (put 'allout-passphrase-hint-string 'safe-local-variable 'stringp)
1407 ;;;_ = allout-after-save-decrypt
1408 (defvar allout-after-save-decrypt nil
1409 "Internal variable, is nil or has the value of two points:
1411 - the location of a topic to be decrypted after saving is done
1412 - where to situate the cursor after the decryption is performed
1414 This is used to decrypt the topic that was currently being edited, if it
1415 was encrypted automatically as part of a file write or autosave.")
1416 (make-variable-buffer-local 'allout-after-save-decrypt)
1417 ;;;_ = allout-encryption-plaintext-sanitization-regexps
1418 (defvar allout-encryption-plaintext-sanitization-regexps nil
1419 "List of regexps whose matches are removed from plaintext before encryption.
1421 This is for the sake of removing artifacts, like escapes, that are added on
1422 and not actually part of the original plaintext. The removal is done just
1423 prior to encryption.
1425 Entries must be symbols that are bound to the desired values.
1427 Each value can be a regexp or a list with a regexp followed by a
1428 substitution string. If it's just a regexp, all its matches are removed
1429 before the text is encrypted. If it's a regexp and a substitution, the
1430 substition is used against the regexp matches, a la `replace-match'.")
1431 (make-variable-buffer-local 'allout-encryption-text-removal-regexps)
1432 ;;;_ = allout-encryption-ciphertext-rejection-regexps
1433 (defvar allout-encryption-ciphertext-rejection-regexps nil
1434 "Variable for regexps matching plaintext to remove before encryption.
1436 This is for the sake of redoing encryption in cases where the ciphertext
1437 incidentally contains strings that would disrupt mode operation -
1438 for example, a line that happens to look like an allout-mode topic prefix.
1440 Entries must be symbols that are bound to the desired regexp values.
1442 The encryption will be retried up to
1443 `allout-encryption-ciphertext-rejection-limit' times, after which an error
1446 (make-variable-buffer-local 'allout-encryption-ciphertext-rejection-regexps)
1447 ;;;_ = allout-encryption-ciphertext-rejection-ceiling
1448 (defvar allout-encryption-ciphertext-rejection-ceiling 5
1449 "Limit on number of times encryption ciphertext is rejected.
1451 See `allout-encryption-ciphertext-rejection-regexps' for rejection reasons.")
1452 (make-variable-buffer-local 'allout-encryption-ciphertext-rejection-ceiling)
1453 ;;;_ > allout-mode-p ()
1454 ;; Must define this macro above any uses, or byte compilation will lack
1455 ;; proper def, if file isn't loaded - eg, during emacs build!
1456 (defmacro allout-mode-p ()
1457 "Return t if `allout-mode' is active in current buffer."
1459 ;;;_ > allout-write-file-hook-handler ()
1460 (defun allout-write-file-hook-handler ()
1461 "Implement `allout-encrypt-unencrypted-on-saves' policy for file writes."
1463 (if (or (not (allout-mode-p))
1464 (not (boundp 'allout-encrypt-unencrypted-on-saves))
1465 (not allout-encrypt-unencrypted-on-saves))
1467 (let ((except-mark (and (equal allout-encrypt-unencrypted-on-saves
1470 (if (save-excursion (goto-char (point-min))
1471 (allout-next-topic-pending-encryption except-mark))
1473 (message "auto-encrypting pending topics")
1475 (condition-case failure
1476 (setq allout-after-save-decrypt
1477 (allout-encrypt-decrypted except-mark))
1480 "allout-write-file-hook-handler suppressing error %s"
1485 ;;;_ > allout-auto-save-hook-handler ()
1486 (defun allout-auto-save-hook-handler ()
1487 "Implement `allout-encrypt-unencrypted-on-saves' policy for auto save."
1489 (if (and (allout-mode-p) allout-encrypt-unencrypted-on-saves)
1490 ;; Always implement 'except-current policy when enabled.
1491 (let ((allout-encrypt-unencrypted-on-saves 'except-current))
1492 (allout-write-file-hook-handler))))
1493 ;;;_ > allout-after-saves-handler ()
1494 (defun allout-after-saves-handler ()
1495 "Decrypt topic encrypted for save, if it's currently being edited.
1497 Ie, if it was pending encryption and contained the point in its body before
1500 We use values stored in `allout-after-save-decrypt' to locate the topic
1501 and the place for the cursor after the decryption is done."
1502 (if (not (and (allout-mode-p)
1503 (boundp 'allout-after-save-decrypt)
1504 allout-after-save-decrypt))
1506 (goto-char (car allout-after-save-decrypt))
1507 (let ((was-modified (buffer-modified-p)))
1508 (allout-toggle-subtree-encryption)
1509 (if (not was-modified)
1510 (set-buffer-modified-p nil)))
1511 (goto-char (cadr allout-after-save-decrypt))
1512 (setq allout-after-save-decrypt nil))
1514 ;;;_ = allout-during-yank-processing nil
1515 ;; XXX allout yanks adjust the level of the topic being pasted to that of
1516 ;; their target location. aberrance must be inhibited to allow that
1517 ;; reconciliation. (this means that actually aberrant topics won't be
1518 ;; treated specially while being pasted.)
1519 (defvar allout-during-yank-processing nil
1520 "Internal state, inhibits aberrance doublecheck while adjusting yanks.")
1522 ;;;_ #2 Mode activation
1523 ;;;_ = allout-explicitly-deactivated
1524 (defvar allout-explicitly-deactivated nil
1525 "If t, `allout-mode's last deactivation was deliberate.
1526 So `allout-post-command-business' should not reactivate it...")
1527 (make-variable-buffer-local 'allout-explicitly-deactivated)
1528 ;;;_ > allout-init (&optional mode)
1529 (defun allout-init (&optional mode)
1530 "Prime `allout-mode' to enable/disable auto-activation, wrt `allout-layout'.
1532 MODE is one of the following symbols:
1534 - nil \(or no argument) deactivate auto-activation/layout;
1535 - `activate', enable auto-activation only;
1536 - `ask', enable auto-activation, and enable auto-layout but with
1537 confirmation for layout operation solicited from user each time;
1538 - `report', just report and return the current auto-activation state;
1539 - anything else \(eg, t) for auto-activation and auto-layout, without
1540 any confirmation check.
1542 Use this function to setup your Emacs session for automatic activation
1543 of allout outline mode, contingent to the buffer-specific setting of
1544 the `allout-layout' variable. (See `allout-layout' and
1545 `allout-expose-topic' docstrings for more details on auto layout).
1547 `allout-init' works by setting up (or removing) the `allout-mode'
1548 find-file-hook, and giving `allout-auto-activation' a suitable
1551 To prime your Emacs session for full auto-outline operation, include
1552 the following two lines in your Emacs init file:
1562 (concat "Select outline auto setup mode "
1563 "(empty for report, ? for options) ")
1564 '(("nil")("full")("activate")("deactivate")
1565 ("ask") ("report") (""))
1568 (if (string= mode "")
1570 (setq mode (intern-soft mode)))))
1572 ;; convenience aliases, for consistent ref to respective vars:
1573 ((hook 'allout-find-file-hook)
1574 (find-file-hook-var-name (if (boundp 'find-file-hook)
1577 (curr-mode 'allout-auto-activation))
1580 (set find-file-hook-var-name
1581 (delq hook (symbol-value find-file-hook-var-name)))
1583 (message "Allout outline mode auto-activation inhibited.")))
1585 (if (not (memq hook (symbol-value find-file-hook-var-name)))
1587 ;; Just punt and use the reports from each of the modes:
1588 (allout-init (symbol-value curr-mode))))
1589 (t (add-hook find-file-hook-var-name hook)
1590 (set curr-mode ; `set', not `setq'!
1591 (cond ((eq mode 'activate)
1593 "Outline mode auto-activation enabled.")
1596 ;; Return the current mode setting:
1600 (concat "Outline mode auto-activation and "
1601 "-layout \(upon confirmation) enabled."))
1604 "Outline mode auto-activation and -layout enabled.")
1606 ;;;_ > allout-setup-menubar ()
1607 (defun allout-setup-menubar ()
1608 "Populate the current buffer's menubar with `allout-mode' stuff."
1609 (let ((menus (list allout-mode-exposure-menu
1610 allout-mode-editing-menu
1611 allout-mode-navigation-menu
1612 allout-mode-misc-menu))
1615 (setq cur (car menus)
1617 (easy-menu-add cur))))
1618 ;;;_ > allout-overlay-preparations
1619 (defun allout-overlay-preparations ()
1620 "Set the properties of the allout invisible-text overlay and others."
1621 (setplist 'allout-exposure-category nil)
1622 (put 'allout-exposure-category 'invisible 'allout)
1623 (put 'allout-exposure-category 'evaporate t)
1624 ;; XXX We use isearch-open-invisible *and* isearch-mode-end-hook. The
1625 ;; latter would be sufficient, but it seems that a separate behavior -
1626 ;; the _transient_ opening of invisible text during isearch - is keyed to
1627 ;; presence of the isearch-open-invisible property - even though this
1628 ;; property controls the isearch _arrival_ behavior. This is the case at
1629 ;; least in emacs 21, 22.0, and xemacs 21.4.
1630 (put 'allout-exposure-category 'isearch-open-invisible
1631 'allout-isearch-end-handler)
1632 (if (featurep 'xemacs)
1633 (put 'allout-exposure-category 'start-open t)
1634 (put 'allout-exposure-category 'insert-in-front-hooks
1635 '(allout-overlay-insert-in-front-handler)))
1636 (put 'allout-exposure-category 'modification-hooks
1637 '(allout-overlay-interior-modification-handler)))
1638 ;;;_ > allout-mode (&optional toggle)
1641 (defun allout-mode (&optional toggle)
1643 "Toggle minor mode for controlling exposure and editing of text outlines.
1646 Optional arg forces mode to re-initialize iff arg is positive num or
1647 symbol. Allout outline mode always runs as a minor mode.
1649 Allout outline mode provides extensive outline oriented formatting and
1650 manipulation. It enables structural editing of outlines, as well as
1651 navigation and exposure. It also is specifically aimed at
1652 accommodating syntax-sensitive text like programming languages. \(For
1653 an example, see the allout code itself, which is organized as an allout
1656 In addition to outline navigation and exposure, allout includes:
1658 - topic-oriented repositioning, promotion/demotion, cut, and paste
1659 - integral outline exposure-layout
1660 - incremental search with dynamic exposure and reconcealment of hidden text
1661 - automatic topic-number maintenance
1662 - easy topic encryption and decryption
1663 - \"Hot-spot\" operation, for single-keystroke maneuvering and
1664 exposure control. \(See the allout-mode docstring.)
1666 and many other features.
1668 Below is a description of the bindings, and then explanation of
1669 special `allout-mode' features and terminology. See also the outline
1670 menubar additions for quick reference to many of the features, and see
1671 the docstring of the function `allout-init' for instructions on
1672 priming your emacs session for automatic activation of `allout-mode'.
1675 The bindings are dictated by the `allout-keybindings-list' and
1676 `allout-command-prefix' variables.
1678 Navigation: Exposure Control:
1679 ---------- ----------------
1680 \\[allout-next-visible-heading] allout-next-visible-heading | \\[allout-hide-current-subtree] allout-hide-current-subtree
1681 \\[allout-previous-visible-heading] allout-previous-visible-heading | \\[allout-show-children] allout-show-children
1682 \\[allout-up-current-level] allout-up-current-level | \\[allout-show-current-subtree] allout-show-current-subtree
1683 \\[allout-forward-current-level] allout-forward-current-level | \\[allout-show-current-entry] allout-show-current-entry
1684 \\[allout-backward-current-level] allout-backward-current-level | \\[allout-show-all] allout-show-all
1685 \\[allout-end-of-entry] allout-end-of-entry
1686 \\[allout-beginning-of-current-entry] allout-beginning-of-current-entry, alternately, goes to hot-spot
1688 Topic Header Production:
1689 -----------------------
1690 \\[allout-open-sibtopic] allout-open-sibtopic Create a new sibling after current topic.
1691 \\[allout-open-subtopic] allout-open-subtopic ... an offspring of current topic.
1692 \\[allout-open-supertopic] allout-open-supertopic ... a sibling of the current topic's parent.
1694 Topic Level and Prefix Adjustment:
1695 ---------------------------------
1696 \\[allout-shift-in] allout-shift-in Shift current topic and all offspring deeper.
1697 \\[allout-shift-out] allout-shift-out ... less deep.
1698 \\[allout-rebullet-current-heading] allout-rebullet-current-heading Prompt for alternate bullet for
1700 \\[allout-rebullet-topic] allout-rebullet-topic Reconcile bullets of topic and its offspring
1701 - distinctive bullets are not changed, others
1702 alternated according to nesting depth.
1703 \\[allout-number-siblings] allout-number-siblings Number bullets of topic and siblings - the
1704 offspring are not affected. With repeat
1705 count, revoke numbering.
1707 Topic-oriented Killing and Yanking:
1708 ----------------------------------
1709 \\[allout-kill-topic] allout-kill-topic Kill current topic, including offspring.
1710 \\[allout-copy-topic-as-kill] allout-copy-topic-as-kill Copy current topic, including offspring.
1711 \\[allout-kill-line] allout-kill-line kill-line, attending to outline structure.
1712 \\[allout-copy-line-as-kill] allout-copy-line-as-kill Copy line but don't delete it.
1713 \\[allout-yank] allout-yank Yank, adjusting depth of yanked topic to
1714 depth of heading if yanking into bare topic
1715 heading (ie, prefix sans text).
1716 \\[allout-yank-pop] allout-yank-pop Is to allout-yank as yank-pop is to yank
1718 Topic-oriented Encryption:
1719 -------------------------
1720 \\[allout-toggle-current-subtree-encryption] allout-toggle-current-subtree-encryption Encrypt/Decrypt topic content
1724 M-x outlineify-sticky Activate outline mode for current buffer,
1725 and establish a default file-var setting
1726 for `allout-layout'.
1727 \\[allout-mark-topic] allout-mark-topic
1728 \\[allout-copy-exposed-to-buffer] allout-copy-exposed-to-buffer
1729 Duplicate outline, sans concealed text, to
1730 buffer with name derived from derived from that
1731 of current buffer - \"*BUFFERNAME exposed*\".
1732 \\[allout-flatten-exposed-to-buffer] allout-flatten-exposed-to-buffer
1733 Like above 'copy-exposed', but convert topic
1734 prefixes to section.subsection... numeric
1736 \\[eval-expression] (allout-init t) Setup Emacs session for outline mode
1741 Outline mode supports gpg encryption of topics, with support for
1742 symmetric and key-pair modes, passphrase timeout, passphrase
1743 consistency checking, user-provided hinting for symmetric key
1744 mode, and auto-encryption of topics pending encryption on save.
1745 \(Topics pending encryption are, by default, automatically
1746 encrypted during file saves; if you're editing the contents of
1747 such a topic, it is automatically decrypted for continued
1748 editing.) The aim is reliable topic privacy while preventing
1749 accidents like neglected encryption before saves, forgetting
1750 which passphrase was used, and other practical pitfalls.
1752 See `allout-toggle-current-subtree-encryption' function docstring and
1753 `allout-encrypt-unencrypted-on-saves' customization variable for details.
1757 Hot-spot operation provides a means for easy, single-keystroke outline
1758 navigation and exposure control.
1760 When the text cursor is positioned directly on the bullet character of
1761 a topic, regular characters (a to z) invoke the commands of the
1762 corresponding allout-mode keymap control chars. For example, \"f\"
1763 would invoke the command typically bound to \"C-c<space>C-f\"
1764 \(\\[allout-forward-current-level] `allout-forward-current-level').
1766 Thus, by positioning the cursor on a topic bullet, you can
1767 execute the outline navigation and manipulation commands with a
1768 single keystroke. Regular navigation keys (eg, \\[forward-char], \\[next-line]) never get
1769 this special translation, so you can use them to get out of the
1770 hot-spot and back to normal operation.
1772 Note that the command `allout-beginning-of-current-entry' \(\\[allout-beginning-of-current-entry]\)
1773 will move to the hot-spot when the cursor is already located at the
1774 beginning of the current entry, so you usually can hit \\[allout-beginning-of-current-entry]
1775 twice in a row to get to the hot-spot.
1779 Topic hierarchy constituents - TOPICS and SUBTOPICS:
1781 TOPIC: A basic, coherent component of an Emacs outline. It can
1782 contain and be contained by other topics.
1784 The visible topic most immediately containing the cursor.
1785 DEPTH: The degree of nesting of a topic; it increases with
1786 containment. Also called the:
1787 LEVEL: The same as DEPTH.
1790 The topics that contain a topic.
1791 PARENT: A topic's immediate ancestor. It has a depth one less than
1794 The topics contained by a topic;
1796 An immediate offspring of a topic;
1798 The immediate offspring of a topic.
1800 Topics having the same parent and depth.
1802 Topic text constituents:
1804 HEADER: The first line of a topic, include the topic PREFIX and header
1806 PREFIX: The leading text of a topic which distinguishes it from normal
1807 text. It has a strict form, which consists of a prefix-lead
1808 string, padding, and a bullet. The bullet may be followed by a
1809 number, indicating the ordinal number of the topic among its
1810 siblings, a space, and then the header text.
1812 The relative length of the PREFIX determines the nesting depth
1815 The string at the beginning of a topic prefix, normally a `.'.
1816 It can be customized by changing the setting of
1817 `allout-header-prefix' and then reinitializing `allout-mode'.
1819 By setting the prefix-lead to the comment-string of a
1820 programming language, you can embed outline structuring in
1821 program code without interfering with the language processing
1822 of that code. See `allout-use-mode-specific-leader'
1823 docstring for more detail.
1825 Spaces or asterisks which separate the prefix-lead and the
1826 bullet, determining the depth of the topic.
1827 BULLET: A character at the end of the topic prefix, it must be one of
1828 the characters listed on `allout-plain-bullets-string' or
1829 `allout-distinctive-bullets-string'. (See the documentation
1830 for these variables for more details.) The default choice of
1831 bullet when generating topics varies in a cycle with the depth of
1833 ENTRY: The text contained in a topic before any offspring.
1834 BODY: Same as ENTRY.
1838 The state of a topic which determines the on-screen visibility
1839 of its offspring and contained text.
1841 Topics and entry text whose display is inhibited. Contiguous
1842 units of concealed text is represented by `...' ellipses.
1844 Concealed topics are effectively collapsed within an ancestor.
1845 CLOSED: A topic whose immediate offspring and body-text is concealed.
1846 OPEN: A topic that is not closed, though its offspring or body may be."
1850 (let* ((active (and (not (equal major-mode 'outline))
1852 ; Massage universal-arg `toggle' val:
1854 (or (and (listp toggle)(car toggle))
1856 ; Activation specifically demanded?
1857 (explicit-activation (and toggle
1858 (or (symbolp toggle)
1859 (and (wholenump toggle)
1860 (not (zerop toggle))))))
1861 ;; allout-mode already called once during this complex command?
1862 (same-complex-command (eq allout-v18/19-file-var-hack
1863 (car command-history)))
1864 (write-file-hook-var-name (cond ((boundp 'write-file-functions)
1865 'write-file-functions)
1866 ((boundp 'write-file-hooks)
1868 (t 'local-write-file-hooks)))
1872 ; See comments below re v19.18,.19 bug.
1873 (setq allout-v18/19-file-var-hack (car command-history))
1877 ;; Provision for v19.18, 19.19 bug -
1878 ;; Emacs v 19.18, 19.19 file-var code invokes prop-line-designated
1879 ;; modes twice when file is visited. We have to avoid toggling mode
1880 ;; off on second invocation, so we detect it as best we can, and
1882 ((and same-complex-command ; Still in same complex command
1883 ; as last time `allout-mode' invoked.
1884 active ; Already activated.
1885 (not explicit-activation) ; Prop-line file-vars don't have args.
1886 (string-match "^19.1[89]" ; Bug only known to be in v19.18 and
1887 emacs-version)); 19.19.
1891 ((and (not explicit-activation)
1893 ; Activation not explicitly
1894 ; requested, and either in
1895 ; active state or *de*activation
1896 ; specifically requested:
1897 (setq allout-explicitly-deactivated t)
1899 (allout-do-resumptions)
1901 (remove-from-invisibility-spec '(allout . t))
1902 (remove-hook 'pre-command-hook 'allout-pre-command-business t)
1903 (remove-hook 'post-command-hook 'allout-post-command-business t)
1904 (remove-hook 'before-change-functions 'allout-before-change-handler t)
1905 (remove-hook 'isearch-mode-end-hook 'allout-isearch-end-handler t)
1906 (remove-hook write-file-hook-var-name 'allout-write-file-hook-handler t)
1907 (remove-hook 'auto-save-hook 'allout-auto-save-hook-handler t)
1909 (remove-overlays (point-min) (point-max)
1910 'category 'allout-exposure-category)
1912 (setq allout-mode nil)
1913 (run-hooks 'allout-mode-deactivate-hook))
1917 (setq allout-explicitly-deactivated nil)
1918 (if allout-old-style-prefixes
1919 ;; Inhibit all the fancy formatting:
1920 (allout-add-resumptions '(allout-primary-bullet "*")))
1922 (allout-overlay-preparations) ; Doesn't hurt to redo this.
1924 (allout-infer-header-lead-and-primary-bullet)
1925 (allout-infer-body-reindent)
1928 (allout-add-resumptions
1929 '(allout-encryption-ciphertext-rejection-regexps
1930 allout-line-boundary-regexp
1932 '(allout-encryption-ciphertext-rejection-regexps
1936 ;; Produce map from current version of allout-keybindings-list:
1937 (setq allout-mode-map
1938 (produce-allout-mode-map allout-keybindings-list))
1939 (substitute-key-definition 'beginning-of-line
1940 'allout-beginning-of-line
1941 allout-mode-map global-map)
1942 (substitute-key-definition 'move-beginning-of-line
1943 'allout-beginning-of-line
1944 allout-mode-map global-map)
1945 (substitute-key-definition 'end-of-line
1947 allout-mode-map global-map)
1948 (substitute-key-definition 'move-end-of-line
1950 allout-mode-map global-map)
1951 (produce-allout-mode-menubar-entries)
1952 (fset 'allout-mode-map allout-mode-map)
1954 ;; Include on minor-mode-map-alist, if not already there:
1955 (if (not (member '(allout-mode . allout-mode-map)
1956 minor-mode-map-alist))
1957 (setq minor-mode-map-alist
1958 (cons '(allout-mode . allout-mode-map)
1959 minor-mode-map-alist)))
1961 (add-to-invisibility-spec '(allout . t))
1962 (allout-add-resumptions '(line-move-ignore-invisible t))
1963 (add-hook 'pre-command-hook 'allout-pre-command-business nil t)
1964 (add-hook 'post-command-hook 'allout-post-command-business nil t)
1965 (add-hook 'before-change-functions 'allout-before-change-handler
1967 (add-hook 'isearch-mode-end-hook 'allout-isearch-end-handler nil t)
1968 (add-hook write-file-hook-var-name 'allout-write-file-hook-handler
1970 (add-hook 'auto-save-hook 'allout-auto-save-hook-handler
1973 ;; Stash auto-fill settings and adjust so custom allout auto-fill
1974 ;; func will be used if auto-fill is active or activated. (The
1975 ;; custom func respects topic headline, maintains hanging-indents,
1977 (if (and auto-fill-function (not allout-inhibit-auto-fill))
1978 ;; allout-auto-fill will use the stashed values and so forth.
1979 (allout-add-resumptions '(auto-fill-function allout-auto-fill)))
1980 (allout-add-resumptions (list 'allout-former-auto-filler
1982 ;; Register allout-auto-fill to be used if
1983 ;; filling is active:
1984 (list 'allout-outside-normal-auto-fill-function
1985 normal-auto-fill-function)
1986 '(normal-auto-fill-function allout-auto-fill)
1987 ;; Paragraphs are broken by topic headlines.
1988 (list 'paragraph-start
1989 (concat paragraph-start "\\|^\\("
1990 allout-regexp "\\)"))
1991 (list 'paragraph-separate
1992 (concat paragraph-separate "\\|^\\("
1993 allout-regexp "\\)")))
1994 (or (assq 'allout-mode minor-mode-alist)
1995 (setq minor-mode-alist
1996 (cons '(allout-mode " Allout") minor-mode-alist)))
1998 (allout-setup-menubar)
2003 (setq allout-mode t)
2004 (run-hooks 'allout-mode-hook))
2008 (allout-infer-body-reindent))
2009 ) ;; end of activation-mode cases.
2011 ;; Do auto layout if warranted:
2012 (let ((use-layout (if (listp allout-layout)
2014 allout-default-layout)))
2016 allout-auto-activation
2018 (and (not (eq allout-auto-activation 'activate))
2019 (if (eq allout-auto-activation 'ask)
2020 (if (y-or-n-p (format "Expose %s with layout '%s'? "
2024 (message "Skipped %s layout." (buffer-name))
2028 (message "Adjusting '%s' exposure..." (buffer-name))
2030 (allout-this-or-next-heading)
2033 (apply 'allout-expose-topic (list use-layout))
2034 (message "Adjusting '%s' exposure... done." (buffer-name)))
2035 ;; Problem applying exposure - notify user, but don't
2036 ;; interrupt, eg, file visit:
2037 (error (message "%s" (car (cdr err)))
2042 ;;;_ > allout-minor-mode
2043 (defalias 'allout-minor-mode 'allout-mode)
2045 ;;;_ - Position Assessment
2046 ;;;_ > allout-hidden-p (&optional pos)
2047 (defsubst allout-hidden-p (&optional pos)
2048 "Non-nil if the character after point is invisible."
2049 (eq (get-char-property (or pos (point)) 'invisible) 'allout))
2051 ;;;_ > allout-overlay-insert-in-front-handler (ol after beg end
2052 ;;; &optional prelen)
2053 (defun allout-overlay-insert-in-front-handler (ol after beg end
2055 "Shift the overlay so stuff inserted in front of it are excluded."
2057 (move-overlay ol (1+ beg) (overlay-end ol))))
2058 ;;;_ > allout-overlay-interior-modification-handler (ol after beg end
2059 ;;; &optional prelen)
2060 (defun allout-overlay-interior-modification-handler (ol after beg end
2062 "Get confirmation before making arbitrary changes to invisible text.
2064 We expose the invisible text and ask for confirmation. Refusal or
2065 keyboard-quit abandons the changes, with keyboard-quit additionally
2066 reclosing the opened text.
2068 No confirmation is necessary when inhibit-read-only is set - eg, allout
2069 internal functions use this feature cohesively bunch changes."
2071 (when (and (not inhibit-read-only) (not after))
2072 (let ((start (point))
2073 (ol-start (overlay-start ol))
2074 (ol-end (overlay-end ol))
2077 (while (< (point) end)
2078 (when (allout-hidden-p)
2079 (allout-show-to-offshoot)
2080 (if (allout-hidden-p)
2081 (save-excursion (forward-char 1)
2082 (allout-show-to-offshoot)))
2084 (setq first (point))))
2085 (goto-char (if (featurep 'xemacs)
2086 (next-property-change (1+ (point)) nil end)
2087 (next-char-property-change (1+ (point)) end))))
2093 (substitute-command-keys
2094 (concat "Modify concealed text? (\"no\" just aborts,"
2095 " \\[keyboard-quit] also reconceals) "))))
2096 (progn (goto-char start)
2097 (error "Concealed-text change refused.")))
2098 (quit (allout-flag-region ol-start ol-end nil)
2099 (allout-flag-region ol-start ol-end t)
2100 (error "Concealed-text change abandoned, text reconcealed."))))
2101 (goto-char start))))
2102 ;;;_ > allout-before-change-handler (beg end)
2103 (defun allout-before-change-handler (beg end)
2104 "Protect against changes to invisible text.
2106 See allout-overlay-interior-modification-handler for details."
2108 (if (and (allout-mode-p) undo-in-progress (allout-hidden-p))
2109 (allout-show-to-offshoot))
2111 ;; allout-overlay-interior-modification-handler on an overlay handles
2112 ;; this in other emacs, via `allout-exposure-category's 'modification-hooks.
2113 (when (and (featurep 'xemacs) (allout-mode-p))
2114 ;; process all of the pending overlays:
2117 (let ((overlay (allout-get-invisibility-overlay)))
2118 (allout-overlay-interior-modification-handler
2119 overlay nil beg end nil)))))
2120 ;;;_ > allout-isearch-end-handler (&optional overlay)
2121 (defun allout-isearch-end-handler (&optional overlay)
2122 "Reconcile allout outline exposure on arriving in hidden text after isearch.
2124 Optional OVERLAY parameter is for when this function is used by
2125 `isearch-open-invisible' overlay property. It is otherwise unused, so this
2126 function can also be used as an `isearch-mode-end-hook'."
2128 (if (and (allout-mode-p) (allout-hidden-p))
2129 (allout-show-to-offshoot)))
2131 ;;;_ #3 Internal Position State-Tracking - "allout-recent-*" funcs
2132 ;;; All the basic outline functions that directly do string matches to
2133 ;;; evaluate heading prefix location set the variables
2134 ;;; `allout-recent-prefix-beginning' and `allout-recent-prefix-end'
2135 ;;; when successful. Functions starting with `allout-recent-' all
2136 ;;; use this state, providing the means to avoid redundant searches
2137 ;;; for just-established data. This optimization can provide
2138 ;;; significant speed improvement, but it must be employed carefully.
2139 ;;;_ = allout-recent-prefix-beginning
2140 (defvar allout-recent-prefix-beginning 0
2141 "Buffer point of the start of the last topic prefix encountered.")
2142 (make-variable-buffer-local 'allout-recent-prefix-beginning)
2143 ;;;_ = allout-recent-prefix-end
2144 (defvar allout-recent-prefix-end 0
2145 "Buffer point of the end of the last topic prefix encountered.")
2146 (make-variable-buffer-local 'allout-recent-prefix-end)
2147 ;;;_ = allout-recent-depth
2148 (defvar allout-recent-depth 0
2149 "Depth of the last topic prefix encountered.")
2150 (make-variable-buffer-local 'allout-recent-depth)
2151 ;;;_ = allout-recent-end-of-subtree
2152 (defvar allout-recent-end-of-subtree 0
2153 "Buffer point last returned by `allout-end-of-current-subtree'.")
2154 (make-variable-buffer-local 'allout-recent-end-of-subtree)
2155 ;;;_ > allout-prefix-data ()
2156 (defsubst allout-prefix-data ()
2157 "Register allout-prefix state data.
2159 For reference by `allout-recent' funcs. Returns BEGINNING."
2160 (setq allout-recent-prefix-end (or (match-end 1) (match-end 2))
2161 allout-recent-prefix-beginning (or (match-beginning 1)
2162 (match-beginning 2))
2163 allout-recent-depth (max 1 (- allout-recent-prefix-end
2164 allout-recent-prefix-beginning
2165 allout-header-subtraction)))
2166 allout-recent-prefix-beginning)
2167 ;;;_ > nullify-allout-prefix-data ()
2168 (defsubst nullify-allout-prefix-data ()
2169 "Mark allout prefix data as being uninformative."
2170 (setq allout-recent-prefix-end (point)
2171 allout-recent-prefix-beginning (point)
2172 allout-recent-depth 0)
2173 allout-recent-prefix-beginning)
2174 ;;;_ > allout-recent-depth ()
2175 (defsubst allout-recent-depth ()
2176 "Return depth of last heading encountered by an outline maneuvering function.
2178 All outline functions which directly do string matches to assess
2179 headings set the variables `allout-recent-prefix-beginning' and
2180 `allout-recent-prefix-end' if successful. This function uses those settings
2181 to return the current depth."
2183 allout-recent-depth)
2184 ;;;_ > allout-recent-prefix ()
2185 (defsubst allout-recent-prefix ()
2186 "Like `allout-recent-depth', but returns text of last encountered prefix.
2188 All outline functions which directly do string matches to assess
2189 headings set the variables `allout-recent-prefix-beginning' and
2190 `allout-recent-prefix-end' if successful. This function uses those settings
2191 to return the current prefix."
2192 (buffer-substring-no-properties allout-recent-prefix-beginning
2193 allout-recent-prefix-end))
2194 ;;;_ > allout-recent-bullet ()
2195 (defmacro allout-recent-bullet ()
2196 "Like allout-recent-prefix, but returns bullet of last encountered prefix.
2198 All outline functions which directly do string matches to assess
2199 headings set the variables `allout-recent-prefix-beginning' and
2200 `allout-recent-prefix-end' if successful. This function uses those settings
2201 to return the current depth of the most recently matched topic."
2202 '(buffer-substring-no-properties (1- allout-recent-prefix-end)
2203 allout-recent-prefix-end))
2207 ;;;_ - Position Assessment
2208 ;;;_ : Location Predicates
2209 ;;;_ > allout-do-doublecheck ()
2210 (defsubst allout-do-doublecheck ()
2211 "True if current item conditions qualify for checking on topic aberrance."
2213 ;; presume integrity of outline and yanked content during yank - necessary,
2214 ;; to allow for level disparity of yank location and yanked text:
2215 (not allout-during-yank-processing)
2216 ;; allout-doublecheck-at-and-shallower is ceiling for doublecheck:
2217 (<= allout-recent-depth allout-doublecheck-at-and-shallower)))
2218 ;;;_ > allout-aberrant-container-p ()
2219 (defun allout-aberrant-container-p ()
2220 "True if topic, or next sibling with children, contains them discontinuously.
2222 Discontinuous means an immediate offspring that is nested more
2223 than one level deeper than the topic.
2225 If topic has no offspring, then the next sibling with offspring will
2226 determine whether or not this one is determined to be aberrant.
2228 If true, then the allout-recent-* settings are calibrated on the
2229 offspring that qaulifies it as aberrant, ie with depth that
2230 exceeds the topic by more than one."
2232 ;; This is most clearly understood when considering standard-prefix-leader
2233 ;; low-level topics, which can all too easily match text not intended as
2234 ;; headers. For example, any line with a leading '.' or '*' and lacking a
2235 ;; following bullet qualifies without this protection. (A sequence of
2236 ;; them can occur naturally, eg a typical textual bullet list.) We
2237 ;; disqualify such low-level sequences when they are followed by a
2238 ;; discontinuously contained child, inferring that the sequences are not
2239 ;; actually connected with their prospective context.
2241 (let ((depth (allout-depth))
2242 (start-point (point))
2245 (while (and (not done)
2246 (re-search-forward allout-line-boundary-regexp nil 0))
2247 (allout-prefix-data)
2248 (goto-char allout-recent-prefix-beginning)
2250 ;; sibling - continue:
2251 ((eq allout-recent-depth depth))
2252 ;; first offspring is excessive - aberrant:
2253 ((> allout-recent-depth (1+ depth))
2254 (setq done t aberrant t))
2255 ;; next non-sibling is lower-depth - not aberrant:
2256 (t (setq done t)))))
2259 (goto-char start-point)
2260 ;; recalibrate allout-recent-*
2263 ;;;_ > allout-on-current-heading-p ()
2264 (defun allout-on-current-heading-p ()
2265 "Return non-nil if point is on current visible topics' header line.
2267 Actually, returns prefix beginning point."
2269 (allout-beginning-of-current-line)
2270 (and (looking-at allout-regexp)
2271 (allout-prefix-data)
2272 (or (not (allout-do-doublecheck))
2273 (not (allout-aberrant-container-p))))))
2274 ;;;_ > allout-on-heading-p ()
2275 (defalias 'allout-on-heading-p 'allout-on-current-heading-p)
2276 ;;;_ > allout-e-o-prefix-p ()
2277 (defun allout-e-o-prefix-p ()
2278 "True if point is located where current topic prefix ends, heading begins."
2279 (and (save-excursion (let ((inhibit-field-text-motion t))
2280 (beginning-of-line))
2281 (looking-at allout-regexp))
2282 (= (point)(save-excursion (allout-end-of-prefix)(point)))))
2283 ;;;_ : Location attributes
2284 ;;;_ > allout-depth ()
2285 (defun allout-depth ()
2286 "Return depth of topic most immediately containing point.
2288 Return zero if point is not within any topic.
2290 Like `allout-current-depth', but respects hidden as well as visible topics."
2292 (let ((start-point (point)))
2293 (if (and (allout-goto-prefix)
2294 (not (< start-point (point))))
2297 ;; Oops, no prefix, nullify it:
2298 (nullify-allout-prefix-data)
2299 ;; ... and return 0:
2301 ;;;_ > allout-current-depth ()
2302 (defun allout-current-depth ()
2303 "Return depth of visible topic most immediately containing point.
2305 Return zero if point is not within any topic."
2307 (if (allout-back-to-current-heading)
2309 (- allout-recent-prefix-end
2310 allout-recent-prefix-beginning
2311 allout-header-subtraction))
2313 ;;;_ > allout-get-current-prefix ()
2314 (defun allout-get-current-prefix ()
2315 "Topic prefix of the current topic."
2317 (if (allout-goto-prefix)
2318 (allout-recent-prefix))))
2319 ;;;_ > allout-get-bullet ()
2320 (defun allout-get-bullet ()
2321 "Return bullet of containing topic (visible or not)."
2323 (and (allout-goto-prefix)
2324 (allout-recent-bullet))))
2325 ;;;_ > allout-current-bullet ()
2326 (defun allout-current-bullet ()
2327 "Return bullet of current (visible) topic heading, or none if none found."
2330 (allout-back-to-current-heading)
2331 (buffer-substring-no-properties (- allout-recent-prefix-end 1)
2332 allout-recent-prefix-end))
2333 ;; Quick and dirty provision, ostensibly for missing bullet:
2334 (args-out-of-range nil))
2336 ;;;_ > allout-get-prefix-bullet (prefix)
2337 (defun allout-get-prefix-bullet (prefix)
2338 "Return the bullet of the header prefix string PREFIX."
2339 ;; Doesn't make sense if we're old-style prefixes, but this just
2340 ;; oughtn't be called then, so forget about it...
2341 (if (string-match allout-regexp prefix)
2342 (substring prefix (1- (match-end 2)) (match-end 2))))
2343 ;;;_ > allout-sibling-index (&optional depth)
2344 (defun allout-sibling-index (&optional depth)
2345 "Item number of this prospective topic among its siblings.
2347 If optional arg DEPTH is greater than current depth, then we're
2348 opening a new level, and return 0.
2350 If less than this depth, ascend to that depth and count..."
2353 (cond ((and depth (<= depth 0) 0))
2354 ((or (null depth) (= depth (allout-depth)))
2356 (while (allout-previous-sibling allout-recent-depth nil)
2357 (setq index (1+ index)))
2359 ((< depth allout-recent-depth)
2360 (allout-ascend-to-depth depth)
2361 (allout-sibling-index))
2363 ;;;_ > allout-topic-flat-index ()
2364 (defun allout-topic-flat-index ()
2365 "Return a list indicating point's numeric section.subsect.subsubsect...
2366 Outermost is first."
2367 (let* ((depth (allout-depth))
2368 (next-index (allout-sibling-index depth))
2370 (while (> next-index 0)
2371 (setq rev-sibls (cons next-index rev-sibls))
2372 (setq depth (1- depth))
2373 (setq next-index (allout-sibling-index depth)))
2377 ;;;_ - Navigation routines
2378 ;;;_ > allout-beginning-of-current-line ()
2379 (defun allout-beginning-of-current-line ()
2380 "Like beginning of line, but to visible text."
2382 ;; This combination of move-beginning-of-line and beginning-of-line is
2383 ;; deliberate, but the (beginning-of-line) may now be superfluous.
2384 (let ((inhibit-field-text-motion t))
2385 (move-beginning-of-line 1)
2387 (while (and (not (bobp)) (or (not (bolp)) (allout-hidden-p)))
2389 (if (or (allout-hidden-p) (not (bolp)))
2390 (forward-char -1)))))
2391 ;;;_ > allout-end-of-current-line ()
2392 (defun allout-end-of-current-line ()
2393 "Move to the end of line, past concealed text if any."
2394 ;; XXX This is for symmetry with `allout-beginning-of-current-line' -
2395 ;; `move-end-of-line' doesn't suffer the same problem as
2396 ;; `move-beginning-of-line'.
2397 (let ((inhibit-field-text-motion t))
2399 (while (allout-hidden-p)
2401 (if (allout-hidden-p) (forward-char 1)))))
2402 ;;;_ > allout-beginning-of-line ()
2403 (defun allout-beginning-of-line ()
2404 "Beginning-of-line with `allout-beginning-of-line-cycles' behavior, if set."
2408 (if (or (not allout-beginning-of-line-cycles)
2409 (not (equal last-command this-command)))
2410 (move-beginning-of-line 1)
2412 (let ((beginning-of-body
2414 (while (and (allout-do-doublecheck)
2415 (allout-aberrant-container-p)
2416 (allout-previous-visible-heading 1)))
2417 (allout-beginning-of-current-entry)
2419 (cond ((= (current-column) 0)
2420 (goto-char beginning-of-body))
2421 ((< (point) beginning-of-body)
2422 (allout-beginning-of-current-line))
2423 ((= (point) beginning-of-body)
2424 (goto-char (allout-current-bullet-pos)))
2425 (t (allout-beginning-of-current-line)
2426 (if (< (point) beginning-of-body)
2427 ;; we were on the headline after its start:
2428 (goto-char beginning-of-body)))))))
2429 ;;;_ > allout-end-of-line ()
2430 (defun allout-end-of-line ()
2431 "End-of-line with `allout-end-of-line-cycles' behavior, if set."
2435 (if (or (not allout-end-of-line-cycles)
2436 (not (equal last-command this-command)))
2437 (allout-end-of-current-line)
2438 (let ((end-of-entry (save-excursion
2439 (allout-end-of-entry)
2442 (allout-end-of-current-line))
2443 ((or (allout-hidden-p) (save-excursion
2446 (allout-back-to-current-heading)
2447 (allout-show-current-entry)
2448 (allout-show-children)
2449 (allout-end-of-entry))
2450 ((>= (point) end-of-entry)
2451 (allout-back-to-current-heading)
2452 (allout-end-of-current-line))
2453 (t (allout-end-of-entry))))))
2454 ;;;_ > allout-next-heading ()
2455 (defsubst allout-next-heading ()
2456 "Move to the heading for the topic \(possibly invisible) after this one.
2458 Returns the location of the heading, or nil if none found.
2460 We skip anomolous low-level topics, a la `allout-aberrant-container-p'."
2461 (if (looking-at allout-regexp)
2464 (when (re-search-forward allout-line-boundary-regexp nil 0)
2465 (allout-prefix-data)
2466 (and (allout-do-doublecheck)
2467 ;; this will set allout-recent-* on the first non-aberrant topic,
2468 ;; whether it's the current one or one that disqualifies it:
2469 (allout-aberrant-container-p))
2470 (goto-char allout-recent-prefix-beginning)))
2471 ;;;_ > allout-this-or-next-heading
2472 (defun allout-this-or-next-heading ()
2473 "Position cursor on current or next heading."
2474 ;; A throwaway non-macro that is defined after allout-next-heading
2475 ;; and usable by allout-mode.
2476 (if (not (allout-goto-prefix-doublechecked)) (allout-next-heading)))
2477 ;;;_ > allout-previous-heading ()
2478 (defun allout-previous-heading ()
2479 "Move to the prior \(possibly invisible) heading line.
2481 Return the location of the beginning of the heading, or nil if not found.
2483 We skip anomolous low-level topics, a la `allout-aberrant-container-p'."
2487 (let ((start-point (point)))
2488 ;; allout-goto-prefix-doublechecked calls us, so we can't use it here.
2489 (allout-goto-prefix)
2490 (when (or (re-search-backward allout-line-boundary-regexp nil 0)
2491 (looking-at allout-bob-regexp))
2492 (goto-char (allout-prefix-data))
2493 (if (and (allout-do-doublecheck)
2494 (allout-aberrant-container-p))
2495 (or (allout-previous-heading)
2496 (and (goto-char start-point)
2497 ;; recalibrate allout-recent-*:
2501 ;;;_ > allout-get-invisibility-overlay ()
2502 (defun allout-get-invisibility-overlay ()
2503 "Return the overlay at point that dictates allout invisibility."
2504 (let ((overlays (overlays-at (point)))
2506 (while (and overlays (not got))
2507 (if (equal (overlay-get (car overlays) 'invisible) 'allout)
2508 (setq got (car overlays))
2511 ;;;_ > allout-back-to-visible-text ()
2512 (defun allout-back-to-visible-text ()
2513 "Move to most recent prior character that is visible, and return point."
2514 (if (allout-hidden-p)
2515 (goto-char (overlay-start (allout-get-invisibility-overlay))))
2518 ;;;_ - Subtree Charting
2519 ;;;_ " These routines either produce or assess charts, which are
2520 ;;; nested lists of the locations of topics within a subtree.
2522 ;;; Charts enable efficient subtree navigation by providing a reusable basis
2523 ;;; for elaborate, compound assessment and adjustment of a subtree.
2525 ;;;_ > allout-chart-subtree (&optional levels visible orig-depth prev-depth)
2526 (defun allout-chart-subtree (&optional levels visible orig-depth prev-depth)
2527 "Produce a location \"chart\" of subtopics of the containing topic.
2529 Optional argument LEVELS specifies a depth limit \(relative to start
2530 depth) for the chart. Null LEVELS means no limit.
2532 When optional argument VISIBLE is non-nil, the chart includes
2533 only the visible subelements of the charted subjects.
2535 The remaining optional args are for internal use by the function.
2537 Point is left at the end of the subtree.
2539 Charts are used to capture outline structure, so that outline-altering
2540 routines need assess the structure only once, and then use the chart
2541 for their elaborate manipulations.
2543 The chart entries for the topics are in reverse order, so the
2544 last topic is listed first. The entry for each topic consists of
2545 an integer indicating the point at the beginning of the topic
2546 prefix. Charts for offspring consists of a list containing,
2547 recursively, the charts for the respective subtopics. The chart
2548 for a topics' offspring precedes the entry for the topic itself.
2550 The other function parameters are for internal recursion, and should
2551 not be specified by external callers. ORIG-DEPTH is depth of topic at
2552 starting point, and PREV-DEPTH is depth of prior topic."
2554 (let ((original (not orig-depth)) ; `orig-depth' set only in recursion.
2557 (if original ; Just starting?
2558 ; Register initial settings and
2559 ; position to first offspring:
2560 (progn (setq orig-depth (allout-depth))
2561 (or prev-depth (setq prev-depth (1+ orig-depth)))
2563 (allout-next-visible-heading 1)
2564 (allout-next-heading))))
2566 ;; Loop over the current levels' siblings. Besides being more
2567 ;; efficient than tail-recursing over a level, it avoids exceeding
2568 ;; the typically quite constrained Emacs max-lisp-eval-depth.
2570 ;; Probably would speed things up to implement loop-based stack
2571 ;; operation rather than recursing for lower levels. Bah.
2573 (while (and (not (eobp))
2574 ; Still within original topic?
2575 (< orig-depth (setq curr-depth allout-recent-depth))
2576 (cond ((= prev-depth curr-depth)
2577 ;; Register this one and move on:
2578 (setq chart (cons allout-recent-prefix-beginning chart))
2579 (if (and levels (<= levels 1))
2580 ;; At depth limit - skip sublevels:
2581 (or (allout-next-sibling curr-depth)
2582 ;; or no more siblings - proceed to
2583 ;; next heading at lesser depth:
2584 (while (and (<= curr-depth
2585 allout-recent-depth)
2587 (allout-next-visible-heading 1)
2588 (allout-next-heading)))))
2590 (allout-next-visible-heading 1)
2591 (allout-next-heading))))
2593 ((and (< prev-depth curr-depth)
2596 ;; Recurse on deeper level of curr topic:
2598 (cons (allout-chart-subtree (and levels
2604 ;; ... then continue with this one.
2607 ;; ... else nil if we've ascended back to prev-depth.
2611 (if original ; We're at the last sibling on
2612 ; the original level. Position
2614 (progn (and (not (eobp)) (forward-char -1))
2615 (and (= (preceding-char) ?\n)
2616 (= (aref (buffer-substring (max 1 (- (point) 3))
2621 (setq allout-recent-end-of-subtree (point))))
2623 chart ; (nreverse chart) not necessary,
2624 ; and maybe not preferable.
2626 ;;;_ > allout-chart-siblings (&optional start end)
2627 (defun allout-chart-siblings (&optional start end)
2628 "Produce a list of locations of this and succeeding sibling topics.
2629 Effectively a top-level chart of siblings. See `allout-chart-subtree'
2630 for an explanation of charts."
2632 (when (allout-goto-prefix-doublechecked)
2633 (let ((chart (list (point))))
2634 (while (allout-next-sibling)
2635 (setq chart (cons (point) chart)))
2636 (if chart (setq chart (nreverse chart)))))))
2637 ;;;_ > allout-chart-to-reveal (chart depth)
2638 (defun allout-chart-to-reveal (chart depth)
2640 "Return a flat list of hidden points in subtree CHART, up to DEPTH.
2642 If DEPTH is nil, include hidden points at any depth.
2644 Note that point can be left at any of the points on chart, or at the
2648 (while (and (or (null depth) (> depth 0))
2650 (setq here (car chart))
2652 (let ((further (allout-chart-to-reveal here (if (null depth)
2655 ;; We're on the start of a subtree - recurse with it, if there's
2656 ;; more depth to go:
2657 (if further (setq result (append further result)))
2658 (setq chart (cdr chart)))
2660 (if (allout-hidden-p)
2661 (setq result (cons here result)))
2662 (setq chart (cdr chart))))
2664 ;;;_ X allout-chart-spec (chart spec &optional exposing)
2665 ;; (defun allout-chart-spec (chart spec &optional exposing)
2666 ;; "Not yet \(if ever) implemented.
2668 ;; Produce exposure directives given topic/subtree CHART and an exposure SPEC.
2670 ;; Exposure spec indicates the locations to be exposed and the prescribed
2671 ;; exposure status. Optional arg EXPOSING is an integer, with 0
2672 ;; indicating pending concealment, anything higher indicating depth to
2673 ;; which subtopic headers should be exposed, and negative numbers
2674 ;; indicating (negative of) the depth to which subtopic headers and
2675 ;; bodies should be exposed.
2677 ;; The produced list can have two types of entries. Bare numbers
2678 ;; indicate points in the buffer where topic headers that should be
2681 ;; - bare negative numbers indicates that the topic starting at the
2682 ;; point which is the negative of the number should be opened,
2683 ;; including their entries.
2684 ;; - bare positive values indicate that this topic header should be
2686 ;; - Lists signify the beginning and end points of regions that should
2687 ;; be flagged, and the flag to employ. (For concealment: `\(\?r\)', and
2690 ;; (cond ((listp spec)
2693 ;; (setq spec (cdr spec)))
2697 ;;;_ > allout-goto-prefix ()
2698 (defun allout-goto-prefix ()
2699 "Put point at beginning of immediately containing outline topic.
2701 Goes to most immediate subsequent topic if none immediately containing.
2703 Not sensitive to topic visibility.
2705 Returns the point at the beginning of the prefix, or nil if none."
2708 (while (and (not done)
2709 (search-backward "\n" nil 1))
2711 (if (looking-at allout-regexp)
2712 (setq done (allout-prefix-data))
2715 (cond ((looking-at allout-regexp)
2716 (allout-prefix-data))
2717 ((allout-next-heading))
2720 ;;;_ > allout-goto-prefix-doublechecked ()
2721 (defun allout-goto-prefix-doublechecked ()
2722 "Put point at beginning of immediately containing outline topic.
2724 Like `allout-goto-prefix', but shallow topics \(according to
2725 `allout-doublecheck-at-and-shallower') are checked and
2726 disqualified for child containment discontinuity, according to
2727 `allout-aberrant-container-p'."
2728 (if (allout-goto-prefix)
2729 (if (and (allout-do-doublecheck)
2730 (allout-aberrant-container-p))
2731 (allout-previous-heading)
2734 ;;;_ > allout-end-of-prefix ()
2735 (defun allout-end-of-prefix (&optional ignore-decorations)
2736 "Position cursor at beginning of header text.
2738 If optional IGNORE-DECORATIONS is non-nil, put just after bullet,
2739 otherwise skip white space between bullet and ensuing text."
2741 (if (not (allout-goto-prefix-doublechecked))
2743 (goto-char allout-recent-prefix-end)
2744 (if ignore-decorations
2746 (while (looking-at "[0-9]") (forward-char 1))
2747 (if (and (not (eolp)) (looking-at "\\s-")) (forward-char 1)))
2748 ;; Reestablish where we are:
2749 (allout-current-depth)))
2750 ;;;_ > allout-current-bullet-pos ()
2751 (defun allout-current-bullet-pos ()
2752 "Return position of current \(visible) topic's bullet."
2754 (if (not (allout-current-depth))
2756 (1- allout-recent-prefix-end)))
2757 ;;;_ > allout-back-to-current-heading ()
2758 (defun allout-back-to-current-heading ()
2759 "Move to heading line of current topic, or beginning if not in a topic.
2761 If interactive, we position at the end of the prefix.
2763 Return value of resulting point, unless we started outside
2764 of (before any) topics, in which case we return nil."
2766 (allout-beginning-of-current-line)
2767 (let ((bol-point (point)))
2768 (if (allout-goto-prefix-doublechecked)
2769 (if (<= (point) bol-point)
2771 (allout-end-of-prefix)
2773 (goto-char (point-min))
2775 ;;;_ > allout-back-to-heading ()
2776 (defalias 'allout-back-to-heading 'allout-back-to-current-heading)
2777 ;;;_ > allout-pre-next-prefix ()
2778 (defun allout-pre-next-prefix ()
2779 "Skip forward to just before the next heading line.
2781 Returns that character position."
2783 (if (allout-next-heading)
2784 (goto-char (1- allout-recent-prefix-beginning))))
2785 ;;;_ > allout-end-of-subtree (&optional current include-trailing-blank)
2786 (defun allout-end-of-subtree (&optional current include-trailing-blank)
2787 "Put point at the end of the last leaf in the containing topic.
2789 Optional CURRENT means put point at the end of the containing
2792 Optional INCLUDE-TRAILING-BLANK means include a trailing blank line, if
2793 any, as part of the subtree. Otherwise, that trailing blank will be
2794 excluded as delimiting whitespace between topics.
2796 Returns the value of point."
2799 (allout-back-to-current-heading)
2800 (allout-goto-prefix-doublechecked))
2801 (let ((level allout-recent-depth))
2802 (allout-next-heading)
2803 (while (and (not (eobp))
2804 (> allout-recent-depth level))
2805 (allout-next-heading))
2807 (allout-end-of-entry)
2809 (if (and (not include-trailing-blank) (= ?\n (preceding-char)))
2811 (setq allout-recent-end-of-subtree (point))))
2812 ;;;_ > allout-end-of-current-subtree (&optional include-trailing-blank)
2813 (defun allout-end-of-current-subtree (&optional include-trailing-blank)
2815 "Put point at end of last leaf in currently visible containing topic.
2817 Optional INCLUDE-TRAILING-BLANK means include a trailing blank line, if
2818 any, as part of the subtree. Otherwise, that trailing blank will be
2819 excluded as delimiting whitespace between topics.
2821 Returns the value of point."
2823 (allout-end-of-subtree t include-trailing-blank))
2824 ;;;_ > allout-beginning-of-current-entry ()
2825 (defun allout-beginning-of-current-entry ()
2826 "When not already there, position point at beginning of current topic header.
2828 If already there, move cursor to bullet for hot-spot operation.
2829 \(See `allout-mode' doc string for details of hot-spot operation.)"
2831 (let ((start-point (point)))
2832 (move-beginning-of-line 1)
2833 (if (< 0 (allout-current-depth))
2834 (goto-char allout-recent-prefix-end)
2835 (goto-char (point-min)))
2836 (allout-end-of-prefix)
2837 (if (and (interactive-p)
2838 (= (point) start-point))
2839 (goto-char (allout-current-bullet-pos)))))
2840 ;;;_ > allout-end-of-entry (&optional inclusive)
2841 (defun allout-end-of-entry (&optional inclusive)
2842 "Position the point at the end of the current topics' entry.
2844 Optional INCLUSIVE means also include trailing empty line, if any. When
2845 unset, whitespace between items separates them even when the items are
2848 (allout-pre-next-prefix)
2849 (if (and (not inclusive) (not (bobp)) (= ?\n (preceding-char)))
2852 ;;;_ > allout-end-of-current-heading ()
2853 (defun allout-end-of-current-heading ()
2855 (allout-beginning-of-current-entry)
2856 (search-forward "\n" nil t)
2858 (defalias 'allout-end-of-heading 'allout-end-of-current-heading)
2859 ;;;_ > allout-get-body-text ()
2860 (defun allout-get-body-text ()
2861 "Return the unmangled body text of the topic immediately containing point."
2863 (allout-end-of-prefix)
2864 (if (not (search-forward "\n" nil t))
2867 (let ((pre-body (point)))
2870 (allout-end-of-entry t)
2871 (if (not (= pre-body (point)))
2872 (buffer-substring-no-properties (1+ pre-body) (point))))
2879 ;;;_ > allout-ascend-to-depth (depth)
2880 (defun allout-ascend-to-depth (depth)
2881 "Ascend to depth DEPTH, returning depth if successful, nil if not."
2882 (if (and (> depth 0)(<= depth (allout-depth)))
2883 (let (last-ascended)
2884 (while (and (< depth allout-recent-depth)
2885 (setq last-ascended (allout-ascend))))
2886 (goto-char allout-recent-prefix-beginning)
2887 (if (interactive-p) (allout-end-of-prefix))
2888 (and last-ascended allout-recent-depth))))
2889 ;;;_ > allout-ascend ()
2890 (defun allout-ascend ()
2891 "Ascend one level, returning t if successful, nil if not."
2893 (if (allout-beginning-of-level)
2894 (allout-previous-heading))
2895 (if (interactive-p) (allout-end-of-prefix))))
2896 ;;;_ > allout-descend-to-depth (depth)
2897 (defun allout-descend-to-depth (depth)
2898 "Descend to depth DEPTH within current topic.
2900 Returning depth if successful, nil if not."
2901 (let ((start-point (point))
2902 (start-depth (allout-depth)))
2904 (and (> (allout-depth) 0)
2905 (not (= depth allout-recent-depth)) ; ... not there yet
2906 (allout-next-heading) ; ... go further
2907 (< start-depth allout-recent-depth))) ; ... still in topic
2908 (if (and (> (allout-depth) 0)
2909 (= allout-recent-depth depth))
2911 (goto-char start-point)
2914 ;;;_ > allout-up-current-level (arg)
2915 (defun allout-up-current-level (arg)
2916 "Move out ARG levels from current visible topic."
2918 (let ((start-point (point)))
2919 (allout-back-to-current-heading)
2920 (if (not (allout-ascend))
2921 (progn (goto-char start-point)
2922 (error "Can't ascend past outermost level"))
2923 (if (interactive-p) (allout-end-of-prefix))
2924 allout-recent-prefix-beginning)))
2927 ;;;_ > allout-next-sibling (&optional depth backward)
2928 (defun allout-next-sibling (&optional depth backward)
2929 "Like `allout-forward-current-level', but respects invisible topics.
2931 Traverse at optional DEPTH, or current depth if none specified.
2933 Go backward if optional arg BACKWARD is non-nil.
2935 Return the start point of the new topic if successful, nil otherwise."
2937 (if (if backward (bobp) (eobp))
2939 (let ((target-depth (or depth (allout-depth)))
2940 (start-point (point))
2941 (start-prefix-beginning allout-recent-prefix-beginning)
2946 ;; done too few single steps to resort to the leap routine:
2949 (not (if backward (bobp) (eobp)))
2950 ;; still traversable:
2951 (if backward (allout-previous-heading) (allout-next-heading))
2952 ;; we're below the target depth
2953 (> (setq last-depth allout-recent-depth) target-depth))
2954 (setq count (1+ count))
2955 (if (> count 7) ; lists are commonly 7 +- 2, right?-)
2958 (or (allout-next-sibling-leap target-depth backward)
2960 (goto-char start-point)
2961 (if depth (allout-depth) target-depth)
2964 (and (> (or last-depth (allout-depth)) 0)
2965 (= allout-recent-depth target-depth))
2966 (not (= start-prefix-beginning
2967 allout-recent-prefix-beginning)))
2968 allout-recent-prefix-beginning)
2970 (goto-char start-point)
2971 (if depth (allout-depth) target-depth)
2973 ;;;_ > allout-next-sibling-leap (&optional depth backward)
2974 (defun allout-next-sibling-leap (&optional depth backward)
2975 "Like `allout-next-sibling', but by direct search for topic at depth.
2977 Traverse at optional DEPTH, or current depth if none specified.
2979 Go backward if optional arg BACKWARD is non-nil.
2981 Return the start point of the new topic if successful, nil otherwise.
2983 Costs more than regular `allout-next-sibling' for short traversals:
2985 - we have to check the prior \(next, if travelling backwards)
2986 item to confirm connectivity with the prior topic, and
2987 - if confirmed, we have to reestablish the allout-recent-* settings with
2988 some extra navigation
2989 - if confirmation fails, we have to do more work to recover
2991 It is an increasingly big win when there are many intervening
2992 offspring before the next sibling, however, so
2993 `allout-next-sibling' resorts to this if it finds itself in that
2996 (if (if backward (bobp) (eobp))
2998 (let* ((start-point (point))
2999 (target-depth (or depth (allout-depth)))
3000 (search-whitespace-regexp nil)
3001 (depth-biased (- target-depth 2))
3002 (expression (if (<= target-depth 1)
3003 allout-depth-one-regexp
3004 (format allout-depth-specific-regexp
3005 depth-biased depth-biased)))
3009 (setq found (if backward
3010 (re-search-backward expression nil 'to-limit)
3012 (re-search-forward expression nil 'to-limit)))
3013 (if (and found (allout-aberrant-container-p))
3015 (setq done (or found (if backward (bobp) (eobp)))))
3017 (progn (goto-char start-point)
3019 ;; rationale: if any intervening items were at a lower depth, we
3020 ;; would now be on the first offspring at the target depth - ie,
3021 ;; the preceeding item (per the search direction) must be at a
3022 ;; lesser depth. that's all we need to check.
3023 (if backward (allout-next-heading) (allout-previous-heading))
3024 (if (< allout-recent-depth target-depth)
3025 ;; return to start and reestablish allout-recent-*:
3027 (goto-char start-point)
3031 ;; locate cursor and set allout-recent-*:
3032 (allout-goto-prefix))))))
3033 ;;;_ > allout-previous-sibling (&optional depth backward)
3034 (defun allout-previous-sibling (&optional depth backward)
3035 "Like `allout-forward-current-level' backwards, respecting invisible topics.
3037 Optional DEPTH specifies depth to traverse, default current depth.
3039 Optional BACKWARD reverses direction.
3041 Return depth if successful, nil otherwise."
3042 (allout-next-sibling depth (not backward))
3044 ;;;_ > allout-snug-back ()
3045 (defun allout-snug-back ()
3046 "Position cursor at end of previous topic.
3048 Presumes point is at the start of a topic prefix."
3049 (if (or (bobp) (eobp))
3052 (if (or (bobp) (not (= ?\n (preceding-char))))
3056 ;;;_ > allout-beginning-of-level ()
3057 (defun allout-beginning-of-level ()
3058 "Go back to the first sibling at this level, visible or not."
3059 (allout-end-of-level 'backward))
3060 ;;;_ > allout-end-of-level (&optional backward)
3061 (defun allout-end-of-level (&optional backward)
3062 "Go to the last sibling at this level, visible or not."
3064 (let ((depth (allout-depth)))
3065 (while (allout-previous-sibling depth nil))
3066 (prog1 allout-recent-depth
3067 (if (interactive-p) (allout-end-of-prefix)))))
3068 ;;;_ > allout-next-visible-heading (arg)
3069 (defun allout-next-visible-heading (arg)
3070 "Move to the next ARG'th visible heading line, backward if arg is negative.
3072 Move to buffer limit in indicated direction if headings are exhausted."
3075 (let* ((inhibit-field-text-motion t)
3076 (backward (if (< arg 0) (setq arg (* -1 arg))))
3077 (step (if backward -1 1))
3082 ;; Boundary condition:
3083 (not (if backward (bobp)(eobp)))
3084 ;; Move, skipping over all concealed lines in one fell swoop:
3085 (prog1 (condition-case nil (or (line-move step) t)
3087 (allout-beginning-of-current-line))
3088 ;; Deal with apparent header line:
3089 (if (not (looking-at allout-regexp))
3090 ;; not a header line, keep looking:
3092 (allout-prefix-data)
3093 (if (and (allout-do-doublecheck)
3094 (allout-aberrant-container-p))
3095 ;; skip this aberrant prospective header line:
3097 ;; this prospective headerline qualifies - register:
3098 (setq got allout-recent-prefix-beginning)
3099 ;; and break the loop:
3101 ;; Register this got, it may be the last:
3102 (if got (setq prev got))
3103 (setq arg (1- arg)))
3104 (cond (got ; Last move was to a prefix:
3105 (allout-end-of-prefix))
3106 (prev ; Last move wasn't, but prev was:
3108 (allout-end-of-prefix))
3109 ((not backward) (end-of-line) nil))))
3110 ;;;_ > allout-previous-visible-heading (arg)
3111 (defun allout-previous-visible-heading (arg)
3112 "Move to the previous heading line.
3114 With argument, repeats or can move forward if negative.
3115 A heading line is one that starts with a `*' (or that `allout-regexp'
3118 (prog1 (allout-next-visible-heading (- arg))
3119 (if (interactive-p) (allout-end-of-prefix))))
3120 ;;;_ > allout-forward-current-level (arg)
3121 (defun allout-forward-current-level (arg)
3122 "Position point at the next heading of the same level.
3124 Takes optional repeat-count, goes backward if count is negative.
3126 Returns resulting position, else nil if none found."
3128 (let ((start-depth (allout-current-depth))
3130 (backward (> 0 arg)))
3131 (if (= 0 start-depth)
3132 (error "No siblings, not in a topic..."))
3133 (if backward (setq arg (* -1 arg)))
3134 (allout-back-to-current-heading)
3135 (while (and (not (zerop arg))
3137 (allout-previous-sibling)
3138 (allout-next-sibling)))
3139 (setq arg (1- arg)))
3140 (if (not (interactive-p))
3142 (allout-end-of-prefix)
3143 (if (not (zerop arg))
3144 (error "Hit %s level %d topic, traversed %d of %d requested"
3145 (if backward "first" "last")
3147 (- (abs start-arg) arg)
3148 (abs start-arg))))))
3149 ;;;_ > allout-backward-current-level (arg)
3150 (defun allout-backward-current-level (arg)
3151 "Inverse of `allout-forward-current-level'."
3154 (let ((current-prefix-arg (* -1 arg)))
3155 (call-interactively 'allout-forward-current-level))
3156 (allout-forward-current-level (* -1 arg))))
3161 ;;;_ = allout-post-goto-bullet
3162 (defvar allout-post-goto-bullet nil
3163 "Outline internal var, for `allout-pre-command-business' hot-spot operation.
3165 When set, tells post-processing to reposition on topic bullet, and
3166 then unset it. Set by `allout-pre-command-business' when implementing
3167 hot-spot operation, where literal characters typed over a topic bullet
3168 are mapped to the command of the corresponding control-key on the
3169 `allout-mode-map'.")
3170 (make-variable-buffer-local 'allout-post-goto-bullet)
3171 ;;;_ = allout-command-counter
3172 (defvar allout-command-counter 0
3173 "Counter that monotonically increases in allout-mode buffers.
3175 Set by `allout-pre-command-business', to support allout addons in
3176 coordinating with allout activity.")
3177 (make-variable-buffer-local 'allout-command-counter)
3178 ;;;_ > allout-post-command-business ()
3179 (defun allout-post-command-business ()
3180 "Outline `post-command-hook' function.
3182 - Implement (and clear) `allout-post-goto-bullet', for hot-spot
3185 - Decrypt topic currently being edited if it was encrypted for a save."
3187 ; Apply any external change func:
3188 (if (not (allout-mode-p)) ; In allout-mode.
3191 (if (and (boundp 'allout-after-save-decrypt)
3192 allout-after-save-decrypt)
3193 (allout-after-saves-handler))
3195 ;; Implement allout-post-goto-bullet, if set:
3196 (if (and allout-post-goto-bullet
3197 (allout-current-bullet-pos))
3198 (progn (goto-char (allout-current-bullet-pos))
3199 (setq allout-post-goto-bullet nil)))
3201 ;;;_ > allout-pre-command-business ()
3202 (defun allout-pre-command-business ()
3203 "Outline `pre-command-hook' function for outline buffers.
3205 Among other things, implements special behavior when the cursor is on the
3206 topic bullet character.
3208 When the cursor is on the bullet character, self-insert characters are
3209 reinterpreted as the corresponding control-character in the
3210 `allout-mode-map'. The `allout-mode' `post-command-hook' insures that
3211 the cursor which has moved as a result of such reinterpretation is
3212 positioned on the bullet character of the destination topic.
3214 The upshot is that you can get easy, single \(ie, unmodified\) key
3215 outline maneuvering operations by positioning the cursor on the bullet
3216 char. When in this mode you can use regular cursor-positioning
3217 command/keystrokes to relocate the cursor off of a bullet character to
3218 return to regular interpretation of self-insert characters."
3220 (if (not (allout-mode-p))
3222 ;; Increment allout-command-counter
3223 (setq allout-command-counter (1+ allout-command-counter))
3224 ;; Do hot-spot navigation.
3225 (if (and (eq this-command 'self-insert-command)
3226 (eq (point)(allout-current-bullet-pos)))
3227 (allout-hotspot-key-handler))))
3228 ;;;_ > allout-hotspot-key-handler ()
3229 (defun allout-hotspot-key-handler ()
3230 "Catchall handling of key bindings in hot-spots.
3232 Translates unmodified keystrokes to corresponding allout commands, when
3233 they would qualify if prefixed with the allout-command-prefix, and sets
3234 this-command accordingly.
3236 Returns the qualifying command, if any, else nil."
3238 (let* ((key-string (if (numberp last-command-char)
3239 (char-to-string last-command-char)))
3240 (key-num (cond ((numberp last-command-char) last-command-char)
3241 ;; for XEmacs character type:
3242 ((and (fboundp 'characterp)
3243 (apply 'characterp (list last-command-char)))
3244 (apply 'char-to-int (list last-command-char)))
3252 ;; exclude control chars and escape:
3254 (setq mapped-binding
3255 (or (and (assoc key-string allout-keybindings-list)
3256 ;; translate literal membership on list:
3257 (cadr (assoc key-string allout-keybindings-list)))
3258 ;; translate as a keybinding:
3259 (key-binding (concat allout-command-prefix
3261 (if (and (<= 97 key-num) ; "a"
3262 (>= 122 key-num)) ; "z"
3263 (- key-num 96) key-num)))
3265 ;; Qualified as an allout command - do hot-spot operation.
3266 (setq allout-post-goto-bullet t)
3267 ;; accept-defaults nil, or else we'll get allout-item-icon-key-handler.
3268 (setq mapped-binding (key-binding (char-to-string key-num))))
3270 (while (keymapp mapped-binding)
3271 (setq mapped-binding
3272 (lookup-key mapped-binding (vector (read-char)))))
3275 (setq this-command mapped-binding)))))
3277 ;;;_ > allout-find-file-hook ()
3278 (defun allout-find-file-hook ()
3279 "Activate `allout-mode' on non-nil `allout-auto-activation', `allout-layout'.
3281 See `allout-init' for setup instructions."
3282 (if (and allout-auto-activation
3283 (not (allout-mode-p))
3287 ;;;_ - Topic Format Assessment
3288 ;;;_ > allout-solicit-alternate-bullet (depth &optional current-bullet)
3289 (defun allout-solicit-alternate-bullet (depth &optional current-bullet)
3291 "Prompt for and return a bullet char as an alternative to the current one.
3293 Offer one suitable for current depth DEPTH as default."
3295 (let* ((default-bullet (or (and (stringp current-bullet) current-bullet)
3296 (allout-bullet-for-depth depth)))
3297 (sans-escapes (regexp-sans-escapes allout-bullets-string))
3300 (goto-char (allout-current-bullet-pos))
3301 (setq choice (solicit-char-in-string
3302 (format "Select bullet: %s ('%s' default): "
3304 (substring-no-properties default-bullet))
3308 (if (string= choice "") default-bullet choice))
3310 ;;;_ > allout-distinctive-bullet (bullet)
3311 (defun allout-distinctive-bullet (bullet)
3312 "True if BULLET is one of those on `allout-distinctive-bullets-string'."
3313 (string-match (regexp-quote bullet) allout-distinctive-bullets-string))
3314 ;;;_ > allout-numbered-type-prefix (&optional prefix)
3315 (defun allout-numbered-type-prefix (&optional prefix)
3316 "True if current header prefix bullet is numbered bullet."
3317 (and allout-numbered-bullet
3318 (string= allout-numbered-bullet
3320 (allout-get-prefix-bullet prefix)
3321 (allout-get-bullet)))))
3322 ;;;_ > allout-encrypted-type-prefix (&optional prefix)
3323 (defun allout-encrypted-type-prefix (&optional prefix)
3324 "True if current header prefix bullet is for an encrypted entry \(body)."
3325 (and allout-topic-encryption-bullet
3326 (string= allout-topic-encryption-bullet
3328 (allout-get-prefix-bullet prefix)
3329 (allout-get-bullet)))))
3330 ;;;_ > allout-bullet-for-depth (&optional depth)
3331 (defun allout-bullet-for-depth (&optional depth)
3332 "Return outline topic bullet suited to optional DEPTH, or current depth."
3333 ;; Find bullet in plain-bullets-string modulo DEPTH.
3334 (if allout-stylish-prefixes
3335 (char-to-string (aref allout-plain-bullets-string
3336 (% (max 0 (- depth 2))
3337 allout-plain-bullets-string-len)))
3338 allout-primary-bullet)
3341 ;;;_ - Topic Production
3342 ;;;_ > allout-make-topic-prefix (&optional prior-bullet
3343 (defun allout-make-topic-prefix (&optional prior-bullet
3349 ;; Depth null means use current depth, non-null means we're either
3350 ;; opening a new topic after current topic, lower or higher, or we're
3351 ;; changing level of current topic.
3352 ;; Solicit dominates specified bullet-char.
3354 "Generate a topic prefix suitable for optional arg DEPTH, or current depth.
3356 All the arguments are optional.
3358 PRIOR-BULLET indicates the bullet of the prefix being changed, or
3359 nil if none. This bullet may be preserved (other options
3360 notwithstanding) if it is on the `allout-distinctive-bullets-string',
3363 Second arg NEW indicates that a new topic is being opened after the
3364 topic at point, if non-nil. Default bullet for new topics, eg, may
3365 be set (contingent to other args) to numbered bullets if previous
3366 sibling is one. The implication otherwise is that the current topic
3367 is being adjusted - shifted or rebulleted - and we don't consider
3368 bullet or previous sibling.
3370 Third arg DEPTH forces the topic prefix to that depth, regardless of
3371 the current topics' depth.
3373 If SOLICIT is non-nil, then the choice of bullet is solicited from
3374 user. If it's a character, then that character is offered as the
3375 default, otherwise the one suited to the context \(according to
3376 distinction or depth) is offered. \(This overrides other options,
3377 including, eg, a distinctive PRIOR-BULLET.) If non-nil, then the
3378 context-specific bullet is used.
3380 Fifth arg, NUMBER-CONTROL, matters only if `allout-numbered-bullet'
3381 is non-nil *and* soliciting was not explicitly invoked. Then
3382 NUMBER-CONTROL non-nil forces prefix to either numbered or
3383 denumbered format, depending on the value of the sixth arg, INDEX.
3385 \(Note that NUMBER-CONTROL does *not* apply to level 1 topics. Sorry...)
3387 If NUMBER-CONTROL is non-nil and sixth arg INDEX is non-nil then
3388 the prefix of the topic is forced to be numbered. Non-nil
3389 NUMBER-CONTROL and nil INDEX forces non-numbered format on the
3390 bullet. Non-nil NUMBER-CONTROL and non-nil, non-number INDEX means
3391 that the index for the numbered prefix will be derived, by counting
3392 siblings back to start of level. If INDEX is a number, then that
3393 number is used as the index for the numbered prefix (allowing, eg,
3394 sequential renumbering to not require this function counting back the
3395 index for each successive sibling)."
3397 ;; The options are ordered in likely frequence of use, most common
3398 ;; highest, least lowest. Ie, more likely to be doing prefix
3399 ;; adjustments than soliciting, and yet more than numbering.
3400 ;; Current prefix is least dominant, but most likely to be commonly
3406 (depth (or depth (allout-depth)))
3407 (header-lead allout-header-prefix)
3410 ;; Getting value for bullet char is practically the whole job:
3413 ; Simplest situation - level 1:
3414 ((<= depth 1) (setq header-lead "") allout-primary-bullet)
3415 ; Simple, too: all asterisks:
3416 (allout-old-style-prefixes
3417 ;; Cheat - make body the whole thing, null out header-lead and
3419 (setq body (make-string depth
3420 (string-to-char allout-primary-bullet)))
3421 (setq header-lead "")
3424 ;; (Neither level 1 nor old-style, so we're space padding.
3425 ;; Sneak it in the condition of the next case, whatever it is.)
3427 ;; Solicitation overrides numbering and other cases:
3428 ((progn (setq body (make-string (- depth 2) ?\ ))
3429 ;; The actual condition:
3431 (let* ((got (allout-solicit-alternate-bullet depth solicit)))
3432 ;; Gotta check whether we're numbering and got a numbered bullet:
3433 (setq numbering (and allout-numbered-bullet
3434 (not (and number-control (not index)))
3435 (string= got allout-numbered-bullet)))
3436 ;; Now return what we got, regardless:
3439 ;; Numbering invoked through args:
3440 ((and allout-numbered-bullet number-control)
3441 (if (setq numbering (not (setq denumbering (not index))))
3442 allout-numbered-bullet
3443 (if (and prior-bullet
3444 (not (string= allout-numbered-bullet
3447 (allout-bullet-for-depth depth))))
3449 ;;; Neither soliciting nor controlled numbering ;;;
3450 ;;; (may be controlled denumbering, tho) ;;;
3452 ;; Check wrt previous sibling:
3453 ((and new ; only check for new prefixes
3454 (<= depth (allout-depth))
3455 allout-numbered-bullet ; ... & numbering enabled
3457 (let ((sibling-bullet
3459 ;; Locate correct sibling:
3460 (or (>= depth (allout-depth))
3461 (allout-ascend-to-depth depth))
3462 (allout-get-bullet))))
3463 (if (and sibling-bullet
3464 (string= allout-numbered-bullet sibling-bullet))
3465 (setq numbering sibling-bullet)))))
3467 ;; Distinctive prior bullet?
3469 (allout-distinctive-bullet prior-bullet)
3470 ;; Either non-numbered:
3471 (or (not (and allout-numbered-bullet
3472 (string= prior-bullet allout-numbered-bullet)))
3473 ;; or numbered, and not denumbering:
3474 (setq numbering (not denumbering)))
3478 ;; Else, standard bullet per depth:
3479 ((allout-bullet-for-depth depth)))))
3485 (format "%d" (cond ((and index (numberp index)) index)
3486 (new (1+ (allout-sibling-index depth)))
3487 ((allout-sibling-index))))))
3490 ;;;_ > allout-open-topic (relative-depth &optional before offer-recent-bullet)
3491 (defun allout-open-topic (relative-depth &optional before offer-recent-bullet)
3492 "Open a new topic at depth DEPTH.
3494 New topic is situated after current one, unless optional flag BEFORE
3495 is non-nil, or unless current line is completely empty - lacking even
3496 whitespace - in which case open is done on the current line.
3498 When adding an offspring, it will be added immediately after the parent if
3499 the other offspring are exposed, or after the last child if the offspring
3500 are hidden. \(The intervening offspring will be exposed in the latter
3503 If OFFER-RECENT-BULLET is true, offer to use the bullet of the prior sibling.
3509 - Creation of new topics is with respect to the visible topic
3510 containing the cursor, regardless of intervening concealed ones.
3512 - New headers are generally created after/before the body of a
3513 topic. However, they are created right at cursor location if the
3514 cursor is on a blank line, even if that breaks the current topic
3515 body. This is intentional, to provide a simple means for
3516 deliberately dividing topic bodies.
3518 - Double spacing of topic lists is preserved. Also, the first
3519 level two topic is created double-spaced (and so would be
3520 subsequent siblings, if that's left intact). Otherwise,
3521 single-spacing is used.
3523 - Creation of sibling or nested topics is with respect to the topic
3524 you're starting from, even when creating backwards. This way you
3525 can easily create a sibling in front of the current topic without
3526 having to go to its preceding sibling, and then open forward
3529 (allout-beginning-of-current-line)
3530 (let* ((inhibit-field-text-motion t)
3531 (depth (+ (allout-current-depth) relative-depth))
3532 (opening-on-blank (if (looking-at "^\$")
3533 (not (setq before nil))))
3534 ;; bunch o vars set while computing ref-topic
3538 (ref-topic (save-excursion
3539 (cond ((< relative-depth 0)
3540 (allout-ascend-to-depth depth))
3541 ((>= relative-depth 1) nil)
3542 (t (allout-back-to-current-heading)))
3543 (setq ref-depth allout-recent-depth)
3545 (if (> allout-recent-prefix-end 1)
3546 (allout-recent-bullet)
3548 (setq opening-numbered
3550 (and allout-numbered-bullet
3551 (or (<= relative-depth 0)
3552 (allout-descend-to-depth depth))
3553 (if (allout-numbered-type-prefix)
3554 allout-numbered-bullet))))
3560 (if (not opening-on-blank)
3561 ; Positioning and vertical
3562 ; padding - only if not
3565 (goto-char ref-topic)
3566 (setq dbl-space ; Determine double space action:
3567 (or (and (<= relative-depth 0) ; not descending;
3569 ;; at b-o-b or preceded by a blank line?
3570 (or (> 0 (forward-line -1))
3571 (looking-at "^\\s-*$")
3574 ;; succeeded by a blank line?
3575 (allout-end-of-current-subtree)
3576 (looking-at "\n\n")))
3577 (and (= ref-depth 1)
3581 ;; Don't already have following
3582 ;; vertical padding:
3583 (not (allout-pre-next-prefix)))))))
3585 ;; Position to prior heading, if inserting backwards, and not
3587 (if (and before (>= relative-depth 0))
3588 (progn (allout-back-to-current-heading)
3589 (setq doing-beginning (bobp))
3591 (allout-previous-heading)))
3592 (if (and before (bobp))
3595 (if (<= relative-depth 0)
3596 ;; Not going inwards, don't snug up:
3602 (progn (end-of-line)
3603 (allout-pre-next-prefix)
3604 (while (and (= ?\n (following-char))
3609 (if (not (looking-at "^$"))
3611 (allout-end-of-current-subtree)
3612 (if (looking-at "\n\n") (forward-char 1))))
3613 ;; Going inwards - double-space if first offspring is
3614 ;; double-spaced, otherwise snug up.
3615 (allout-end-of-entry)
3619 (allout-beginning-of-current-line)
3622 ;; Blank lines between current header body and next
3623 ;; header - get to last substantive (non-white-space)
3625 (progn (setq dbl-space t)
3626 (re-search-backward "[^ \t\n]" nil t)))
3627 (if (looking-at "\n\n")
3630 (allout-next-heading)
3631 (when (> allout-recent-depth ref-depth)
3632 ;; This is an offspring.
3634 (looking-at "^\\s-*$")))
3635 (progn (forward-line 1)
3638 (allout-end-of-current-line))
3640 ;;(if doing-beginning (goto-char doing-beginning))
3642 ;; We insert a newline char rather than using open-line to
3643 ;; avoid rear-stickiness inheritence of read-only property.
3644 (progn (if (and (not (> depth ref-depth))
3647 (if (and (not dbl-space) (> depth ref-depth))
3653 (if (and dbl-space (not (> relative-depth 0)))
3655 (if (and (not (eobp))
3658 ;; bolp doesnt detect concealed
3659 ;; trailing newlines, compensate:
3662 (allout-hidden-p)))))
3665 (setq start (point))
3666 (insert (concat (allout-make-topic-prefix opening-numbered t depth)
3668 (setq end (1+ (point)))
3670 (allout-rebullet-heading (and offer-recent-bullet ref-bullet)
3672 (if (> relative-depth 0)
3673 (save-excursion (goto-char ref-topic)
3674 (allout-show-children)))
3677 (run-hook-with-args 'allout-structure-added-hook start end)
3680 ;;;_ > allout-open-subtopic (arg)
3681 (defun allout-open-subtopic (arg)
3682 "Open new topic header at deeper level than the current one.
3684 Negative universal arg means to open deeper, but place the new topic
3685 prior to the current one."
3687 (allout-open-topic 1 (> 0 arg) (< 1 arg)))
3688 ;;;_ > allout-open-sibtopic (arg)
3689 (defun allout-open-sibtopic (arg)
3690 "Open new topic header at same level as the current one.
3692 Positive universal arg means to use the bullet of the prior sibling.
3694 Negative universal arg means to place the new topic prior to the current
3697 (allout-open-topic 0 (> 0 arg) (not (= 1 arg))))
3698 ;;;_ > allout-open-supertopic (arg)
3699 (defun allout-open-supertopic (arg)
3700 "Open new topic header at shallower level than the current one.
3702 Negative universal arg means to open shallower, but place the new
3703 topic prior to the current one."
3706 (allout-open-topic -1 (> 0 arg) (< 1 arg)))
3708 ;;;_ - Outline Alteration
3709 ;;;_ : Topic Modification
3710 ;;;_ = allout-former-auto-filler
3711 (defvar allout-former-auto-filler nil
3712 "Name of modal fill function being wrapped by `allout-auto-fill'.")
3713 ;;;_ > allout-auto-fill ()
3714 (defun allout-auto-fill ()
3715 "`allout-mode' autofill function.
3717 Maintains outline hanging topic indentation if
3718 `allout-use-hanging-indents' is set."
3720 (when (not allout-inhibit-auto-fill)
3721 (let ((fill-prefix (if allout-use-hanging-indents
3722 ;; Check for topic header indentation:
3725 (if (looking-at allout-regexp)
3726 ;; ... construct indentation to account for
3727 ;; length of topic prefix:
3728 (make-string (progn (allout-end-of-prefix)
3731 (use-auto-fill-function (or allout-outside-normal-auto-fill-function
3734 (if (or allout-former-auto-filler allout-use-hanging-indents)
3735 (funcall use-auto-fill-function)))))
3736 ;;;_ > allout-reindent-body (old-depth new-depth &optional number)
3737 (defun allout-reindent-body (old-depth new-depth &optional number)
3738 "Reindent body lines which were indented at OLD-DEPTH to NEW-DEPTH.
3740 Optional arg NUMBER indicates numbering is being added, and it must
3743 Note that refill of indented paragraphs is not done."
3746 (allout-end-of-prefix)
3747 (let* ((new-margin (current-column))
3748 excess old-indent-begin old-indent-end
3749 ;; We want the column where the header-prefix text started
3750 ;; *before* the prefix was changed, so we infer it relative
3751 ;; to the new margin and the shift in depth:
3752 (old-margin (+ old-depth (- new-margin new-depth))))
3754 ;; Process lines up to (but excluding) next topic header:
3758 (and (re-search-forward "\n\\(\\s-*\\)"
3761 ;; Register the indent data, before we reset the
3762 ;; match data with a subsequent `looking-at':
3763 (setq old-indent-begin (match-beginning 1)
3764 old-indent-end (match-end 1))
3765 (not (looking-at allout-regexp)))
3766 (if (> 0 (setq excess (- (- old-indent-end old-indent-begin)
3768 ;; Text starts left of old margin - don't adjust:
3770 ;; Text was hanging at or right of old left margin -
3771 ;; reindent it, preserving its existing indentation
3772 ;; beyond the old margin:
3773 (delete-region old-indent-begin old-indent-end)
3774 (indent-to (+ new-margin excess (current-column))))))))))
3775 ;;;_ > allout-rebullet-current-heading (arg)
3776 (defun allout-rebullet-current-heading (arg)
3777 "Solicit new bullet for current visible heading."
3779 (let ((initial-col (current-column))
3780 (on-bullet (eq (point)(allout-current-bullet-pos)))
3782 (backwards (if (< arg 0)
3783 (setq arg (* arg -1)))))
3785 (save-excursion (allout-back-to-current-heading)
3786 (allout-end-of-prefix)
3787 (setq from allout-recent-prefix-beginning
3788 to allout-recent-prefix-end)
3789 (allout-rebullet-heading t ;;; solicit
3791 nil ;;; number-control
3793 t) ;;; do-successors
3794 (run-hook-with-args 'allout-exposure-change-hook
3799 (setq initial-col nil) ; Override positioning back to init col
3801 (allout-next-visible-heading 1)
3802 (allout-goto-prefix-doublechecked)
3803 (allout-next-visible-heading -1))))
3805 (cond (on-bullet (goto-char (allout-current-bullet-pos)))
3806 (initial-col (move-to-column initial-col)))))
3807 ;;;_ > allout-rebullet-heading (&optional solicit ...)
3808 (defun allout-rebullet-heading (&optional solicit
3814 "Adjust bullet of current topic prefix.
3816 All args are optional.
3818 If SOLICIT is non-nil, then the choice of bullet is solicited from
3819 user. If it's a character, then that character is offered as the
3820 default, otherwise the one suited to the context \(according to
3821 distinction or depth) is offered. If non-nil, then the
3822 context-specific bullet is just used.
3824 Second arg DEPTH forces the topic prefix to that depth, regardless
3825 of the topic's current depth.
3827 Third arg NUMBER-CONTROL can force the prefix to or away from
3828 numbered form. It has effect only if `allout-numbered-bullet' is
3829 non-nil and soliciting was not explicitly invoked (via first arg).
3830 Its effect, numbering or denumbering, then depends on the setting
3831 of the forth arg, INDEX.
3833 If NUMBER-CONTROL is non-nil and forth arg INDEX is nil, then the
3834 prefix of the topic is forced to be non-numbered. Null index and
3835 non-nil NUMBER-CONTROL forces denumbering. Non-nil INDEX (and
3836 non-nil NUMBER-CONTROL) forces a numbered-prefix form. If non-nil
3837 INDEX is a number, then that number is used for the numbered
3838 prefix. Non-nil and non-number means that the index for the
3839 numbered prefix will be derived by allout-make-topic-prefix.
3841 Fifth arg DO-SUCCESSORS t means re-resolve count on succeeding
3844 Cf vars `allout-stylish-prefixes', `allout-old-style-prefixes',
3845 and `allout-numbered-bullet', which all affect the behavior of
3848 (let* ((current-depth (allout-depth))
3849 (new-depth (or new-depth current-depth))
3850 (mb allout-recent-prefix-beginning)
3851 (me allout-recent-prefix-end)
3852 (current-bullet (buffer-substring-no-properties (- me 1) me))
3853 (has-annotation (get-text-property mb 'allout-was-hidden))
3854 (new-prefix (allout-make-topic-prefix current-bullet
3861 ;; Is new one is identical to old?
3862 (if (and (= current-depth new-depth)
3863 (string= current-bullet
3864 (substring new-prefix (1- (length new-prefix)))))
3868 ;; New prefix probably different from old:
3869 ; get rid of old one:
3870 (allout-unprotected (delete-region mb me))
3872 ; Dispense with number if
3873 ; numbered-bullet prefix:
3874 (if (and allout-numbered-bullet
3875 (string= allout-numbered-bullet current-bullet)
3876 (looking-at "[0-9]+"))
3878 (delete-region (match-beginning 0)(match-end 0))))
3880 ;; convey 'allout-was-hidden annotation, if original had it:
3882 (put-text-property 0 (length new-prefix) 'allout-was-hidden t
3885 ; Put in new prefix:
3886 (allout-unprotected (insert new-prefix))
3888 ;; Reindent the body if elected, margin changed, and not encrypted body:
3889 (if (and allout-reindent-bodies
3890 (not (= new-depth current-depth))
3891 (not (allout-encrypted-topic-p)))
3892 (allout-reindent-body current-depth new-depth))
3894 ;; Recursively rectify successive siblings of orig topic if
3895 ;; caller elected for it:
3898 (while (allout-next-sibling new-depth nil)
3900 (cond ((numberp index) (1+ index))
3901 ((not number-control) (allout-sibling-index))))
3902 (if (allout-numbered-type-prefix)
3903 (allout-rebullet-heading nil ;;; solicit
3904 new-depth ;;; new-depth
3905 number-control;;; number-control
3907 nil))))) ;;;(dont!)do-successors
3908 ) ; (if (and (= current-depth new-depth)...))
3909 ) ; let* ((current-depth (allout-depth))...)
3911 ;;;_ > allout-rebullet-topic (arg)
3912 (defun allout-rebullet-topic (arg &optional sans-offspring)
3913 "Rebullet the visible topic containing point and all contained subtopics.
3915 Descends into invisible as well as visible topics, however.
3917 When optional sans-offspring is non-nil, subtopics are not
3918 shifted. \(Shifting a topic outwards without shifting its
3919 offspring is disallowed, since this would create a \"containment
3920 discontinuity\", where the depth difference between a topic and
3921 its immediate offspring is greater than one.)
3923 With repeat count, shift topic depth by that amount."
3925 (let ((start-col (current-column)))
3928 (cond ((null arg) (setq arg 0))
3929 ((listp arg) (setq arg (car arg))))
3930 ;; Fill the user in, in case we're shifting a big topic:
3931 (if (not (zerop arg)) (message "Shifting..."))
3932 (allout-back-to-current-heading)
3933 (if (<= (+ allout-recent-depth arg) 0)
3934 (error "Attempt to shift topic below level 1"))
3935 (allout-rebullet-topic-grunt arg nil nil nil nil sans-offspring)
3936 (if (not (zerop arg)) (message "Shifting... done.")))
3937 (move-to-column (max 0 (+ start-col arg)))))
3938 ;;;_ > allout-rebullet-topic-grunt (&optional relative-depth ...)
3939 (defun allout-rebullet-topic-grunt (&optional relative-depth
3945 "Like `allout-rebullet-topic', but on nearest containing topic
3948 See `allout-rebullet-heading' for rebulleting behavior.
3950 All arguments are optional.
3952 First arg RELATIVE-DEPTH means to shift the depth of the entire
3955 Several subsequent args are for internal recursive use by the function
3956 itself: STARTING-DEPTH, STARTING-POINT, and INDEX.
3958 Finally, if optional SANS-OFFSPRING is non-nil then the offspring
3959 are not shifted. \(Shifting a topic outwards without shifting
3960 its offspring is disallowed, since this would create a
3961 \"containment discontinuity\", where the depth difference between
3962 a topic and its immediate offspring is greater than one..)"
3964 ;; XXX the recursion here is peculiar, and in general the routine may
3965 ;; need simplification with refactoring.
3967 (if (and sans-offspring
3969 (< relative-depth 0))
3970 (error (concat "Attempt to shift topic outwards without offspring,"
3971 " would cause containment discontinuity.")))
3973 (let* ((relative-depth (or relative-depth 0))
3974 (new-depth (allout-depth))
3975 (starting-depth (or starting-depth new-depth))
3976 (on-starting-call (null starting-point))
3978 ;; Leave index null on starting call, so rebullet-heading
3979 ;; calculates it at what might be new depth:
3980 (and (or (zerop relative-depth)
3981 (not on-starting-call))
3982 (allout-sibling-index))))
3983 (starting-index index)
3984 (moving-outwards (< 0 relative-depth))
3985 (starting-point (or starting-point (point)))
3986 (local-point (point)))
3988 ;; Sanity check for excessive promotion done only on starting call:
3989 (and on-starting-call
3991 (> 0 (+ starting-depth relative-depth))
3992 (error "Attempt to shift topic out beyond level 1"))
3994 (cond ((= starting-depth new-depth)
3995 ;; We're at depth to work on this one.
3997 ;; When shifting out we work on the children before working on
3998 ;; the parent to avoid interim `allout-aberrant-container-p'
3999 ;; aberrancy, and vice-versa when shifting in:
4000 (if (>= relative-depth 0)
4001 (allout-rebullet-heading nil
4002 (+ starting-depth relative-depth)
4005 nil)) ;;; do-successors
4006 (when (not sans-offspring)
4007 ;; ... and work on subsequent ones which are at greater depth:
4009 (allout-next-heading)
4010 (while (and (not (eobp))
4011 (< starting-depth (allout-depth)))
4012 (setq index (1+ index))
4013 (allout-rebullet-topic-grunt relative-depth
4017 (when (< relative-depth 0)
4019 (goto-char local-point)
4020 (allout-rebullet-heading nil ;;; solicit
4021 (+ starting-depth relative-depth)
4024 nil)))) ;;; do-successors
4026 ((< starting-depth new-depth)
4027 ;; Rare case - subtopic more than one level deeper than parent.
4028 ;; Treat this one at an even deeper level:
4029 (allout-rebullet-topic-grunt relative-depth
4035 (if on-starting-call
4037 ;; Rectify numbering of former siblings of the adjusted topic,
4038 ;; if topic has changed depth
4039 (if (or do-successors
4040 (and (not (zerop relative-depth))
4041 (or (= allout-recent-depth starting-depth)
4042 (= allout-recent-depth (+ starting-depth
4044 (allout-rebullet-heading nil nil nil nil t))
4045 ;; Now rectify numbering of new siblings of the adjusted topic,
4046 ;; if depth has been changed:
4047 (progn (goto-char starting-point)
4048 (if (not (zerop relative-depth))
4049 (allout-rebullet-heading nil nil nil nil t)))))
4052 ;;;_ > allout-renumber-to-depth (&optional depth)
4053 (defun allout-renumber-to-depth (&optional depth)
4054 "Renumber siblings at current depth.
4056 Affects superior topics if optional arg DEPTH is less than current depth.
4058 Returns final depth."
4060 ;; Proceed by level, processing subsequent siblings on each,
4061 ;; ascending until we get shallower than the start depth:
4063 (let ((ascender (allout-depth))
4065 (while (and (not (eobp))
4067 (>= allout-recent-depth depth)
4068 (>= ascender depth))
4069 ; Skip over all topics at
4070 ; lesser depths, which can not
4071 ; have been disturbed:
4072 (while (and (not (setq was-eobp (eobp)))
4073 (> allout-recent-depth ascender))
4074 (allout-next-heading))
4075 ; Prime ascender for ascension:
4076 (setq ascender (1- allout-recent-depth))
4077 (if (>= allout-recent-depth depth)
4078 (allout-rebullet-heading nil ;;; solicit
4080 nil ;;; number-control
4082 t)) ;;; do-successors
4083 (if was-eobp (goto-char (point-max)))))
4084 allout-recent-depth)
4085 ;;;_ > allout-number-siblings (&optional denumber)
4086 (defun allout-number-siblings (&optional denumber)
4087 "Assign numbered topic prefix to this topic and its siblings.
4089 With universal argument, denumber - assign default bullet to this
4090 topic and its siblings.
4092 With repeated universal argument (`^U^U'), solicit bullet for each
4093 rebulleting each topic at this level."
4098 (allout-back-to-current-heading)
4099 (allout-beginning-of-level)
4100 (let ((depth allout-recent-depth)
4101 (index (if (not denumber) 1))
4102 (use-bullet (equal '(16) denumber))
4105 (allout-rebullet-heading use-bullet ;;; solicit
4107 t ;;; number-control
4109 nil) ;;; do-successors
4110 (if index (setq index (1+ index)))
4111 (setq more (allout-next-sibling depth nil))))))
4112 ;;;_ > allout-shift-in (arg)
4113 (defun allout-shift-in (arg)
4114 "Increase depth of current heading and any items collapsed within it.
4116 With a negative argument, the item is shifted out using
4117 `allout-shift-out', instead.
4119 With an argument greater than one, shift-in the item but not its
4120 offspring, making the item into a sibling of its former children,
4121 and a child of sibling that formerly preceeded it.
4123 You are not allowed to shift the first offspring of a topic
4124 inwards, because that would yield a \"containment
4125 discontinuity\", where the depth difference between a topic and
4126 its immediate offspring is greater than one. The first topic in
4127 the file can be adjusted to any positive depth, however."
4131 (allout-shift-out (* arg -1))
4132 ;; refuse to create a containment discontinuity:
4134 (allout-back-to-current-heading)
4136 (let* ((current-depth allout-recent-depth)
4137 (start-point (point))
4138 (predecessor-depth (progn
4140 (allout-goto-prefix-doublechecked)
4141 (if (< (point) start-point)
4144 (if (and (> predecessor-depth 0)
4145 (> (1+ current-depth)
4146 (1+ predecessor-depth)))
4147 (error (concat "Disallowed shift deeper than"
4148 " containing topic's children."))))))
4149 (let ((where (point)))
4150 (allout-rebullet-topic 1 (and (> arg 1) 'sans-offspring))
4151 (run-hook-with-args 'allout-structure-shifted-hook arg where))))
4152 ;;;_ > allout-shift-out (arg)
4153 (defun allout-shift-out (arg)
4154 "Decrease depth of current heading and any topics collapsed within it.
4155 This will make the item a sibling of its former container.
4157 With a negative argument, the item is shifted in using
4158 `allout-shift-in', instead.
4160 With an argument greater than one, shift-out the item's offspring
4161 but not the item itself, making the former children siblings of
4164 With an argument greater than 1, the item's offspring are shifted
4165 out without shifting the item. This will make the immediate
4166 subtopics into siblings of the item."
4169 (allout-shift-in (* arg -1))
4170 ;; Get proper exposure in this area:
4171 (save-excursion (if (allout-ascend)
4172 (allout-show-children)))
4173 ;; Show collapsed children if there's a successor which will become
4175 (if (and (allout-current-topic-collapsed-p)
4176 (save-excursion (allout-next-sibling)))
4177 (allout-show-children))
4178 (let ((where (and (allout-depth) allout-recent-prefix-beginning)))
4181 ;; Shift the offspring but not the topic:
4182 (let ((children-chart (allout-chart-subtree 1)))
4183 (if (listp (car children-chart))
4185 (setq children-chart (allout-flatten children-chart)))
4187 (dolist (child-point children-chart)
4188 (goto-char child-point)
4189 (allout-shift-out 1))))
4190 (allout-rebullet-topic (* arg -1))))
4191 (run-hook-with-args 'allout-structure-shifted-hook (* arg -1) where))))
4192 ;;;_ : Surgery (kill-ring) functions with special provisions for outlines:
4193 ;;;_ > allout-kill-line (&optional arg)
4194 (defun allout-kill-line (&optional arg)
4195 "Kill line, adjusting subsequent lines suitably for outline mode."
4199 (if (or (not (allout-mode-p))
4201 (not (looking-at allout-regexp)))
4202 ;; Just do a regular kill:
4204 ;; Ah, have to watch out for adjustments:
4205 (let* ((beg (point))
4207 (beg-hidden (allout-hidden-p))
4208 (end-hidden (save-excursion (allout-end-of-current-line)
4211 (depth (allout-depth)))
4213 (allout-annotate-hidden beg end)
4214 (if (and (not beg-hidden) (not end-hidden))
4215 (allout-unprotected (kill-line arg))
4217 (allout-deannotate-hidden beg end)
4219 (if allout-numbered-bullet
4220 (save-excursion ; Renumber subsequent topics if needed:
4221 (if (not (looking-at allout-regexp))
4222 (allout-next-heading))
4223 (allout-renumber-to-depth depth)))
4224 (run-hook-with-args 'allout-structure-deleted-hook depth (point)))))
4225 ;;;_ > allout-copy-line-as-kill ()
4226 (defun allout-copy-line-as-kill ()
4227 "Like allout-kill-topic, but save to kill ring instead of deleting."
4229 (let ((buffer-read-only t))
4232 (buffer-read-only nil))))
4233 ;;;_ > allout-kill-topic ()
4234 (defun allout-kill-topic ()
4235 "Kill topic together with subtopics.
4237 Trailing whitespace is killed with a topic if that whitespace:
4239 - would separate the topic from a subsequent sibling
4240 - would separate the topic from the end of buffer
4241 - would not be added to whitespace already separating the topic from the
4244 Topic exposure is marked with text-properties, to be used by
4245 allout-yank-processing for exposure recovery."
4248 (let* ((inhibit-field-text-motion t)
4249 (beg (prog1 (allout-back-to-current-heading) (beginning-of-line)))
4251 (depth allout-recent-depth))
4252 (allout-end-of-current-subtree)
4253 (if (and (/= (current-column) 0) (not (eobp)))
4256 (if (and (looking-at "\n")
4258 (or (not (allout-next-heading))
4259 (= depth allout-recent-depth)))
4260 (and (> (- beg (point-min)) 3)
4261 (string= (buffer-substring (- beg 2) beg) "\n\n"))))
4264 (allout-annotate-hidden beg (setq end (point)))
4266 (allout-unprotected (kill-region beg end))
4267 (if buffer-read-only
4268 ;; eg, during copy-as-kill.
4269 (allout-deannotate-hidden beg end)))
4272 (allout-renumber-to-depth depth))
4273 (run-hook-with-args 'allout-structure-deleted-hook depth (point))))
4274 ;;;_ > allout-copy-topic-as-kill ()
4275 (defun allout-copy-topic-as-kill ()
4276 "Like allout-kill-topic, but save to kill ring instead of deleting."
4278 (let ((buffer-read-only t))
4281 (buffer-read-only (message "Topic copied...")))))
4282 ;;;_ > allout-annotate-hidden (begin end)
4283 (defun allout-annotate-hidden (begin end)
4284 "Qualify text with properties to indicate exposure status."
4286 (let ((was-modified (buffer-modified-p))
4287 (buffer-read-only nil))
4288 (allout-deannotate-hidden begin end)
4291 (let (done next prev overlay)
4293 ;; at or advance to start of next hidden region:
4294 (if (not (allout-hidden-p))
4297 (next-single-char-property-change (point)
4300 (if (or (not next) (eq prev next))
4301 ;; still not at start of hidden area - must not be any left.
4305 (if (not (allout-hidden-p))
4306 ;; still not at start of hidden area.
4308 (setq overlay (allout-get-invisibility-overlay))
4309 (setq next (overlay-end overlay)
4311 ;; advance to end of this hidden area:
4315 (let ((buffer-undo-list t))
4316 (put-text-property (overlay-start overlay) next
4317 'allout-was-hidden t)))))))))
4318 (set-buffer-modified-p was-modified)))
4319 ;;;_ > allout-deannotate-hidden (begin end)
4320 (defun allout-deannotate-hidden (begin end)
4321 "Remove allout hidden-text annotation between BEGIN and END."
4324 (let ((inhibit-read-only t)
4325 (buffer-undo-list t))
4326 ;(remove-text-properties begin end '(allout-was-hidden t))
4328 ;;;_ > allout-hide-by-annotation (begin end)
4329 (defun allout-hide-by-annotation (begin end)
4330 "Translate text properties indicating exposure status into actual exposure."
4333 (let ((was-modified (buffer-modified-p))
4336 ;; at or advance to start of next annotation:
4337 (if (not (get-text-property (point) 'allout-was-hidden))
4338 (setq next (next-single-char-property-change (point)
4341 (if (or (not next) (eq prev next))
4342 ;; no more or not advancing - must not be any left.
4346 (if (not (get-text-property (point) 'allout-was-hidden))
4347 ;; still not at start of annotation.
4349 ;; advance to just after end of this annotation:
4350 (setq next (next-single-char-property-change (point)
4353 (overlay-put (make-overlay prev next)
4354 'category 'allout-exposure-category)
4355 (allout-deannotate-hidden prev next)
4357 (if next (goto-char next)))))
4358 (set-buffer-modified-p was-modified))))
4359 ;;;_ > allout-yank-processing ()
4360 (defun allout-yank-processing (&optional arg)
4362 "Incidental allout-specific business to be done just after text yanks.
4364 Does depth adjustment of yanked topics, when:
4366 1 the stuff being yanked starts with a valid outline header prefix, and
4367 2 it is being yanked at the end of a line which consists of only a valid
4370 Also, adjusts numbering of subsequent siblings when appropriate.
4372 Depth adjustment alters the depth of all the topics being yanked
4373 the amount it takes to make the first topic have the depth of the
4374 header into which it's being yanked.
4376 The point is left in front of yanked, adjusted topics, rather than
4377 at the end (and vice-versa with the mark). Non-adjusted yanks,
4378 however, are left exactly like normal, non-allout-specific yanks."
4381 ; Get to beginning, leaving
4382 ; region around subject:
4383 (if (< (allout-mark-marker t) (point))
4384 (exchange-point-and-mark))
4385 (let* ( ;; inhibit aberrance doublecheck while reconciling disparate pastes:
4386 (allout-during-yank-processing t)
4389 (subj-end (allout-mark-marker t))
4390 ;; 'resituate' if yanking an entire topic into topic header:
4391 (resituate (and (allout-e-o-prefix-p)
4392 (looking-at allout-regexp)
4393 (allout-prefix-data)))
4394 ;; `rectify-numbering' if resituating (where several topics may
4395 ;; be resituating) or yanking a topic into a topic slot (bol):
4396 (rectify-numbering (or resituate
4397 (and into-bol (looking-at allout-regexp)))))
4399 ; The yanked stuff is a topic:
4400 (let* ((inhibit-field-text-motion t)
4401 (prefix-len (if (not (match-end 1))
4403 (- (match-end 1) subj-beg)))
4404 (subj-depth allout-recent-depth)
4405 (prefix-bullet (allout-recent-bullet))
4407 ;; Nil if adjustment unnecessary, otherwise depth to which
4408 ;; adjustment should be made:
4410 (and (goto-char subj-end)
4412 (goto-char subj-beg)
4413 (and (looking-at allout-regexp)
4416 (not (= (point) subj-beg)))
4417 (looking-at allout-regexp)
4418 (allout-prefix-data))
4419 allout-recent-depth)))
4421 (setq rectify-numbering allout-numbered-bullet)
4423 ; Do the adjustment:
4426 (narrow-to-region subj-beg subj-end)
4427 ; Trim off excessive blank
4428 ; line at end, if any:
4429 (goto-char (point-max))
4430 (if (looking-at "^$")
4431 (allout-unprotected (delete-char -1)))
4432 ; Work backwards, with each
4434 ; successively excluding the
4435 ; last processed topic from
4436 ; the narrow region:
4438 (allout-back-to-current-heading)
4439 ; go as high as we can in each bunch:
4440 (while (allout-ascend))
4443 (allout-rebullet-topic-grunt (- adjust-to-depth
4446 (if (setq more (not (bobp)))
4449 (narrow-to-region subj-beg (point))))))
4450 ;; Preserve new bullet if it's a distinctive one, otherwise
4452 (if (string-match (regexp-quote prefix-bullet)
4453 allout-distinctive-bullets-string)
4454 ; Delete from bullet of old to
4455 ; before bullet of new:
4459 (delete-region (point) subj-beg))
4460 (set-marker (allout-mark-marker t) subj-end)
4461 (goto-char subj-beg)
4462 (allout-end-of-prefix))
4463 ; Delete base subj prefix,
4467 (delete-region (point) (+ (point)
4469 (- adjust-to-depth subj-depth)))
4470 ; and delete residual subj
4471 ; prefix digits and space:
4472 (while (looking-at "[0-9]") (delete-char 1))
4473 (if (looking-at " ") (delete-char 1))))))
4474 (exchange-point-and-mark))))
4475 (if rectify-numbering
4478 ; Give some preliminary feedback:
4479 (message "... reconciling numbers")
4480 ; ... and renumber, in case necessary:
4481 (goto-char subj-beg)
4482 (if (allout-goto-prefix-doublechecked)
4484 (allout-rebullet-heading nil ;;; solicit
4485 (allout-depth) ;;; depth
4486 nil ;;; number-control
4490 (if (or into-bol resituate)
4491 (allout-hide-by-annotation (point) (allout-mark-marker t))
4492 (allout-deannotate-hidden (allout-mark-marker t) (point)))
4494 (exchange-point-and-mark))
4495 (run-hook-with-args 'allout-structure-added-hook subj-beg subj-end)))
4496 ;;;_ > allout-yank (&optional arg)
4497 (defun allout-yank (&optional arg)
4498 "`allout-mode' yank, with depth and numbering adjustment of yanked topics.
4500 Non-topic yanks work no differently than normal yanks.
4502 If a topic is being yanked into a bare topic prefix, the depth of the
4503 yanked topic is adjusted to the depth of the topic prefix.
4505 1 we're yanking in an `allout-mode' buffer
4506 2 the stuff being yanked starts with a valid outline header prefix, and
4507 3 it is being yanked at the end of a line which consists of only a valid
4510 If these conditions hold then the depth of the yanked topics are all
4511 adjusted the amount it takes to make the first one at the depth of the
4512 header into which it's being yanked.
4514 The point is left in front of yanked, adjusted topics, rather than
4515 at the end (and vice-versa with the mark). Non-adjusted yanks,
4516 however, (ones that don't qualify for adjustment) are handled
4517 exactly like normal yanks.
4519 Numbering of yanked topics, and the successive siblings at the depth
4520 into which they're being yanked, is adjusted.
4522 `allout-yank-pop' works with `allout-yank' just like normal `yank-pop'
4523 works with normal `yank' in non-outline buffers."
4526 (setq this-command 'yank)
4530 (allout-yank-processing)))
4531 ;;;_ > allout-yank-pop (&optional arg)
4532 (defun allout-yank-pop (&optional arg)
4533 "Yank-pop like `allout-yank' when popping to bare outline prefixes.
4535 Adapts level of popped topics to level of fresh prefix.
4537 Note - prefix changes to distinctive bullets will stick, if followed
4538 by pops to non-distinctive yanks. Bug..."
4541 (setq this-command 'yank)
4544 (allout-yank-processing)))
4546 ;;;_ - Specialty bullet functions
4547 ;;;_ : File Cross references
4548 ;;;_ > allout-resolve-xref ()
4549 (defun allout-resolve-xref ()
4550 "Pop to file associated with current heading, if it has an xref bullet.
4552 \(Works according to setting of `allout-file-xref-bullet')."
4554 (if (not allout-file-xref-bullet)
4556 "Outline cross references disabled - no `allout-file-xref-bullet'")
4557 (if (not (string= (allout-current-bullet) allout-file-xref-bullet))
4558 (error "Current heading lacks cross-reference bullet `%s'"
4559 allout-file-xref-bullet)
4560 (let ((inhibit-field-text-motion t)
4563 (let* ((text-start allout-recent-prefix-end)
4564 (heading-end (progn (end-of-line) (point))))
4565 (goto-char text-start)
4567 (if (re-search-forward "\\s-\\(\\S-*\\)" heading-end t)
4568 (buffer-substring (match-beginning 1) (match-end 1))))))
4569 (setq file-name (expand-file-name file-name))
4570 (if (or (file-exists-p file-name)
4571 (if (file-writable-p file-name)
4572 (y-or-n-p (format "%s not there, create one? "
4574 (error "%s not found and can't be created" file-name)))
4575 (condition-case failure
4576 (find-file-other-window file-name)
4578 (error "%s not found" file-name))
4584 ;;;_ #6 Exposure Control
4587 ;;;_ > allout-flag-region (from to flag)
4588 (defun allout-flag-region (from to flag)
4589 "Conceal text between FROM and TO if FLAG is non-nil, else reveal it.
4591 Exposure-change hook `allout-exposure-change-hook' is run with the same
4592 arguments as this function, after the exposure changes are made. \(The old
4593 `allout-view-change-hook' is being deprecated, and eventually will not be
4596 ;; We use outline invisibility spec.
4597 (remove-overlays from to 'category 'allout-exposure-category)
4599 (let ((o (make-overlay from to)))
4600 (overlay-put o 'category 'allout-exposure-category)
4601 (when (featurep 'xemacs)
4602 (let ((props (symbol-plist 'allout-exposure-category)))
4604 (overlay-put o (pop props) (pop props)))))))
4605 (run-hooks 'allout-view-change-hook)
4606 (run-hook-with-args 'allout-exposure-change-hook from to flag))
4607 ;;;_ > allout-flag-current-subtree (flag)
4608 (defun allout-flag-current-subtree (flag)
4609 "Conceal currently-visible topic's subtree if FLAG non-nil, else reveal it."
4612 (allout-back-to-current-heading)
4613 (let ((inhibit-field-text-motion t))
4615 (allout-flag-region (point)
4616 ;; Exposing must not leave trailing blanks hidden,
4617 ;; but can leave them exposed when hiding, so we
4618 ;; can use flag's inverse as the
4619 ;; include-trailing-blank cue:
4620 (allout-end-of-current-subtree (not flag))
4623 ;;;_ - Topic-specific
4624 ;;;_ > allout-show-entry ()
4625 (defun allout-show-entry ()
4626 "Like `allout-show-current-entry', but reveals entries in hidden topics.
4628 This is a way to give restricted peek at a concealed locality without the
4629 expense of exposing its context, but can leave the outline with aberrant
4630 exposure. `allout-show-offshoot' should be used after the peek to rectify
4636 (allout-goto-prefix-doublechecked)
4637 (setq beg (if (allout-hidden-p) (1- (point)) (point)))
4638 (setq end (allout-pre-next-prefix))
4639 (allout-flag-region beg end nil)
4641 ;;;_ > allout-show-children (&optional level strict)
4642 (defun allout-show-children (&optional level strict)
4644 "If point is visible, show all direct subheadings of this heading.
4646 Otherwise, do `allout-show-to-offshoot', and then show subheadings.
4648 Optional LEVEL specifies how many levels below the current level
4649 should be shown, or all levels if t. Default is 1.
4651 Optional STRICT means don't resort to -show-to-offshoot, no matter
4652 what. This is basically so -show-to-offshoot, which is called by
4653 this function, can employ the pure offspring-revealing capabilities of
4656 Returns point at end of subtree that was opened, if any. (May get a
4657 point of non-opened subtree?)"
4660 (let ((start-point (point)))
4661 (if (and (not strict)
4664 (progn (allout-show-to-offshoot) ; Point's concealed, open to
4666 ;; Then recurse, but with "strict" set so we don't
4667 ;; infinite regress:
4668 (allout-show-children level t))
4671 (allout-beginning-of-current-line)
4674 ;; translate the level spec for this routine to the ones
4675 ;; used by -chart-subtree and -chart-to-reveal:
4676 (chart-level (cond ((not level) 1)
4679 (chart (allout-chart-subtree chart-level))
4680 (to-reveal (or (allout-chart-to-reveal chart chart-level)
4681 ;; interactive, show discontinuous children:
4685 (allout-back-to-current-heading)
4686 (setq depth (allout-current-depth))
4687 (and (allout-next-heading)
4688 (> allout-recent-depth
4691 "Discontinuous offspring; use `%s %s'%s."
4692 (substitute-command-keys
4693 "\\[universal-argument]")
4694 (substitute-command-keys
4695 "\\[allout-shift-out]")
4696 " to elevate them.")
4697 (allout-chart-to-reveal
4698 chart (- allout-recent-depth depth))))))
4699 (goto-char start-point)
4700 (when (and strict (allout-hidden-p))
4701 ;; Concealed root would already have been taken care of,
4702 ;; unless strict was set.
4703 (allout-flag-region (point) (allout-snug-back) nil)
4704 (when allout-show-bodies
4705 (goto-char (car to-reveal))
4706 (allout-show-current-entry)))
4708 (goto-char (car to-reveal))
4709 (allout-flag-region (save-excursion (allout-snug-back) (point))
4710 (progn (search-forward "\n" nil t)
4713 (when allout-show-bodies
4714 (goto-char (car to-reveal))
4715 (allout-show-current-entry))
4716 (setq to-reveal (cdr to-reveal)))))))
4717 ;; Compensate for `save-excursion's maintenance of point
4718 ;; within invisible text:
4719 (goto-char start-point)))
4720 ;;;_ > allout-show-to-offshoot ()
4721 (defun allout-show-to-offshoot ()
4722 "Like `allout-show-entry', but reveals all concealed ancestors, as well.
4724 Useful for coherently exposing to a random point in a hidden region."
4727 (let ((inhibit-field-text-motion t)
4729 (orig-pref (allout-goto-prefix-doublechecked))
4732 (while (or (> bag-it 1) (allout-hidden-p))
4733 (while (allout-hidden-p)
4734 (move-beginning-of-line 1)
4735 (if (allout-hidden-p) (forward-char -1)))
4736 (if (= last-at (setq last-at (point)))
4737 ;; Oops, we're not making any progress! Show the current topic
4738 ;; completely, and try one more time here, if we haven't already.
4739 (progn (beginning-of-line)
4740 (allout-show-current-subtree)
4742 (setq bag-it (1+ bag-it))
4744 (error "allout-show-to-offshoot: %s"
4745 "Stumped by aberrant nesting.")))
4746 (if (> bag-it 0) (setq bag-it 0))
4747 (allout-show-children)
4748 (goto-char orig-pref)))
4749 (goto-char orig-pt)))
4750 (if (allout-hidden-p)
4751 (allout-show-entry)))
4752 ;;;_ > allout-hide-current-entry ()
4753 (defun allout-hide-current-entry ()
4754 "Hide the body directly following this heading."
4756 (allout-back-to-current-heading)
4758 (let ((inhibit-field-text-motion t))
4760 (allout-flag-region (point)
4761 (progn (allout-end-of-entry) (point))
4763 ;;;_ > allout-show-current-entry (&optional arg)
4764 (defun allout-show-current-entry (&optional arg)
4765 "Show body following current heading, or hide entry with universal argument."
4769 (allout-hide-current-entry)
4770 (save-excursion (allout-show-to-offshoot))
4772 (allout-flag-region (point)
4773 (progn (allout-end-of-entry t) (point))
4776 ;;;_ > allout-show-current-subtree (&optional arg)
4777 (defun allout-show-current-subtree (&optional arg)
4778 "Show everything within the current topic. With a repeat-count,
4779 expose this topic and its siblings."
4782 (if (<= (allout-current-depth) 0)
4783 ;; Outside any topics - try to get to the first:
4784 (if (not (allout-next-heading))
4786 ;; got to first, outermost topic - set to expose it and siblings:
4787 (message "Above outermost topic - exposing all.")
4788 (allout-flag-region (point-min)(point-max) nil))
4789 (allout-beginning-of-current-line)
4791 (allout-flag-current-subtree nil)
4792 (allout-beginning-of-level)
4793 (allout-expose-topic '(* :))))))
4794 ;;;_ > allout-current-topic-collapsed-p (&optional include-single-liners)
4795 (defun allout-current-topic-collapsed-p (&optional include-single-liners)
4796 "True if the currently visible containing topic is already collapsed.
4798 Single line topics intrinsically can be considered as being both
4799 collapsed and uncollapsed. If optional INCLUDE-SINGLE-LINERS is
4800 true, then single-line topics are considered to be collapsed. By
4801 default, they are treated as being uncollapsed."
4804 ;; Is the topic all on one line (allowing for trailing blank line)?
4805 (>= (progn (allout-back-to-current-heading)
4806 (move-end-of-line 1)
4808 (allout-end-of-current-subtree (not (looking-at "\n\n"))))
4810 (or include-single-liners
4811 (progn (backward-char 1) (allout-hidden-p))))))
4812 ;;;_ > allout-hide-current-subtree (&optional just-close)
4813 (defun allout-hide-current-subtree (&optional just-close)
4814 "Close the current topic, or containing topic if this one is already closed.
4816 If this topic is closed and it's a top level topic, close this topic
4819 If optional arg JUST-CLOSE is non-nil, do not close the parent or
4820 siblings, even if the target topic is already closed."
4823 (let* ((from (point))
4824 (sibs-msg "Top-level topic already closed - closing siblings...")
4825 (current-exposed (not (allout-current-topic-collapsed-p t))))
4826 (cond (current-exposed (allout-flag-current-subtree t))
4828 ((allout-ascend) (allout-hide-current-subtree))
4831 (allout-goto-prefix-doublechecked)
4832 (allout-expose-topic '(0 :))
4833 (message (concat sibs-msg " Done."))))
4835 ;;;_ > allout-show-current-branches ()
4836 (defun allout-show-current-branches ()
4837 "Show all subheadings of this heading, but not their bodies."
4839 (let ((inhibit-field-text-motion t))
4840 (beginning-of-line))
4841 (allout-show-children t))
4842 ;;;_ > allout-hide-current-leaves ()
4843 (defun allout-hide-current-leaves ()
4844 "Hide the bodies of the current topic and all its offspring."
4846 (allout-back-to-current-heading)
4847 (allout-hide-region-body (point) (progn (allout-end-of-current-subtree)
4850 ;;;_ - Region and beyond
4851 ;;;_ > allout-show-all ()
4852 (defun allout-show-all ()
4853 "Show all of the text in the buffer."
4855 (message "Exposing entire buffer...")
4856 (allout-flag-region (point-min) (point-max) nil)
4857 (message "Exposing entire buffer... Done."))
4858 ;;;_ > allout-hide-bodies ()
4859 (defun allout-hide-bodies ()
4860 "Hide all of buffer except headings."
4862 (allout-hide-region-body (point-min) (point-max)))
4863 ;;;_ > allout-hide-region-body (start end)
4864 (defun allout-hide-region-body (start end)
4865 "Hide all body lines in the region, but not headings."
4868 (narrow-to-region start end)
4869 (goto-char (point-min))
4870 (let ((inhibit-field-text-motion t))
4873 (allout-flag-region (point) (allout-end-of-entry) t)
4876 (if (looking-at "\n\n")
4879 ;;;_ > allout-expose-topic (spec)
4880 (defun allout-expose-topic (spec)
4881 "Apply exposure specs to successive outline topic items.
4883 Use the more convenient frontend, `allout-new-exposure', if you don't
4884 need evaluation of the arguments, or even better, the `allout-layout'
4885 variable-keyed mode-activation/auto-exposure feature of allout outline
4886 mode. See the respective documentation strings for more details.
4888 Cursor is left at start position.
4890 SPEC is either a number or a list.
4892 Successive specs on a list are applied to successive sibling topics.
4894 A simple spec \(either a number, one of a few symbols, or the null
4895 list) dictates the exposure for the corresponding topic.
4897 Non-null lists recursively designate exposure specs for respective
4898 subtopics of the current topic.
4900 The `:' repeat spec is used to specify exposure for any number of
4901 successive siblings, up to the trailing ones for which there are
4902 explicit specs following the `:'.
4904 Simple (numeric and null-list) specs are interpreted as follows:
4906 Numbers indicate the relative depth to open the corresponding topic.
4907 - negative numbers force the topic to be closed before opening to the
4908 absolute value of the number, so all siblings are open only to
4910 - positive numbers open to the relative depth indicated by the
4911 number, but do not force already opened subtopics to be closed.
4912 - 0 means to close topic - hide all offspring.
4914 apply prior element to all siblings at current level, *up to*
4915 those siblings that would be covered by specs following the `:'
4916 on the list. Ie, apply to all topics at level but the last
4917 ones. \(Only first of multiple colons at same level is
4918 respected - subsequent ones are discarded.)
4919 * - completely opens the topic, including bodies.
4920 + - shows all the sub headers, but not the bodies
4921 - - exposes the body of the corresponding topic.
4924 \(allout-expose-topic '(-1 : 0))
4925 Close this and all following topics at current level, exposing
4926 only their immediate children, but close down the last topic
4927 at this current level completely.
4928 \(allout-expose-topic '(-1 () : 1 0))
4929 Close current topic so only the immediate subtopics are shown;
4930 show the children in the second to last topic, and completely
4932 \(allout-expose-topic '(-2 : -1 *))
4933 Expose children and grandchildren of all topics at current
4934 level except the last two; expose children of the second to
4935 last and completely open the last one."
4937 (interactive "xExposure spec: ")
4938 (if (not (listp spec))
4940 (let ((depth (allout-depth))
4945 (setq prev-elem curr-elem
4946 curr-elem (car spec)
4948 (cond ; Do current element:
4949 ((null curr-elem) nil)
4950 ((symbolp curr-elem)
4951 (cond ((eq curr-elem '*) (allout-show-current-subtree)
4952 (if (> allout-recent-end-of-subtree max-pos)
4953 (setq max-pos allout-recent-end-of-subtree)))
4955 (if (not (allout-hidden-p))
4956 (save-excursion (allout-hide-current-subtree t)))
4957 (allout-show-current-branches)
4958 (if (> allout-recent-end-of-subtree max-pos)
4959 (setq max-pos allout-recent-end-of-subtree)))
4960 ((eq curr-elem '-) (allout-show-current-entry))
4963 ;; Expand the `repeat' spec to an explicit version,
4964 ;; w.r.t. remaining siblings:
4965 (let ((residue ; = # of sibs not covered by remaining spec
4966 ;; Dang - could be nice to make use of the chart, sigh:
4967 (- (length (allout-chart-siblings))
4970 ;; Some residue - cover it with prev-elem:
4971 (setq spec (append (make-list residue prev-elem)
4973 ((numberp curr-elem)
4974 (if (and (>= 0 curr-elem) (not (allout-hidden-p)))
4975 (save-excursion (allout-hide-current-subtree t)
4978 (if (> allout-recent-end-of-subtree max-pos)
4980 allout-recent-end-of-subtree)))))
4981 (if (> (abs curr-elem) 0)
4982 (progn (allout-show-children (abs curr-elem))
4983 (if (> allout-recent-end-of-subtree max-pos)
4984 (setq max-pos allout-recent-end-of-subtree)))))
4986 (if (allout-descend-to-depth (1+ depth))
4987 (let ((got (allout-expose-topic curr-elem)))
4988 (if (and got (> got max-pos)) (setq max-pos got))))))
4989 (cond (stay (setq stay nil))
4990 ((listp (car spec)) nil)
4991 ((> max-pos (point))
4992 ;; Capitalize on max-pos state to get us nearer next sibling:
4993 (progn (goto-char (min (point-max) max-pos))
4994 (allout-next-heading)))
4995 ((allout-next-sibling depth))))
4997 ;;;_ > allout-old-expose-topic (spec &rest followers)
4998 (defun allout-old-expose-topic (spec &rest followers)
5000 "Deprecated. Use `allout-expose-topic' \(with different schema
5003 Dictate wholesale exposure scheme for current topic, according to SPEC.
5005 SPEC is either a number or a list. Optional successive args
5006 dictate exposure for subsequent siblings of current topic.
5008 A simple spec (either a number, a special symbol, or the null list)
5009 dictates the overall exposure for a topic. Non null lists are
5010 composite specs whose first element dictates the overall exposure for
5011 a topic, with the subsequent elements in the list interpreted as specs
5012 that dictate the exposure for the successive offspring of the topic.
5014 Simple (numeric and null-list) specs are interpreted as follows:
5016 - Numbers indicate the relative depth to open the corresponding topic:
5017 - negative numbers force the topic to be close before opening to the
5018 absolute value of the number.
5019 - positive numbers just open to the relative depth indicated by the number.
5021 - `*' completely opens the topic, including bodies.
5022 - `+' shows all the sub headers, but not the bodies
5023 - `-' exposes the body and immediate offspring of the corresponding topic.
5025 If the spec is a list, the first element must be a number, which
5026 dictates the exposure depth of the topic as a whole. Subsequent
5027 elements of the list are nested SPECs, dictating the specific exposure
5028 for the corresponding offspring of the topic.
5030 Optional FOLLOWERS arguments dictate exposure for succeeding siblings."
5032 (interactive "xExposure spec: ")
5033 (let ((inhibit-field-text-motion t)
5034 (depth (allout-current-depth))
5036 (cond ((null spec) nil)
5038 (if (eq spec '*) (allout-show-current-subtree))
5039 (if (eq spec '+) (allout-show-current-branches))
5040 (if (eq spec '-) (allout-show-current-entry)))
5043 (save-excursion (allout-hide-current-subtree t)
5045 (if (or (not max-pos)
5046 (> (point) max-pos))
5047 (setq max-pos (point)))
5049 (setq spec (* -1 spec)))))
5051 (allout-show-children spec)))
5053 ;(let ((got (allout-old-expose-topic (car spec))))
5054 ; (if (and got (or (not max-pos) (> got max-pos)))
5055 ; (setq max-pos got)))
5056 (let ((new-depth (+ (allout-current-depth) 1))
5058 (setq max-pos (allout-old-expose-topic (car spec)))
5059 (setq spec (cdr spec))
5061 (allout-descend-to-depth new-depth)
5062 (not (allout-hidden-p)))
5063 (progn (setq got (apply 'allout-old-expose-topic spec))
5064 (if (and got (or (not max-pos) (> got max-pos)))
5065 (setq max-pos got)))))))
5066 (while (and followers
5067 (progn (if (and max-pos (< (point) max-pos))
5068 (progn (goto-char max-pos)
5069 (setq max-pos nil)))
5071 (allout-next-sibling depth)))
5072 (allout-old-expose-topic (car followers))
5073 (setq followers (cdr followers)))
5075 ;;;_ > allout-new-exposure '()
5076 (defmacro allout-new-exposure (&rest spec)
5077 "Literal frontend for `allout-expose-topic', doesn't evaluate arguments.
5078 Some arguments that would need to be quoted in `allout-expose-topic'
5079 need not be quoted in `allout-new-exposure'.
5081 Cursor is left at start position.
5083 Use this instead of obsolete `allout-exposure'.
5086 \(allout-new-exposure (-1 () () () 1) 0)
5087 Close current topic at current level so only the immediate
5088 subtopics are shown, except also show the children of the
5089 third subtopic; and close the next topic at the current level.
5090 \(allout-new-exposure : -1 0)
5091 Close all topics at current level to expose only their
5092 immediate children, except for the last topic at the current
5093 level, in which even its immediate children are hidden.
5094 \(allout-new-exposure -2 : -1 *)
5095 Expose children and grandchildren of first topic at current
5096 level, and expose children of subsequent topics at current
5097 level *except* for the last, which should be opened completely."
5098 (list 'save-excursion
5099 '(if (not (or (allout-goto-prefix-doublechecked)
5100 (allout-next-heading)))
5101 (error "allout-new-exposure: Can't find any outline topics"))
5102 (list 'allout-expose-topic (list 'quote spec))))
5104 ;;;_ #7 Systematic outline presentation - copying, printing, flattening
5106 ;;;_ - Mapping and processing of topics
5107 ;;;_ ( See also Subtree Charting, in Navigation code.)
5108 ;;;_ > allout-stringify-flat-index (flat-index)
5109 (defun allout-stringify-flat-index (flat-index &optional context)
5110 "Convert list representing section/subsection/... to document string.
5112 Optional arg CONTEXT indicates interior levels to include."
5116 (context-depth (or (and context 2) 1)))
5117 ;; Take care of the explicit context:
5118 (while (> context-depth 0)
5119 (setq numstr (int-to-string (car flat-index))
5120 flat-index (cdr flat-index)
5121 result (if flat-index
5122 (cons delim (cons numstr result))
5123 (cons numstr result))
5124 context-depth (if flat-index (1- context-depth) 0)))
5126 ;; Take care of the indentation:
5133 (1+ (truncate (if (zerop (car flat-index))
5135 (log10 (car flat-index)))))
5138 (setq flat-index (cdr flat-index)))
5139 ;; Dispose of single extra delim:
5140 (setq result (cdr result))))
5141 (apply 'concat result)))
5142 ;;;_ > allout-stringify-flat-index-plain (flat-index)
5143 (defun allout-stringify-flat-index-plain (flat-index)
5144 "Convert list representing section/subsection/... to document string."
5148 (setq result (cons (int-to-string (car flat-index))
5150 (cons delim result))))
5151 (setq flat-index (cdr flat-index)))
5152 (apply 'concat result)))
5153 ;;;_ > allout-stringify-flat-index-indented (flat-index)
5154 (defun allout-stringify-flat-index-indented (flat-index)
5155 "Convert list representing section/subsection/... to document string."
5159 ;; Take care of the explicit context:
5160 (setq numstr (int-to-string (car flat-index))
5161 flat-index (cdr flat-index)
5162 result (if flat-index
5163 (cons delim (cons numstr result))
5164 (cons numstr result)))
5166 ;; Take care of the indentation:
5173 (1+ (truncate (if (zerop (car flat-index))
5175 (log10 (car flat-index)))))
5178 (setq flat-index (cdr flat-index)))
5179 ;; Dispose of single extra delim:
5180 (setq result (cdr result))))
5181 (apply 'concat result)))
5182 ;;;_ > allout-listify-exposed (&optional start end format)
5183 (defun allout-listify-exposed (&optional start end format)
5185 "Produce a list representing exposed topics in current region.
5187 This list can then be used by `allout-process-exposed' to manipulate
5190 Optional START and END indicate bounds of region.
5192 optional arg, FORMAT, designates an alternate presentation form for
5195 list - Present prefix as numeric section.subsection..., starting with
5196 section indicated by the list, innermost nesting first.
5197 `indent' \(symbol) - Convert header prefixes to all white space,
5198 except for distinctive bullets.
5200 The elements of the list produced are lists that represents a topic
5201 header and body. The elements of that list are:
5203 - a number representing the depth of the topic,
5204 - a string representing the header-prefix, including trailing whitespace and
5206 - a string representing the bullet character,
5207 - and a series of strings, each containing one line of the exposed
5208 portion of the topic entry."
5213 ((inhibit-field-text-motion t)
5215 strings prefix result depth new-depth out gone-out bullet beg
5220 ;; Goto initial topic, and register preceeding stuff, if any:
5221 (if (> (allout-goto-prefix-doublechecked) start)
5222 ;; First topic follows beginning point - register preliminary stuff:
5223 (setq result (list (list 0 "" nil
5224 (buffer-substring start (1- (point)))))))
5225 (while (and (not done)
5226 (not (eobp)) ; Loop until we've covered the region.
5227 (not (> (point) end)))
5228 (setq depth allout-recent-depth ; Current topics depth,
5229 bullet (allout-recent-bullet) ; ... bullet,
5230 prefix (allout-recent-prefix)
5231 beg (progn (allout-end-of-prefix t) (point))) ; and beginning.
5232 (setq done ; The boundary for the current topic:
5233 (not (allout-next-visible-heading 1)))
5234 (setq new-depth allout-recent-depth)
5236 out (< new-depth depth))
5241 (while (> next (point)) ; Get all the exposed text in
5243 (cons (buffer-substring
5245 ;To hidden text or end of line:
5248 (allout-back-to-visible-text)))
5250 (when (< (point) next) ; Resume from after hid text, if any.
5252 (beginning-of-line))
5254 ;; Accumulate list for this topic:
5255 (setq strings (nreverse strings))
5259 (let ((special (if (string-match
5260 (regexp-quote bullet)
5261 allout-distinctive-bullets-string)
5263 (cond ((listp format)
5265 (if allout-abbreviate-flattened-numbering
5266 (allout-stringify-flat-index format
5268 (allout-stringify-flat-index-plain
5272 ((eq format 'indent)
5275 (concat (make-string (1+ depth) ? )
5276 (substring prefix -1))
5279 (make-string depth ? )
5281 (t (error "allout-listify-exposed: %s %s"
5282 "invalid format" format))))
5283 (list depth prefix strings))
5285 ;; Reasses format, if any:
5286 (if (and format (listp format))
5287 (cond ((= new-depth depth)
5288 (setq format (cons (1+ (car format))
5290 ((> new-depth depth) ; descending - assume by 1:
5291 (setq format (cons 1 format)))
5294 (while (< new-depth depth)
5295 (setq format (cdr format))
5296 (setq depth (1- depth)))
5297 ; And increment the current one:
5299 (cons (1+ (or (car format)
5302 ;; Put the list with first at front, to last at back:
5303 (nreverse result))))
5304 ;;;_ > my-region-active-p ()
5305 (defmacro my-region-active-p ()
5306 (if (fboundp 'region-active-p)
5309 ;;;_ > allout-process-exposed (&optional func from to frombuf
5311 (defun allout-process-exposed (&optional func from to frombuf tobuf
5313 "Map function on exposed parts of current topic; results to another buffer.
5315 All args are options; default values itemized below.
5317 Apply FUNCTION to exposed portions FROM position TO position in buffer
5318 FROMBUF to buffer TOBUF. Sixth optional arg, FORMAT, designates an
5319 alternate presentation form:
5321 `flat' - Present prefix as numeric section.subsection..., starting with
5322 section indicated by the start-num, innermost nesting first.
5323 X`flat-indented' - Prefix is like `flat' for first topic at each
5324 X level, but subsequent topics have only leaf topic
5325 X number, padded with blanks to line up with first.
5326 `indent' \(symbol) - Convert header prefixes to all white space,
5327 except for distinctive bullets.
5330 FUNCTION: `allout-insert-listified'
5331 FROM: region start, if region active, else start of buffer
5332 TO: region end, if region active, else end of buffer
5333 FROMBUF: current buffer
5334 TOBUF: buffer name derived: \"*current-buffer-name exposed*\"
5337 ; Resolve arguments,
5338 ; defaulting if necessary:
5339 (if (not func) (setq func 'allout-insert-listified))
5340 (if (not (and from to))
5341 (if (my-region-active-p)
5342 (setq from (region-beginning) to (region-end))
5343 (setq from (point-min) to (point-max))))
5345 (if (not (bufferp frombuf))
5346 ;; Specified but not a buffer - get it:
5347 (let ((got (get-buffer frombuf)))
5349 (error (concat "allout-process-exposed: source buffer "
5352 (setq frombuf got))))
5353 ;; not specified - default it:
5354 (setq frombuf (current-buffer)))
5356 (if (not (bufferp tobuf))
5357 (setq tobuf (get-buffer-create tobuf)))
5358 ;; not specified - default it:
5359 (setq tobuf (concat "*" (buffer-name frombuf) " exposed*")))
5364 (progn (set-buffer frombuf)
5365 (allout-listify-exposed from to format))))
5367 (mapcar func listified)
5368 (pop-to-buffer tobuf)))
5371 ;;;_ > allout-insert-listified (listified)
5372 (defun allout-insert-listified (listified)
5373 "Insert contents of listified outline portion in current buffer.
5375 LISTIFIED is a list representing each topic header and body:
5377 \`(depth prefix text)'
5379 or \`(depth prefix text bullet-plus)'
5381 If `bullet-plus' is specified, it is inserted just after the entire prefix."
5382 (setq listified (cdr listified))
5383 (let ((prefix (prog1
5385 (setq listified (cdr listified))))
5388 (setq listified (cdr listified))))
5389 (bullet-plus (car listified)))
5391 (if bullet-plus (insert (concat " " bullet-plus)))
5394 (if (setq text (cdr text))
5397 ;;;_ > allout-copy-exposed-to-buffer (&optional arg tobuf format)
5398 (defun allout-copy-exposed-to-buffer (&optional arg tobuf format)
5399 "Duplicate exposed portions of current outline to another buffer.
5401 Other buffer has current buffers name with \" exposed\" appended to it.
5403 With repeat count, copy the exposed parts of only the current topic.
5405 Optional second arg TOBUF is target buffer name.
5407 Optional third arg FORMAT, if non-nil, symbolically designates an
5408 alternate presentation format for the outline:
5410 `flat' - Convert topic header prefixes to numeric
5411 section.subsection... identifiers.
5412 `indent' - Convert header prefixes to all white space, except for
5413 distinctive bullets.
5414 `indent-flat' - The best of both - only the first of each level has
5415 the full path, the rest have only the section number
5416 of the leaf, preceded by the right amount of indentation."
5420 (setq tobuf (get-buffer-create (concat "*" (buffer-name) " exposed*"))))
5421 (let* ((start-pt (point))
5422 (beg (if arg (allout-back-to-current-heading) (point-min)))
5423 (end (if arg (allout-end-of-current-subtree) (point-max)))
5424 (buf (current-buffer))
5426 (if (eq format 'flat)
5427 (setq format (if arg (save-excursion
5429 (allout-topic-flat-index))
5431 (save-excursion (set-buffer tobuf)(erase-buffer))
5432 (allout-process-exposed 'allout-insert-listified
5438 (goto-char (point-min))
5440 (goto-char start-pt)))
5441 ;;;_ > allout-flatten-exposed-to-buffer (&optional arg tobuf)
5442 (defun allout-flatten-exposed-to-buffer (&optional arg tobuf)
5443 "Present numeric outline of outline's exposed portions in another buffer.
5445 The resulting outline is not compatible with outline mode - use
5446 `allout-copy-exposed-to-buffer' if you want that.
5448 Use `allout-indented-exposed-to-buffer' for indented presentation.
5450 With repeat count, copy the exposed portions of only current topic.
5452 Other buffer has current buffer's name with \" exposed\" appended to
5453 it, unless optional second arg TOBUF is specified, in which case it is
5456 (allout-copy-exposed-to-buffer arg tobuf 'flat))
5457 ;;;_ > allout-indented-exposed-to-buffer (&optional arg tobuf)
5458 (defun allout-indented-exposed-to-buffer (&optional arg tobuf)
5459 "Present indented outline of outline's exposed portions in another buffer.
5461 The resulting outline is not compatible with outline mode - use
5462 `allout-copy-exposed-to-buffer' if you want that.
5464 Use `allout-flatten-exposed-to-buffer' for numeric sectional presentation.
5466 With repeat count, copy the exposed portions of only current topic.
5468 Other buffer has current buffer's name with \" exposed\" appended to
5469 it, unless optional second arg TOBUF is specified, in which case it is
5472 (allout-copy-exposed-to-buffer arg tobuf 'indent))
5474 ;;;_ - LaTeX formatting
5475 ;;;_ > allout-latex-verb-quote (string &optional flow)
5476 (defun allout-latex-verb-quote (string &optional flow)
5477 "Return copy of STRING for literal reproduction across LaTeX processing.
5478 Expresses the original characters \(including carriage returns) of the
5479 string across LaTeX processing."
5480 (mapconcat (function
5482 (cond ((memq char '(?\\ ?$ ?% ?# ?& ?{ ?} ?_ ?^ ?- ?*))
5483 (concat "\\char" (number-to-string char) "{}"))
5484 ((= char ?\n) "\\\\")
5485 (t (char-to-string char)))))
5488 ;;;_ > allout-latex-verbatim-quote-curr-line ()
5489 (defun allout-latex-verbatim-quote-curr-line ()
5490 "Express line for exact \(literal) representation across LaTeX processing.
5492 Adjust line contents so it is unaltered \(from the original line)
5493 across LaTeX processing, within the context of a `verbatim'
5494 environment. Leaves point at the end of the line."
5495 (let ((inhibit-field-text-motion t))
5498 (end (progn (end-of-line)(point))))
5500 (while (re-search-forward "\\\\"
5501 ;;"\\\\\\|\\{\\|\\}\\|\\_\\|\\$\\|\\\"\\|\\&\\|\\^\\|\\-\\|\\*\\|#"
5502 end ; bounded by end-of-line
5503 1) ; no matches, move to end & return nil
5504 (goto-char (match-beginning 2))
5507 (goto-char (1+ (match-end 2)))))))
5508 ;;;_ > allout-insert-latex-header (buffer)
5509 (defun allout-insert-latex-header (buffer)
5510 "Insert initial LaTeX commands at point in BUFFER."
5511 ;; Much of this is being derived from the stuff in appendix of E in
5512 ;; the TeXBook, pg 421.
5514 (let ((doc-style (format "\n\\documentstyle{%s}\n"
5516 (page-numbering (if allout-number-pages
5517 "\\pagestyle{empty}\n"
5519 (titlecmd (format "\\newcommand{\\titlecmd}[1]{{%s #1}}\n"
5520 allout-title-style))
5521 (labelcmd (format "\\newcommand{\\labelcmd}[1]{{%s #1}}\n"
5522 allout-label-style))
5523 (headlinecmd (format "\\newcommand{\\headlinecmd}[1]{{%s #1}}\n"
5524 allout-head-line-style))
5525 (bodylinecmd (format "\\newcommand{\\bodylinecmd}[1]{{%s #1}}\n"
5526 allout-body-line-style))
5527 (setlength (format "%s%s%s%s"
5528 "\\newlength{\\stepsize}\n"
5529 "\\setlength{\\stepsize}{"
5532 (oneheadline (format "%s%s%s%s%s%s%s"
5533 "\\newcommand{\\OneHeadLine}[3]{%\n"
5535 "\\hspace*{#2\\stepsize}%\n"
5536 "\\labelcmd{#1}\\hspace*{.2cm}"
5537 "\\headlinecmd{#3}\\\\["
5540 (onebodyline (format "%s%s%s%s%s%s"
5541 "\\newcommand{\\OneBodyLine}[2]{%\n"
5543 "\\hspace*{#1\\stepsize}%\n"
5544 "\\bodylinecmd{#2}\\\\["
5547 (begindoc "\\begin{document}\n\\begin{center}\n")
5548 (title (format "%s%s%s%s"
5550 (allout-latex-verb-quote (if allout-title
5553 (error "<unnamed buffer>"))
5556 "\\end{center}\n\n"))
5557 (hsize "\\hsize = 7.5 true in\n")
5558 (hoffset "\\hoffset = -1.5 true in\n")
5559 (vspace "\\vspace{.1cm}\n\n"))
5560 (insert (concat doc-style
5575 ;;;_ > allout-insert-latex-trailer (buffer)
5576 (defun allout-insert-latex-trailer (buffer)
5577 "Insert concluding LaTeX commands at point in BUFFER."
5579 (insert "\n\\end{document}\n"))
5580 ;;;_ > allout-latexify-one-item (depth prefix bullet text)
5581 (defun allout-latexify-one-item (depth prefix bullet text)
5582 "Insert LaTeX commands for formatting one outline item.
5584 Args are the topics numeric DEPTH, the header PREFIX lead string, the
5585 BULLET string, and a list of TEXT strings for the body."
5586 (let* ((head-line (if text (car text)))
5587 (body-lines (cdr text))
5591 (insert (concat "\\OneHeadLine{\\verb\1 "
5592 (allout-latex-verb-quote bullet)
5597 (allout-latex-verb-quote head-line)
5600 (if (not body-lines)
5602 ;;(insert "\\beginlines\n")
5603 (insert "\\begin{verbatim}\n")
5605 (setq curr-line (car body-lines))
5606 (if (and (not body-content)
5607 (not (string-match "^\\s-*$" curr-line)))
5608 (setq body-content t))
5609 ; Mangle any occurrences of
5610 ; "\end{verbatim}" in text,
5612 (if (and body-content
5613 (setq bop (string-match "\\end{verbatim}" curr-line)))
5614 (setq curr-line (concat (substring curr-line 0 bop)
5616 (substring curr-line bop))))
5617 ;;(insert "|" (car body-lines) "|")
5619 (allout-latex-verbatim-quote-curr-line)
5621 (setq body-lines (cdr body-lines)))
5623 (setq body-content nil)
5627 ;;(insert "\\endlines\n")
5628 (insert "\\end{verbatim}\n")
5630 ;;;_ > allout-latexify-exposed (arg &optional tobuf)
5631 (defun allout-latexify-exposed (arg &optional tobuf)
5632 "Format current topics exposed portions to TOBUF for LaTeX processing.
5633 TOBUF defaults to a buffer named the same as the current buffer, but
5634 with \"*\" prepended and \" latex-formed*\" appended.
5636 With repeat count, copy the exposed portions of entire buffer."
5641 (get-buffer-create (concat "*" (buffer-name) " latexified*"))))
5642 (let* ((start-pt (point))
5643 (beg (if arg (point-min) (allout-back-to-current-heading)))
5644 (end (if arg (point-max) (allout-end-of-current-subtree)))
5645 (buf (current-buffer)))
5648 (allout-insert-latex-header tobuf)
5649 (goto-char (point-max))
5650 (allout-process-exposed 'allout-latexify-one-item
5655 (goto-char (point-max))
5656 (allout-insert-latex-trailer tobuf)
5657 (goto-char (point-min))
5659 (goto-char start-pt)))
5662 ;;;_ > allout-toggle-current-subtree-encryption (&optional fetch-pass)
5663 (defun allout-toggle-current-subtree-encryption (&optional fetch-pass)
5664 "Encrypt clear or decrypt encoded text of visibly-containing topic's contents.
5666 Optional FETCH-PASS universal argument provokes key-pair encryption with
5667 single universal argument. With doubled universal argument \(value = 16),
5668 it forces prompting for the passphrase regardless of availability from the
5669 passphrase cache. With no universal argument, the appropriate passphrase
5670 is obtained from the cache, if available, else from the user.
5672 Currently only GnuPG encryption is supported.
5674 \**NOTE WELL** that the encrypted text must be ascii-armored. For gnupg
5675 encryption, include the option ``armor'' in your ~/.gnupg/gpg.conf file.
5677 Both symmetric-key and key-pair encryption is implemented. Symmetric is
5678 the default, use a single \(x4) universal argument for keypair mode.
5680 Encrypted topic's bullet is set to a `~' to signal that the contents of the
5681 topic \(body and subtopics, but not heading) is pending encryption or
5682 encrypted. `*' asterisk immediately after the bullet signals that the body
5683 is encrypted, its' absence means the topic is meant to be encrypted but is
5684 not. When a file with topics pending encryption is saved, topics pending
5685 encryption are encrypted. See allout-encrypt-unencrypted-on-saves for
5686 auto-encryption specifics.
5688 \**NOTE WELL** that automatic encryption that happens during saves will
5689 default to symmetric encryption - you must manually \(re)encrypt key-pair
5690 encrypted topics if you want them to continue to use the key-pair cipher.
5692 Level-one topics, with prefix consisting solely of an `*' asterisk, cannot be
5693 encrypted. If you want to encrypt the contents of a top-level topic, use
5694 \\[allout-shift-in] to increase its depth.
5698 The encryption passphrase is solicited if not currently available in the
5699 passphrase cache from a recent encryption action.
5701 The solicited passphrase is retained for reuse in a buffer-specific cache
5702 for some set period of time \(default, 60 seconds), after which the string
5703 is nulled. The passphrase cache timeout is customized by setting
5704 `pgg-passphrase-cache-expiry'.
5706 Symmetric Passphrase Hinting and Verification
5708 If the file previously had no associated passphrase, or had a different
5709 passphrase than specified, the user is prompted to repeat the new one for
5710 corroboration. A random string encrypted by the new passphrase is set on
5711 the buffer-specific variable `allout-passphrase-verifier-string', for
5712 confirmation of the passphrase when next obtained, before encrypting or
5713 decrypting anything with it. This helps avoid mistakenly shifting between
5716 If allout customization var `allout-passphrase-verifier-handling' is
5717 non-nil, an entry for `allout-passphrase-verifier-string' and its value is
5718 added to an Emacs 'local variables' section at the end of the file, which
5719 is created if necessary. That setting is for retention of the passphrase
5720 verifier across Emacs sessions.
5722 Similarly, `allout-passphrase-hint-string' stores a user-provided reminder
5723 about their passphrase, and `allout-passphrase-hint-handling' specifies
5724 when the hint is presented, or if passphrase hints are disabled. If
5725 enabled \(see the `allout-passphrase-hint-handling' docstring for details),
5726 the hint string is stored in the local-variables section of the file, and
5727 solicited whenever the passphrase is changed."
5730 (allout-back-to-current-heading)
5731 (allout-toggle-subtree-encryption fetch-pass)
5734 ;;;_ > allout-toggle-subtree-encryption (&optional fetch-pass)
5735 (defun allout-toggle-subtree-encryption (&optional fetch-pass)
5736 "Encrypt clear text or decrypt encoded topic contents \(body and subtopics.)
5738 Optional FETCH-PASS universal argument provokes key-pair encryption with
5739 single universal argument. With doubled universal argument \(value = 16),
5740 it forces prompting for the passphrase regardless of availability from the
5741 passphrase cache. With no universal argument, the appropriate passphrase
5742 is obtained from the cache, if available, else from the user.
5744 Currently only GnuPG encryption is supported.
5746 \**NOTE WELL** that the encrypted text must be ascii-armored. For gnupg
5747 encryption, include the option ``armor'' in your ~/.gnupg/gpg.conf file.
5749 See `allout-toggle-current-subtree-encryption' for more details."
5753 (allout-end-of-prefix t)
5755 (if (= allout-recent-depth 1)
5756 (error (concat "Cannot encrypt or decrypt level 1 topics -"
5757 " shift it in to make it encryptable")))
5759 (let* ((allout-buffer (current-buffer))
5761 (bullet-pos allout-recent-prefix-beginning)
5762 (after-bullet-pos (point))
5764 (progn (if (= (point-max) after-bullet-pos)
5765 (error "no body to encrypt"))
5766 (allout-encrypted-topic-p)))
5767 (was-collapsed (if (not (search-forward "\n" nil t))
5771 (subtree-beg (1+ (point)))
5772 (subtree-end (allout-end-of-subtree))
5773 (subject-text (buffer-substring-no-properties subtree-beg
5775 (subtree-end-char (char-after (1- subtree-end)))
5776 (subtree-trailing-char (char-after subtree-end))
5777 ;; kluge - result-text needs to be nil, but we also want to
5778 ;; check for the error condition
5779 (result-text (if (or (string= "" subject-text)
5780 (string= "\n" subject-text))
5781 (error "No topic contents to %scrypt"
5782 (if was-encrypted "de" "en"))
5784 ;; Assess key parameters:
5786 ;; detect the type by which it is already encrypted
5788 (allout-encrypted-key-info subject-text))
5789 (and (member fetch-pass '(4 (4)))
5792 (for-key-type (car key-info))
5793 (for-key-identity (cadr key-info))
5794 (fetch-pass (and fetch-pass (member fetch-pass '(16 (16))))))
5797 (allout-encrypt-string subject-text was-encrypted
5799 for-key-type for-key-identity fetch-pass))
5801 ;; Replace the subtree with the processed product.
5804 (set-buffer allout-buffer)
5805 (delete-region subtree-beg subtree-end)
5806 (insert result-text)
5808 (allout-flag-region (1- subtree-beg) (point) t))
5809 ;; adjust trailing-blank-lines to preserve topic spacing:
5810 (if (not was-encrypted)
5811 (if (and (= subtree-end-char ?\n)
5812 (= subtree-trailing-char ?\n))
5813 (insert subtree-trailing-char)))
5814 ;; Ensure that the item has an encrypted-entry bullet:
5815 (if (not (string= (buffer-substring-no-properties
5816 (1- after-bullet-pos) after-bullet-pos)
5817 allout-topic-encryption-bullet))
5818 (progn (goto-char (1- after-bullet-pos))
5820 (insert allout-topic-encryption-bullet)))
5822 ;; Remove the is-encrypted bullet qualifier:
5823 (progn (goto-char after-bullet-pos)
5825 ;; Add the is-encrypted bullet qualifier:
5826 (goto-char after-bullet-pos)
5828 (run-hook-with-args 'allout-structure-added-hook
5829 bullet-pos subtree-end))))
5830 ;;;_ > allout-encrypt-string (text decrypt allout-buffer key-type for-key
5831 ;;; fetch-pass &optional retried verifying
5833 (defun allout-encrypt-string (text decrypt allout-buffer key-type for-key
5834 fetch-pass &optional retried rejected
5835 verifying passphrase)
5836 "Encrypt or decrypt message TEXT.
5838 If DECRYPT is true (default false), then decrypt instead of encrypt.
5840 FETCH-PASS (default false) forces fresh prompting for the passphrase.
5842 KEY-TYPE indicates whether to use a 'symmetric or 'keypair cipher.
5844 FOR-KEY is human readable identification of the first of the user's
5845 eligible secret keys a keypair decryption targets, or else nil.
5847 Optional RETRIED is for internal use - conveys the number of failed keys
5848 that have been solicited in sequence leading to this current call.
5850 Optional PASSPHRASE enables explicit delivery of the decryption passphrase,
5851 for verification purposes.
5853 Optional REJECTED is for internal use - conveys the number of
5854 rejections due to matches against
5855 `allout-encryption-ciphertext-rejection-regexps', as limited by
5856 `allout-encryption-ciphertext-rejection-ceiling'.
5858 Returns the resulting string, or nil if the transformation fails."
5862 (if (not (fboundp 'pgg-encrypt-symmetric))
5863 (error "Allout encryption depends on a newer version of pgg"))
5865 (let* ((scheme (upcase
5866 (format "%s" (or pgg-scheme pgg-default-scheme "GPG"))))
5867 (for-key (and (equal key-type 'keypair)
5869 (split-string (read-string
5870 (format "%s message recipients: "
5873 (target-prompt-id (if (equal key-type 'keypair)
5874 (if (= (length for-key) 1)
5875 (car for-key) for-key)
5876 (buffer-name allout-buffer)))
5877 (target-cache-id (format "%s-%s"
5879 (if (equal key-type 'keypair)
5881 (or (buffer-file-name allout-buffer)
5882 target-prompt-id))))
5883 (strip-plaintext-regexps
5885 (allout-get-configvar-values
5886 'allout-encryption-plaintext-sanitization-regexps)))
5887 (reject-ciphertext-regexps
5889 (allout-get-configvar-values
5890 'allout-encryption-ciphertext-rejection-regexps)))
5891 (rejected (or rejected 0))
5892 (rejections-left (- allout-encryption-ciphertext-rejection-ceiling
5896 (if (and fetch-pass (not passphrase))
5897 ;; Force later fetch by evicting passphrase from the cache.
5898 (pgg-remove-passphrase-from-cache target-cache-id t))
5900 (catch 'encryption-failed
5902 ;; Obtain the passphrase if we don't already have one and we're not
5903 ;; doing a keypair encryption:
5904 (if (not (or passphrase
5905 (and (equal key-type 'keypair)
5908 (setq passphrase (allout-obtain-passphrase for-key
5913 retried fetch-pass)))
5919 (when (and strip-plaintext-regexps (not decrypt))
5920 (dolist (re strip-plaintext-regexps)
5921 (let ((re (if (listp re) (car re) re))
5922 (replacement (if (listp re) (cadr re) "")))
5923 (goto-char (point-min))
5924 (while (re-search-forward re nil t)
5925 (replace-match replacement nil nil)))))
5930 ((equal key-type 'symmetric)
5934 (pgg-decrypt (point-min) (point-max) passphrase)
5936 (pgg-encrypt-symmetric (point-min) (point-max)
5940 (pgg-situate-output (point-min) (point-max))
5941 ;; failed - handle passphrase caching
5943 (throw 'encryption-failed nil)
5944 (pgg-remove-passphrase-from-cache target-cache-id t)
5945 (error "Symmetric-cipher %scryption failed - %s"
5946 (if decrypt "de" "en")
5947 "try again with different passphrase."))))
5949 ;; encrypt 'keypair:
5954 (pgg-encrypt for-key
5955 nil (point-min) (point-max) passphrase))
5958 (pgg-situate-output (point-min) (point-max))
5959 (error (pgg-remove-passphrase-from-cache target-cache-id t)
5960 (error "encryption failed"))))
5962 ;; decrypt 'keypair:
5966 (pgg-decrypt (point-min) (point-max) passphrase))
5969 (pgg-situate-output (point-min) (point-max))
5970 (error (pgg-remove-passphrase-from-cache target-cache-id t)
5971 (error "decryption failed")))))
5974 (buffer-substring-no-properties
5975 1 (- (point-max) (if decrypt 0 1))))
5978 ;; validate result - non-empty
5979 (cond ((not result-text)
5982 ;; transform was fruitless, retry w/new passphrase.
5983 (pgg-remove-passphrase-from-cache target-cache-id t)
5984 (allout-encrypt-string text decrypt allout-buffer
5985 key-type for-key nil
5986 (if retried (1+ retried) 1)
5987 rejected verifying nil)))
5989 ;; Retry (within limit) if ciphertext contains rejections:
5991 ;; Check for disqualification of this ciphertext:
5992 (let ((regexps reject-ciphertext-regexps)
5994 (while (and regexps (not reject-it))
5995 (setq reject-it (string-match (car regexps)
5999 (setq rejections-left (1- rejections-left))
6000 (if (<= rejections-left 0)
6001 (error (concat "Ciphertext rejected too many times"
6003 allout-encryption-ciphertext-rejection-ceiling
6004 'allout-encryption-ciphertext-rejection-regexps)
6005 (allout-encrypt-string text decrypt allout-buffer
6006 key-type for-key nil
6007 retried (1+ rejected)
6008 verifying passphrase)))
6009 ;; Barf if encryption yields extraordinary control chars:
6011 (string-match "[\C-a\C-k\C-o-\C-z\C-@]"
6013 (error (concat "Encryption produced non-armored text, which"
6014 "conflicts with allout mode - reconfigure!")))
6016 ;; valid result and just verifying or non-symmetric:
6017 ((or verifying (not (equal key-type 'symmetric)))
6018 (if (or verifying decrypt)
6019 (pgg-add-passphrase-to-cache target-cache-id
6023 ;; valid result and regular symmetric - "register"
6024 ;; passphrase with mnemonic aids/cache.
6026 (set-buffer allout-buffer)
6028 (pgg-add-passphrase-to-cache target-cache-id
6030 (allout-update-passphrase-mnemonic-aids for-key passphrase
6037 ;;;_ > allout-obtain-passphrase (for-key cache-id prompt-id key-type
6038 ;;; allout-buffer retried fetch-pass)
6039 (defun allout-obtain-passphrase (for-key cache-id prompt-id key-type
6040 allout-buffer retried fetch-pass)
6041 "Obtain passphrase for a key from the cache or else from the user.
6043 When obtaining from the user, symmetric-cipher passphrases are verified
6044 against either, if available and enabled, a random string that was
6045 encrypted against the passphrase, or else against repeated entry by the
6046 user for corroboration.
6048 FOR-KEY is the key for which the passphrase is being obtained.
6050 CACHE-ID is the cache id of the key for the passphrase.
6052 PROMPT-ID is the id for use when prompting the user.
6054 KEY-TYPE is either 'symmetric or 'keypair.
6056 ALLOUT-BUFFER is the buffer containing the entry being en/decrypted.
6058 RETRIED is the number of this attempt to obtain this passphrase.
6060 FETCH-PASS causes the passphrase to be solicited from the user, regardless
6061 of the availability of a cached copy."
6063 (if (not (equal key-type 'symmetric))
6064 ;; do regular passphrase read on non-symmetric passphrase:
6065 (pgg-read-passphrase (format "%s passphrase%s: "
6066 (upcase (format "%s" (or pgg-scheme
6070 (format " for %s" prompt-id)
6074 ;; Symmetric hereon:
6077 (set-buffer allout-buffer)
6078 (let* ((hint (if (and (not (string= allout-passphrase-hint-string ""))
6079 (or (equal allout-passphrase-hint-handling 'always)
6080 (and (equal allout-passphrase-hint-handling
6083 (format " [%s]" allout-passphrase-hint-string)
6085 (retry-message (if retried (format " (%s retry)" retried) ""))
6086 (prompt-sans-hint (format "'%s' symmetric passphrase%s: "
6087 prompt-id retry-message))
6088 (full-prompt (format "'%s' symmetric passphrase%s%s: "
6089 prompt-id hint retry-message))
6090 (prompt full-prompt)
6091 (verifier-string (allout-get-encryption-passphrase-verifier))
6093 (cached (and (not fetch-pass)
6094 (pgg-read-passphrase-from-cache cache-id t)))
6095 (got-pass (or cached
6096 (pgg-read-passphrase full-prompt cache-id t)))
6102 ;; Duplicate our handle on the passphrase so it's not clobbered by
6103 ;; deactivate-passwd memory clearing:
6104 (setq got-pass (copy-sequence got-pass))
6106 (cond (verifier-string
6107 (save-window-excursion
6108 (if (allout-encrypt-string verifier-string 'decrypt
6109 allout-buffer 'symmetric
6110 for-key nil 0 0 'verifying
6111 (copy-sequence got-pass))
6112 (setq confirmation (format "%s" got-pass))))
6114 (if (and (not confirmation)
6116 (concat "Passphrase differs from established"
6117 " - use new one instead? "))
6118 ;; deactivate password for subsequent
6121 (pgg-remove-passphrase-from-cache cache-id t)
6122 (setq prompt prompt-sans-hint)
6125 (progn (pgg-remove-passphrase-from-cache cache-id t)
6126 (error "Wrong passphrase."))))
6127 ;; No verifier string - force confirmation by repetition of
6128 ;; (new) passphrase:
6129 ((or fetch-pass (not cached))
6130 (pgg-remove-passphrase-from-cache cache-id t))))
6131 ;; confirmation vs new input - doing pgg-read-passphrase will do the
6132 ;; right thing, in either case:
6133 (if (not confirmation)
6135 (pgg-read-passphrase (concat prompt
6136 " ... confirm spelling: ")
6139 (if (equal got-pass confirmation)
6141 (if (yes-or-no-p (concat "spelling of original and"
6142 " confirmation differ - retry? "))
6143 (progn (setq retried (if retried (1+ retried) 1))
6144 (pgg-remove-passphrase-from-cache cache-id t)
6145 ;; recurse to this routine:
6146 (pgg-read-passphrase prompt-sans-hint cache-id t))
6147 (pgg-remove-passphrase-from-cache cache-id t)
6148 (error "Confirmation failed."))))))))
6149 ;;;_ > allout-encrypted-topic-p ()
6150 (defun allout-encrypted-topic-p ()
6151 "True if the current topic is encryptable and encrypted."
6153 (allout-end-of-prefix t)
6154 (and (string= (buffer-substring-no-properties (1- (point)) (point))
6155 allout-topic-encryption-bullet)
6159 ;;;_ > allout-encrypted-key-info (text)
6160 ;; XXX gpg-specific, alas
6161 (defun allout-encrypted-key-info (text)
6162 "Return a pair of the key type and identity of a recipient's secret key.
6164 The key type is one of 'symmetric or 'keypair.
6166 if 'keypair, and some of the user's secret keys are among those for which
6167 the message was encoded, return the identity of the first. otherwise,
6168 return nil for the second item of the pair.
6170 An error is raised if the text is not encrypted."
6171 (require 'pgg-parse)
6175 (let* ((parsed-armor (pgg-parse-armor-region (point-min) (point-max)))
6176 (type (if (pgg-gpg-symmetric-key-p parsed-armor)
6179 secret-keys first-secret-key for-key-owner)
6180 (if (equal type 'keypair)
6181 (setq secret-keys (pgg-gpg-lookup-all-secret-keys)
6182 first-secret-key (pgg-gpg-select-matching-key parsed-armor
6184 for-key-owner (and first-secret-key
6185 (pgg-gpg-lookup-key-owner
6186 first-secret-key))))
6187 (list type (pgg-gpg-key-id-from-key-owner for-key-owner))
6192 ;;;_ > allout-create-encryption-passphrase-verifier (passphrase)
6193 (defun allout-create-encryption-passphrase-verifier (passphrase)
6194 "Encrypt random message for later validation of symmetric key's passphrase."
6195 ;; use 20 random ascii characters, across the entire ascii range.
6197 (let ((spew (make-string 20 ?\0)))
6198 (dotimes (i (length spew))
6199 (aset spew i (1+ (random 254))))
6200 (allout-encrypt-string spew nil (current-buffer) 'symmetric
6201 nil nil 0 0 passphrase))
6203 ;;;_ > allout-update-passphrase-mnemonic-aids (for-key passphrase
6205 (defun allout-update-passphrase-mnemonic-aids (for-key passphrase
6207 "Update passphrase verifier and hint strings if necessary.
6209 See `allout-passphrase-verifier-string' and `allout-passphrase-hint-string'
6212 PASSPHRASE is the passphrase being mnemonicized
6214 OUTLINE-BUFFER is the buffer of the outline being adjusted.
6216 These are used to help the user keep track of the passphrase they use for
6217 symmetric encryption in the file.
6219 Behavior is governed by `allout-passphrase-verifier-handling',
6220 `allout-passphrase-hint-handling', and also, controlling whether the values
6221 are preserved on Emacs local file variables,
6222 `allout-enable-file-variable-adjustment'."
6224 ;; If passphrase doesn't agree with current verifier:
6225 ;; - adjust the verifier
6226 ;; - if passphrase hint handling is enabled, adjust the passphrase hint
6227 ;; - if file var settings are enabled, adjust the file vars
6229 (let* ((new-verifier-needed (not (allout-verify-passphrase
6230 for-key passphrase outline-buffer)))
6231 (new-verifier-string
6232 (if new-verifier-needed
6233 ;; Collapse to a single line and enclose in string quotes:
6234 (subst-char-in-string
6235 ?\n ?\C-a (allout-create-encryption-passphrase-verifier
6238 (when new-verifier-string
6239 ;; do the passphrase hint first, since it's interactive
6240 (when (and allout-passphrase-hint-handling
6241 (not (equal allout-passphrase-hint-handling 'disabled)))
6243 (read-from-minibuffer "Passphrase hint to jog your memory: "
6244 allout-passphrase-hint-string))
6245 (when (not (string= new-hint allout-passphrase-hint-string))
6246 (setq allout-passphrase-hint-string new-hint)
6247 (allout-adjust-file-variable "allout-passphrase-hint-string"
6248 allout-passphrase-hint-string)))
6249 (when allout-passphrase-verifier-handling
6250 (setq allout-passphrase-verifier-string new-verifier-string)
6251 (allout-adjust-file-variable "allout-passphrase-verifier-string"
6252 allout-passphrase-verifier-string))
6256 ;;;_ > allout-get-encryption-passphrase-verifier ()
6257 (defun allout-get-encryption-passphrase-verifier ()
6258 "Return text of the encrypt passphrase verifier, unmassaged, or nil if none.
6260 Derived from value of `allout-passphrase-verifier-string'."
6262 (let ((verifier-string (and (boundp 'allout-passphrase-verifier-string)
6263 allout-passphrase-verifier-string)))
6265 ;; Return it uncollapsed
6266 (subst-char-in-string ?\C-a ?\n verifier-string))
6269 ;;;_ > allout-verify-passphrase (key passphrase allout-buffer)
6270 (defun allout-verify-passphrase (key passphrase allout-buffer)
6271 "True if passphrase successfully decrypts verifier, nil otherwise.
6273 \"Otherwise\" includes absence of passphrase verifier."
6275 (set-buffer allout-buffer)
6276 (and (boundp 'allout-passphrase-verifier-string)
6277 allout-passphrase-verifier-string
6278 (allout-encrypt-string (allout-get-encryption-passphrase-verifier)
6279 'decrypt allout-buffer 'symmetric
6280 key nil 0 0 'verifying passphrase)
6282 ;;;_ > allout-next-topic-pending-encryption (&optional except-mark)
6283 (defun allout-next-topic-pending-encryption (&optional except-mark)
6284 "Return the point of the next topic pending encryption, or nil if none.
6286 EXCEPT-MARK identifies a point whose containing topics should be excluded
6287 from encryption. This supports 'except-current mode of
6288 `allout-encrypt-unencrypted-on-saves'.
6290 Such a topic has the allout-topic-encryption-bullet without an
6291 immediately following '*' that would mark the topic as being encrypted. It
6292 must also have content."
6293 (let (done got content-beg)
6296 (if (not (re-search-forward
6297 (format "\\(\\`\\|\n\\)%s *%s[^*]"
6298 (regexp-quote allout-header-prefix)
6299 (regexp-quote allout-topic-encryption-bullet))
6303 (goto-char (setq got (match-beginning 0)))
6304 (if (looking-at "\n")
6311 ((not (search-forward "\n"))
6320 (setq content-beg (point))
6322 (allout-end-of-subtree)
6323 (if (or (<= (point) content-beg)
6325 (<= content-beg except-mark)
6326 (>= (point) except-mark)))
6337 ;;;_ > allout-encrypt-decrypted (&optional except-mark)
6338 (defun allout-encrypt-decrypted (&optional except-mark)
6339 "Encrypt topics pending encryption except those containing exemption point.
6341 EXCEPT-MARK identifies a point whose containing topics should be excluded
6342 from encryption. This supports 'except-current mode of
6343 `allout-encrypt-unencrypted-on-saves'.
6345 If a topic that is currently being edited was encrypted, we return a list
6346 containing the location of the topic and the location of the cursor just
6347 before the topic was encrypted. This can be used, eg, to decrypt the topic
6348 and exactly resituate the cursor if this is being done as part of a file
6349 save. See `allout-encrypt-unencrypted-on-saves' for more info."
6353 (let* ((current-mark (point-marker))
6354 (current-mark-position (marker-position current-mark))
6357 editing-topic editing-point)
6358 (goto-char (point-min))
6359 (while (allout-next-topic-pending-encryption except-mark)
6360 (setq was-modified (buffer-modified-p))
6361 (when (save-excursion
6362 (and (boundp 'allout-encrypt-unencrypted-on-saves)
6363 allout-encrypt-unencrypted-on-saves
6364 (setq bo-subtree (re-search-forward "$"))
6365 (not (allout-hidden-p))
6366 (>= current-mark (point))
6367 (allout-end-of-current-subtree)
6368 (<= current-mark (point))))
6369 (setq editing-topic (point)
6370 ;; we had to wait for this 'til now so prior topics are
6371 ;; encrypted, any relevant text shifts are in place:
6372 editing-point (- current-mark-position
6373 (count-trailing-whitespace-region
6374 bo-subtree current-mark-position))))
6375 (allout-toggle-subtree-encryption)
6376 (if (not was-modified)
6377 (set-buffer-modified-p nil))
6379 (if (not was-modified)
6380 (set-buffer-modified-p nil))
6381 (if editing-topic (list editing-topic editing-point))
6386 ;;;_ #9 miscellaneous
6388 ;;;_ > outlineify-sticky ()
6389 ;; outlinify-sticky is correct spelling; provide this alias for sticklers:
6391 (defalias 'outlinify-sticky 'outlineify-sticky)
6393 (defun outlineify-sticky (&optional arg)
6394 "Activate outline mode and establish file var so it is started subsequently.
6396 See doc-string for `allout-layout' and `allout-init' for details on
6397 setup for auto-startup."
6404 (goto-char (point-min))
6405 (if (allout-goto-prefix)
6407 (allout-open-topic 2)
6408 (insert (concat "Dummy outline topic header - see"
6409 "`allout-mode' docstring: `^Hm'."))
6410 (allout-adjust-file-variable
6411 "allout-layout" (or allout-layout '(-1 : 0))))))
6412 ;;;_ > allout-file-vars-section-data ()
6413 (defun allout-file-vars-section-data ()
6414 "Return data identifying the file-vars section, or nil if none.
6416 Returns list `(beginning-point prefix-string suffix-string)'."
6417 ;; minimally gleaned from emacs 21.4 files.el hack-local-variables function.
6418 (let (beg prefix suffix)
6420 (goto-char (point-max))
6421 (search-backward "\n\^L" (max (- (point-max) 3000) (point-min)) 'move)
6422 (if (let ((case-fold-search t))
6423 (not (search-forward "Local Variables:" nil t)))
6425 (setq beg (- (point) 16))
6426 (setq suffix (buffer-substring-no-properties
6428 (progn (if (search-forward "\n" nil t)
6431 (setq prefix (buffer-substring-no-properties
6432 (progn (if (search-backward "\n" nil t)
6436 (list beg prefix suffix))
6440 ;;;_ > allout-adjust-file-variable (varname value)
6441 (defun allout-adjust-file-variable (varname value)
6442 "Adjust the setting of an Emacs file variable named VARNAME to VALUE.
6444 This activity is inhibited if either `enable-local-variables'
6445 `allout-enable-file-variable-adjustment' are nil.
6447 When enabled, an entry for the variable is created if not already present,
6448 or changed if established with a different value. The section for the file
6449 variables, itself, is created if not already present. When created, the
6450 section lines \(including the section line) exist as second-level topics in
6451 a top-level topic at the end of the file.
6453 `enable-local-variables' must be true for any of this to happen."
6454 (if (not (and enable-local-variables
6455 allout-enable-file-variable-adjustment))
6458 (let ((inhibit-field-text-motion t)
6459 (section-data (allout-file-vars-section-data))
6462 (setq beg (car section-data)
6463 prefix (cadr section-data)
6464 suffix (car (cddr section-data)))
6465 ;; create the section
6466 (goto-char (point-max))
6468 (allout-open-topic 0)
6470 (insert "Local emacs vars.\n")
6471 (allout-open-topic 1)
6474 prefix (buffer-substring-no-properties (progn
6479 (insert "Local variables:\n")
6480 (allout-open-topic 0)
6483 ;; look for existing entry or create one, leaving point for insertion
6486 (allout-show-to-offshoot)
6487 (if (search-forward (concat "\n" prefix varname ":") nil t)
6488 (let* ((value-beg (point))
6489 (line-end (progn (if (search-forward "\n" nil t)
6492 (value-end (- line-end (length suffix))))
6493 (if (> value-end value-beg)
6494 (delete-region value-beg value-end)))
6498 (insert (concat prefix varname ":")))
6499 (insert (format " %S%s" value suffix))
6504 ;;;_ > allout-get-configvar-values (varname)
6505 (defun allout-get-configvar-values (configvar-name)
6506 "Return a list of values of the symbols in list bound to CONFIGVAR-NAME.
6508 The user is prompted for removal of symbols that are unbound, and they
6509 otherwise are ignored.
6511 CONFIGVAR-NAME should be the name of the configuration variable,
6514 (let ((configvar-value (symbol-value configvar-name))
6516 (dolist (sym configvar-value)
6517 (if (not (boundp sym))
6518 (if (yes-or-no-p (format "%s entry `%s' is unbound - remove it? "
6519 configvar-name sym))
6520 (delq sym (symbol-value configvar-name)))
6521 (push (symbol-value sym) got)))
6524 ;;;_ > allout-mark-topic ()
6525 (defun allout-mark-topic ()
6526 "Put the region around topic currently containing point."
6528 (let ((inhibit-field-text-motion t))
6529 (beginning-of-line))
6530 (allout-goto-prefix-doublechecked)
6532 (allout-end-of-current-subtree)
6533 (exchange-point-and-mark))
6535 ;;;_ > solicit-char-in-string (prompt string &optional do-defaulting)
6536 (defun solicit-char-in-string (prompt string &optional do-defaulting)
6537 "Solicit (with first arg PROMPT) choice of a character from string STRING.
6539 Optional arg DO-DEFAULTING indicates to accept empty input (CR)."
6541 (let ((new-prompt prompt)
6545 (message "%s" new-prompt)
6547 ;; We do our own reading here, so we can circumvent, eg, special
6548 ;; treatment for `?' character. (Oughta use minibuffer keymap instead.)
6550 (char-to-string (let ((cursor-in-echo-area nil)) (read-char))))
6553 (cond ((string-match (regexp-quote got) string) got)
6554 ((and do-defaulting (string= got "\r"))
6555 ;; Return empty string to default:
6557 ((string= got "\C-g") (signal 'quit nil))
6559 (setq new-prompt (concat prompt
6565 ;; got something out of loop - return it:
6569 ;;;_ > regexp-sans-escapes (string)
6570 (defun regexp-sans-escapes (regexp &optional successive-backslashes)
6571 "Return a copy of REGEXP with all character escapes stripped out.
6573 Representations of actual backslashes - '\\\\\\\\' - are left as a
6576 Optional arg SUCCESSIVE-BACKSLASHES is used internally for recursion."
6578 (if (string= regexp "")
6580 ;; Set successive-backslashes to number if current char is
6581 ;; backslash, or else to nil:
6582 (setq successive-backslashes
6583 (if (= (aref regexp 0) ?\\)
6584 (if successive-backslashes (1+ successive-backslashes) 1)
6586 (if (or (not successive-backslashes) (= 2 successive-backslashes))
6587 ;; Include first char:
6588 (concat (substring regexp 0 1)
6589 (regexp-sans-escapes (substring regexp 1)))
6590 ;; Exclude first char, but maintain count:
6591 (regexp-sans-escapes (substring regexp 1) successive-backslashes))))
6592 ;;;_ > count-trailing-whitespace-region (beg end)
6593 (defun count-trailing-whitespace-region (beg end)
6594 "Return number of trailing whitespace chars between BEG and END.
6596 If BEG is bigger than END we return 0."
6602 (while (re-search-forward "[ ][ ]*$" end t)
6603 (goto-char (1+ (match-beginning 2)))
6604 (setq count (1+ count)))
6606 ;;;_ > allout-format-quote (string)
6607 (defun allout-format-quote (string)
6608 "Return a copy of string with all \"%\" characters doubled."
6610 (mapcar (lambda (char) (if (= char ?%) "%%" (char-to-string char)))
6613 ;;;_ > allout-flatten (list)
6614 (defun allout-flatten (list)
6615 "Return a list of all atoms in list."
6617 (cond ((null list) nil)
6618 ((atom (car list)) (cons (car list) (allout-flatten (cdr list))))
6619 (t (append (allout-flatten (car list)) (allout-flatten (cdr list))))))
6620 ;;;_ : Compatability:
6621 ;;;_ > allout-mark-marker to accommodate divergent emacsen:
6622 (defun allout-mark-marker (&optional force buffer)
6623 "Accommodate the different signature for `mark-marker' across Emacsen.
6625 XEmacs takes two optional args, while mainline GNU Emacs does not,
6626 so pass them along when appropriate."
6627 (if (featurep 'xemacs)
6628 (apply 'mark-marker force buffer)
6630 ;;;_ > subst-char-in-string if necessary
6631 (if (not (fboundp 'subst-char-in-string))
6632 (defun subst-char-in-string (fromchar tochar string &optional inplace)
6633 "Replace FROMCHAR with TOCHAR in STRING each time it occurs.
6634 Unless optional argument INPLACE is non-nil, return a new string."
6635 (let ((i (length string))
6636 (newstr (if inplace string (copy-sequence string))))
6639 (if (eq (aref newstr i) fromchar)
6640 (aset newstr i tochar)))
6642 ;;;_ > wholenump if necessary
6643 (if (not (fboundp 'wholenump))
6644 (defalias 'wholenump 'natnump))
6645 ;;;_ > remove-overlays if necessary
6646 (if (not (fboundp 'remove-overlays))
6647 (defun remove-overlays (&optional beg end name val)
6648 "Clear BEG and END of overlays whose property NAME has value VAL.
6649 Overlays might be moved and/or split.
6650 BEG and END default respectively to the beginning and end of buffer."
6651 (unless beg (setq beg (point-min)))
6652 (unless end (setq end (point-max)))
6654 (setq beg (prog1 end (setq end beg))))
6656 (dolist (o (overlays-in beg end))
6657 (when (eq (overlay-get o name) val)
6658 ;; Either push this overlay outside beg...end
6659 ;; or split it to exclude beg...end
6660 ;; or delete it entirely (if it is contained in beg...end).
6661 (if (< (overlay-start o) beg)
6662 (if (> (overlay-end o) end)
6664 (move-overlay (copy-overlay o)
6665 (overlay-start o) beg)
6666 (move-overlay o end (overlay-end o)))
6667 (move-overlay o (overlay-start o) beg))
6668 (if (> (overlay-end o) end)
6669 (move-overlay o end (overlay-end o))
6670 (delete-overlay o)))))))
6672 ;;;_ > copy-overlay if necessary - xemacs ~ 21.4
6673 (if (not (fboundp 'copy-overlay))
6674 (defun copy-overlay (o)
6675 "Return a copy of overlay O."
6676 (let ((o1 (make-overlay (overlay-start o) (overlay-end o)
6677 ;; FIXME: there's no easy way to find the
6678 ;; insertion-type of the two markers.
6679 (overlay-buffer o)))
6680 (props (overlay-properties o)))
6682 (overlay-put o1 (pop props) (pop props)))
6684 ;;;_ > add-to-invisibility-spec if necessary - xemacs ~ 21.4
6685 (if (not (fboundp 'add-to-invisibility-spec))
6686 (defun add-to-invisibility-spec (element)
6687 "Add ELEMENT to `buffer-invisibility-spec'.
6688 See documentation for `buffer-invisibility-spec' for the kind of elements
6690 (if (eq buffer-invisibility-spec t)
6691 (setq buffer-invisibility-spec (list t)))
6692 (setq buffer-invisibility-spec
6693 (cons element buffer-invisibility-spec))))
6694 ;;;_ > remove-from-invisibility-spec if necessary - xemacs ~ 21.4
6695 (if (not (fboundp 'remove-from-invisibility-spec))
6696 (defun remove-from-invisibility-spec (element)
6697 "Remove ELEMENT from `buffer-invisibility-spec'."
6698 (if (consp buffer-invisibility-spec)
6699 (setq buffer-invisibility-spec (delete element
6700 buffer-invisibility-spec)))))
6701 ;;;_ > move-beginning-of-line if necessary - older emacs, xemacs
6702 (if (not (fboundp 'move-beginning-of-line))
6703 (defun move-beginning-of-line (arg)
6704 "Move point to beginning of current line as displayed.
6705 \(This disregards invisible newlines such as those
6706 which are part of the text that an image rests on.)
6708 With argument ARG not nil or 1, move forward ARG - 1 lines first.
6709 If point reaches the beginning or end of buffer, it stops there.
6710 To ignore intangibility, bind `inhibit-point-motion-hooks' to t."
6712 (or arg (setq arg 1))
6714 (condition-case nil (line-move (1- arg)) (error nil)))
6716 ;; Move to beginning-of-line, ignoring fields and invisibles.
6717 (skip-chars-backward "^\n")
6718 (while (and (not (bobp)) (line-move-invisible-p (1- (point))))
6719 (goto-char (if (featurep 'xemacs)
6720 (previous-property-change (point))
6721 (previous-char-property-change (point))))
6722 (skip-chars-backward "^\n"))
6723 (vertical-motion 0))
6725 ;;;_ > move-end-of-line if necessary - older emacs, xemacs
6726 (if (not (fboundp 'move-end-of-line))
6727 (defun move-end-of-line (arg)
6728 "Move point to end of current line as displayed.
6729 \(This disregards invisible newlines such as those
6730 which are part of the text that an image rests on.)
6732 With argument ARG not nil or 1, move forward ARG - 1 lines first.
6733 If point reaches the beginning or end of buffer, it stops there.
6734 To ignore intangibility, bind `inhibit-point-motion-hooks' to t."
6736 (or arg (setq arg 1))
6741 (let ((goal-column 0))
6742 (and (condition-case nil
6743 (or (line-move arg) t)
6747 (while (and (not (bobp))
6748 (line-move-invisible-p (1- (point))))
6750 (previous-char-property-change (point))))
6754 (if (and (> (point) newpos)
6755 (eq (preceding-char) ?\n))
6757 (if (and (> (point) newpos) (not (eobp))
6758 (not (eq (following-char) ?\n)))
6759 ;; If we skipped something intangible
6760 ;; and now we're not really at eol,
6765 ;;;_ > line-move-invisible-p if necessary
6766 (if (not (fboundp 'line-move-invisible-p))
6767 (defun line-move-invisible-p (pos)
6768 "Return non-nil if the character after POS is currently invisible."
6770 (get-char-property pos 'invisible)))
6771 (if (eq buffer-invisibility-spec t)
6773 (or (memq prop buffer-invisibility-spec)
6774 (assq prop buffer-invisibility-spec))))))
6777 ;;;_ > allout-bullet-isearch (&optional bullet)
6778 (defun allout-bullet-isearch (&optional bullet)
6779 "Isearch \(regexp) for topic with bullet BULLET."
6782 (setq bullet (solicit-char-in-string
6783 "ISearch for topic with bullet: "
6784 (regexp-sans-escapes allout-bullets-string))))
6786 (let ((isearch-regexp t)
6787 (isearch-string (concat "^"
6788 allout-header-prefix
6791 (isearch-repeat 'forward)
6794 ;;;_ #11 Unit tests - this should be last item before "Provide"
6795 ;;;_ > allout-run-unit-tests ()
6796 (defun allout-run-unit-tests ()
6797 "Run the various allout unit tests."
6798 (message "Running allout tests...")
6799 (allout-test-resumptions)
6800 (message "Running allout tests... Done.")
6802 ;;;_ : test resumptions:
6803 ;;;_ > allout-tests-obliterate-variable (name)
6804 (defun allout-tests-obliterate-variable (name)
6805 "Completely unbind variable with NAME."
6806 (if (local-variable-p name) (kill-local-variable name))
6807 (while (boundp name) (makunbound name)))
6808 ;;;_ > allout-test-resumptions ()
6809 (defvar allout-tests-globally-unbound nil
6810 "Fodder for allout resumptions tests - defvar just for byte compiler.")
6811 (defvar allout-tests-globally-true nil
6812 "Fodder for allout resumptions tests - defvar just just for byte compiler.")
6813 (defvar allout-tests-locally-true nil
6814 "Fodder for allout resumptions tests - defvar just for byte compiler.")
6815 (defun allout-test-resumptions ()
6816 "Exercise allout resumptions."
6817 ;; for each resumption case, we also test that the right local/global
6818 ;; scopes are affected during resumption effects:
6820 ;; ensure that previously unbound variables return to the unbound state.
6822 (allout-tests-obliterate-variable 'allout-tests-globally-unbound)
6823 (allout-add-resumptions '(allout-tests-globally-unbound t))
6824 (assert (not (default-boundp 'allout-tests-globally-unbound)))
6825 (assert (local-variable-p 'allout-tests-globally-unbound))
6826 (assert (boundp 'allout-tests-globally-unbound))
6827 (assert (equal allout-tests-globally-unbound t))
6828 (allout-do-resumptions)
6829 (assert (not (local-variable-p 'allout-tests-globally-unbound)))
6830 (assert (not (boundp 'allout-tests-globally-unbound))))
6832 ;; ensure that variable with prior global value is resumed
6834 (allout-tests-obliterate-variable 'allout-tests-globally-true)
6835 (setq allout-tests-globally-true t)
6836 (allout-add-resumptions '(allout-tests-globally-true nil))
6837 (assert (equal (default-value 'allout-tests-globally-true) t))
6838 (assert (local-variable-p 'allout-tests-globally-true))
6839 (assert (equal allout-tests-globally-true nil))
6840 (allout-do-resumptions)
6841 (assert (not (local-variable-p 'allout-tests-globally-true)))
6842 (assert (boundp 'allout-tests-globally-true))
6843 (assert (equal allout-tests-globally-true t)))
6845 ;; ensure that prior local value is resumed
6847 (allout-tests-obliterate-variable 'allout-tests-locally-true)
6848 (set (make-local-variable 'allout-tests-locally-true) t)
6849 (assert (not (default-boundp 'allout-tests-locally-true))
6850 nil (concat "Test setup mistake - variable supposed to"
6851 " not have global binding, but it does."))
6852 (assert (local-variable-p 'allout-tests-locally-true)
6853 nil (concat "Test setup mistake - variable supposed to have"
6854 " local binding, but it lacks one."))
6855 (allout-add-resumptions '(allout-tests-locally-true nil))
6856 (assert (not (default-boundp 'allout-tests-locally-true)))
6857 (assert (local-variable-p 'allout-tests-locally-true))
6858 (assert (equal allout-tests-locally-true nil))
6859 (allout-do-resumptions)
6860 (assert (boundp 'allout-tests-locally-true))
6861 (assert (local-variable-p 'allout-tests-locally-true))
6862 (assert (equal allout-tests-locally-true t))
6863 (assert (not (default-boundp 'allout-tests-locally-true))))
6865 ;; ensure that last of multiple resumptions holds, for various scopes.
6867 (allout-tests-obliterate-variable 'allout-tests-globally-unbound)
6868 (allout-tests-obliterate-variable 'allout-tests-globally-true)
6869 (setq allout-tests-globally-true t)
6870 (allout-tests-obliterate-variable 'allout-tests-locally-true)
6871 (set (make-local-variable 'allout-tests-locally-true) t)
6872 (allout-add-resumptions '(allout-tests-globally-unbound t)
6873 '(allout-tests-globally-true nil)
6874 '(allout-tests-locally-true nil))
6875 (allout-add-resumptions '(allout-tests-globally-unbound 2)
6876 '(allout-tests-globally-true 3)
6877 '(allout-tests-locally-true 4))
6878 ;; reestablish many of the basic conditions are maintained after re-add:
6879 (assert (not (default-boundp 'allout-tests-globally-unbound)))
6880 (assert (local-variable-p 'allout-tests-globally-unbound))
6881 (assert (equal allout-tests-globally-unbound 2))
6882 (assert (default-boundp 'allout-tests-globally-true))
6883 (assert (local-variable-p 'allout-tests-globally-true))
6884 (assert (equal allout-tests-globally-true 3))
6885 (assert (not (default-boundp 'allout-tests-locally-true)))
6886 (assert (local-variable-p 'allout-tests-locally-true))
6887 (assert (equal allout-tests-locally-true 4))
6888 (allout-do-resumptions)
6889 (assert (not (local-variable-p 'allout-tests-globally-unbound)))
6890 (assert (not (boundp 'allout-tests-globally-unbound)))
6891 (assert (not (local-variable-p 'allout-tests-globally-true)))
6892 (assert (boundp 'allout-tests-globally-true))
6893 (assert (equal allout-tests-globally-true t))
6894 (assert (boundp 'allout-tests-locally-true))
6895 (assert (local-variable-p 'allout-tests-locally-true))
6896 (assert (equal allout-tests-locally-true t))
6897 (assert (not (default-boundp 'allout-tests-locally-true))))
6899 ;; ensure that deliberately unbinding registered variables doesn't foul things
6901 (allout-tests-obliterate-variable 'allout-tests-globally-unbound)
6902 (allout-tests-obliterate-variable 'allout-tests-globally-true)
6903 (setq allout-tests-globally-true t)
6904 (allout-tests-obliterate-variable 'allout-tests-locally-true)
6905 (set (make-local-variable 'allout-tests-locally-true) t)
6906 (allout-add-resumptions '(allout-tests-globally-unbound t)
6907 '(allout-tests-globally-true nil)
6908 '(allout-tests-locally-true nil))
6909 (allout-tests-obliterate-variable 'allout-tests-globally-unbound)
6910 (allout-tests-obliterate-variable 'allout-tests-globally-true)
6911 (allout-tests-obliterate-variable 'allout-tests-locally-true)
6912 (allout-do-resumptions))
6914 ;;;_ % Run unit tests if `allout-run-unit-tests-after-load' is true:
6915 (when allout-run-unit-tests-on-load
6916 (allout-run-unit-tests))
6921 ;;;_* Local emacs vars.
6922 ;; The following `allout-layout' local variable setting:
6923 ;; - closes all topics from the first topic to just before the third-to-last,
6924 ;; - shows the children of the third to last (config vars)
6925 ;; - and the second to last (code section),
6926 ;; - and closes the last topic (this local-variables section).
6928 ;;allout-layout: (0 : -1 -1 0)
6931 ;; arch-tag: cf38fbc3-c044-450f-8bff-afed8ba5681c
6932 ;;; allout.el ends here