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-header-prefix
217 (defcustom allout-header-prefix
"."
218 "*Leading string which helps distinguish topic headers.
220 Outline topic header lines are identified by a leading topic
221 header prefix, which mostly have the value of this var at their front.
222 \(Level 1 topics are exceptions. They consist of only a single
223 character, which is typically set to the `allout-primary-bullet'. Many
224 outlines start at level 2 to avoid this discrepancy."
227 (make-variable-buffer-local 'allout-header-prefix
)
229 (put 'allout-header-prefix
'safe-local-variable
'stringp
)
230 ;;;_ = allout-primary-bullet
231 (defcustom allout-primary-bullet
"*"
232 "Bullet used for top-level outline topics.
234 Outline topic header lines are identified by a leading topic header
235 prefix, which is concluded by bullets that includes the value of this
236 var and the respective allout-*-bullets-string vars.
238 The value of an asterisk (`*') provides for backwards compatibility
239 with the original Emacs outline mode. See `allout-plain-bullets-string'
240 and `allout-distinctive-bullets-string' for the range of available
244 (make-variable-buffer-local 'allout-primary-bullet
)
246 (put 'allout-primary-bullet
'safe-local-variable
'stringp
)
247 ;;;_ = allout-plain-bullets-string
248 (defcustom allout-plain-bullets-string
".,"
249 "*The bullets normally used in outline topic prefixes.
251 See `allout-distinctive-bullets-string' for the other kind of
254 DO NOT include the close-square-bracket, `]', as a bullet.
256 Outline mode has to be reactivated in order for changes to the value
257 of this var to take effect."
260 (make-variable-buffer-local 'allout-plain-bullets-string
)
262 (put 'allout-plain-bullets-string
'safe-local-variable
'stringp
)
263 ;;;_ = allout-distinctive-bullets-string
264 (defcustom allout-distinctive-bullets-string
"*+-=>()[{}&!?#%\"X@$~_\\:;^"
265 "*Persistent outline header bullets used to distinguish special topics.
267 These bullets are used to distinguish topics from the run-of-the-mill
268 ones. They are not used in the standard topic headers created by
269 the topic-opening, shifting, and rebulleting \(eg, on topic shift,
270 topic paste, blanket rebulleting) routines, but are offered among the
271 choices for rebulleting. They are not altered by the above automatic
272 rebulleting, so they can be used to characterize topics, eg:
275 `\(' parenthetic comment \(with a matching close paren inside)
276 `[' meta-note \(with a matching close ] inside)
282 ... for example. (`#' typically has a special meaning to the software,
283 according to the value of `allout-numbered-bullet'.)
285 See `allout-plain-bullets-string' for the selection of
288 You must run `set-allout-regexp' in order for outline mode to
289 reconcile to changes of this value.
291 DO NOT include the close-square-bracket, `]', on either of the bullet
295 (make-variable-buffer-local 'allout-distinctive-bullets-string
)
297 (put 'allout-distinctive-bullets-string
'safe-local-variable
'stringp
)
299 ;;;_ = allout-use-mode-specific-leader
300 (defcustom allout-use-mode-specific-leader t
301 "*When non-nil, use mode-specific topic-header prefixes.
303 Allout outline mode will use the mode-specific `allout-mode-leaders'
304 and/or comment-start string, if any, to lead the topic prefix string,
305 so topic headers look like comments in the programming language.
307 String values are used as they stand.
309 Value t means to first check for assoc value in `allout-mode-leaders'
310 alist, then use comment-start string, if any, then use default \(`.').
311 \(See note about use of comment-start strings, below.)
313 Set to the symbol for either of `allout-mode-leaders' or
314 `comment-start' to use only one of them, respectively.
316 Value nil means to always use the default \(`.').
318 comment-start strings that do not end in spaces are tripled, and an
319 `_' underscore is tacked on the end, to distinguish them from regular
320 comment strings. comment-start strings that do end in spaces are not
321 tripled, but an underscore is substituted for the space. [This
322 presumes that the space is for appearance, not comment syntax. You
323 can use `allout-mode-leaders' to override this behavior, when
325 :type
'(choice (const t
) (const nil
) string
326 (const allout-mode-leaders
)
327 (const comment-start
))
330 (put 'allout-use-mode-specific-leader
'safe-local-variable
331 '(lambda (x) (or (memq x
'(t nil allout-mode-leaders comment-start
))
333 ;;;_ = allout-mode-leaders
334 (defvar allout-mode-leaders
'()
335 "Specific allout-prefix leading strings per major modes.
337 Entries will be used instead or in lieu of mode-specific
338 comment-start strings. See also `allout-use-mode-specific-leader'.
340 If you're constructing a string that will comment-out outline
341 structuring so it can be included in program code, append an extra
342 character, like an \"_\" underscore, to distinguish the lead string
343 from regular comments that start at bol.")
345 ;;;_ = allout-old-style-prefixes
346 (defcustom allout-old-style-prefixes nil
347 "*When non-nil, use only old-and-crusty `outline-mode' `*' topic prefixes.
349 Non-nil restricts the topic creation and modification
350 functions to asterix-padded prefixes, so they look exactly
351 like the original Emacs-outline style prefixes.
353 Whatever the setting of this variable, both old and new style prefixes
354 are always respected by the topic maneuvering functions."
357 (make-variable-buffer-local 'allout-old-style-prefixes
)
359 (put 'allout-old-style-prefixes
'safe-local-variable
360 (if (fboundp 'booleanp
) 'booleanp
'(lambda (x) (member x
'(t nil
)))))
361 ;;;_ = allout-stylish-prefixes - alternating bullets
362 (defcustom allout-stylish-prefixes t
363 "*Do fancy stuff with topic prefix bullets according to level, etc.
365 Non-nil enables topic creation, modification, and repositioning
366 functions to vary the topic bullet char (the char that marks the topic
367 depth) just preceding the start of the topic text) according to level.
368 Otherwise, only asterisks (`*') and distinctive bullets are used.
370 This is how an outline can look (but sans indentation) with stylish
375 . + One level 3 subtopic
376 . . One level 4 subtopic
377 . . A second 4 subtopic
378 . + Another level 3 subtopic
379 . #1 A numbered level 4 subtopic
381 . ! Another level 4 subtopic with a different distinctive bullet
382 . #4 And another numbered level 4 subtopic
384 This would be an outline with stylish prefixes inhibited (but the
385 numbered and other distinctive bullets retained):
389 . * One level 3 subtopic
390 . * One level 4 subtopic
391 . * A second 4 subtopic
392 . * Another level 3 subtopic
393 . #1 A numbered level 4 subtopic
395 . ! Another level 4 subtopic with a different distinctive bullet
396 . #4 And another numbered level 4 subtopic
398 Stylish and constant prefixes (as well as old-style prefixes) are
399 always respected by the topic maneuvering functions, regardless of
400 this variable setting.
402 The setting of this var is not relevant when `allout-old-style-prefixes'
406 (make-variable-buffer-local 'allout-stylish-prefixes
)
408 (put 'allout-stylish-prefixes
'safe-local-variable
409 (if (fboundp 'booleanp
) 'booleanp
'(lambda (x) (member x
'(t nil
)))))
411 ;;;_ = allout-numbered-bullet
412 (defcustom allout-numbered-bullet
"#"
413 "*String designating bullet of topics that have auto-numbering; nil for none.
415 Topics having this bullet have automatic maintenance of a sibling
416 sequence-number tacked on, just after the bullet. Conventionally set
417 to \"#\", you can set it to a bullet of your choice. A nil value
418 disables numbering maintenance."
419 :type
'(choice (const nil
) string
)
421 (make-variable-buffer-local 'allout-numbered-bullet
)
423 (put 'allout-numbered-bullet
'safe-local-variable
424 (if (fboundp 'string-or-null-p
)
426 '(lambda (x) (or (stringp x
) (null x
)))))
427 ;;;_ = allout-file-xref-bullet
428 (defcustom allout-file-xref-bullet
"@"
429 "*Bullet signifying file cross-references, for `allout-resolve-xref'.
431 Set this var to the bullet you want to use for file cross-references."
432 :type
'(choice (const nil
) string
)
435 (put 'allout-file-xref-bullet
'safe-local-variable
436 (if (fboundp 'string-or-null-p
)
438 '(lambda (x) (or (stringp x
) (null x
)))))
439 ;;;_ = allout-presentation-padding
440 (defcustom allout-presentation-padding
2
441 "*Presentation-format white-space padding factor, for greater indent."
445 (make-variable-buffer-local 'allout-presentation-padding
)
447 (put 'allout-presentation-padding
'safe-local-variable
'integerp
)
449 ;;;_ = allout-abbreviate-flattened-numbering
450 (defcustom allout-abbreviate-flattened-numbering nil
451 "*If non-nil, `allout-flatten-exposed-to-buffer' abbreviates topic
452 numbers to minimal amount with some context. Otherwise, entire
453 numbers are always used."
457 ;;;_ + LaTeX formatting
458 ;;;_ - allout-number-pages
459 (defcustom allout-number-pages nil
460 "*Non-nil turns on page numbering for LaTeX formatting of an outline."
463 ;;;_ - allout-label-style
464 (defcustom allout-label-style
"\\large\\bf"
465 "*Font and size of labels for LaTeX formatting of an outline."
468 ;;;_ - allout-head-line-style
469 (defcustom allout-head-line-style
"\\large\\sl "
470 "*Font and size of entries for LaTeX formatting of an outline."
473 ;;;_ - allout-body-line-style
474 (defcustom allout-body-line-style
" "
475 "*Font and size of entries for LaTeX formatting of an outline."
478 ;;;_ - allout-title-style
479 (defcustom allout-title-style
"\\Large\\bf"
480 "*Font and size of titles for LaTeX formatting of an outline."
484 (defcustom allout-title
'(or buffer-file-name
(buffer-name))
485 "*Expression to be evaluated to determine the title for LaTeX
489 ;;;_ - allout-line-skip
490 (defcustom allout-line-skip
".05cm"
491 "*Space between lines for LaTeX formatting of an outline."
495 (defcustom allout-indent
".3cm"
496 "*LaTeX formatted depth-indent spacing."
500 ;;;_ + Topic encryption
501 ;;;_ = allout-encryption group
502 (defgroup allout-encryption nil
503 "Settings for topic encryption features of allout outliner."
505 ;;;_ = allout-topic-encryption-bullet
506 (defcustom allout-topic-encryption-bullet
"~"
507 "*Bullet signifying encryption of the entry's body."
508 :type
'(choice (const nil
) string
)
510 :group
'allout-encryption
)
511 ;;;_ = allout-passphrase-verifier-handling
512 (defcustom allout-passphrase-verifier-handling t
513 "*Enable use of symmetric encryption passphrase verifier if non-nil.
515 See the docstring for the `allout-enable-file-variable-adjustment'
516 variable for details about allout ajustment of file variables."
519 :group
'allout-encryption
)
520 (make-variable-buffer-local 'allout-passphrase-verifier-handling
)
521 ;;;_ = allout-passphrase-hint-handling
522 (defcustom allout-passphrase-hint-handling
'always
523 "*Dictate outline encryption passphrase reminder handling:
525 always - always show reminder when prompting
526 needed - show reminder on passphrase entry failure
527 disabled - never present or adjust reminder
529 See the docstring for the `allout-enable-file-variable-adjustment'
530 variable for details about allout ajustment of file variables."
531 :type
'(choice (const always
)
535 :group
'allout-encryption
)
536 (make-variable-buffer-local 'allout-passphrase-hint-handling
)
537 ;;;_ = allout-encrypt-unencrypted-on-saves
538 (defcustom allout-encrypt-unencrypted-on-saves t
539 "*When saving, should topics pending encryption be encrypted?
541 The idea is to prevent file-system exposure of any un-encrypted stuff, and
542 mostly covers both deliberate file writes and auto-saves.
544 - Yes: encrypt all topics pending encryption, even if it's the one
545 currently being edited. \(In that case, the currently edited topic
546 will be automatically decrypted before any user interaction, so they
547 can continue editing but the copy on the file system will be
549 Auto-saves will use the \"All except current topic\" mode if this
550 one is selected, to avoid practical difficulties - see below.
551 - All except current topic: skip the topic currently being edited, even if
552 it's pending encryption. This may expose the current topic on the
553 file sytem, but avoids the nuisance of prompts for the encryption
554 passphrase in the middle of editing for, eg, autosaves.
555 This mode is used for auto-saves for both this option and \"Yes\".
556 - No: leave it to the user to encrypt any unencrypted topics.
558 For practical reasons, auto-saves always use the 'except-current policy
559 when auto-encryption is enabled. \(Otherwise, spurious passphrase prompts
560 and unavoidable timing collisions are too disruptive.) If security for a
561 file requires that even the current topic is never auto-saved in the clear,
562 disable auto-saves for that file."
564 :type
'(choice (const :tag
"Yes" t
)
565 (const :tag
"All except current topic" except-current
)
566 (const :tag
"No" nil
))
568 :group
'allout-encryption
)
569 (make-variable-buffer-local 'allout-encrypt-unencrypted-on-saves
)
572 ;;;_ = allout-developer group
573 (defgroup allout-developer nil
574 "Settings for topic encryption features of allout outliner."
576 ;;;_ = allout-run-unit-tests-on-load
577 (defcustom allout-run-unit-tests-on-load nil
578 "*When non-nil, unit tests will be run at end of loading the allout module.
580 Generally, allout code developers are the only ones who'll want to set this.
582 \(If set, this makes it an even better practice to exercise changes by
583 doing byte-compilation with a repeat count, so the file is loaded after
586 See `allout-run-unit-tests' to see what's run."
588 :group
'allout-developer
)
590 ;;;_ + Miscellaneous customization
592 ;;;_ = allout-command-prefix
593 (defcustom allout-command-prefix
"\C-c "
594 "*Key sequence to be used as prefix for outline mode command key bindings.
596 Default is '\C-c<space>'; just '\C-c' is more short-and-sweet, if you're
597 willing to let allout use a bunch of \C-c keybindings."
601 ;;;_ = allout-keybindings-list
602 ;;; You have to reactivate allout-mode - `(allout-mode t)' - to
603 ;;; institute changes to this var.
604 (defvar allout-keybindings-list
()
605 "*List of `allout-mode' key / function bindings, for `allout-mode-map'.
607 String or vector key will be prefaced with `allout-command-prefix',
608 unless optional third, non-nil element is present.")
609 (setq allout-keybindings-list
612 ("\C-n" allout-next-visible-heading
)
613 ("\C-p" allout-previous-visible-heading
)
614 ("\C-u" allout-up-current-level
)
615 ("\C-f" allout-forward-current-level
)
616 ("\C-b" allout-backward-current-level
)
617 ("\C-a" allout-beginning-of-current-entry
)
618 ("\C-e" allout-end-of-entry
)
620 ("\C-i" allout-show-children
)
621 ("\C-s" allout-show-current-subtree
)
622 ("\C-h" allout-hide-current-subtree
)
623 ("h" allout-hide-current-subtree
)
624 ("\C-o" allout-show-current-entry
)
625 ("!" allout-show-all
)
626 ("x" allout-toggle-current-subtree-encryption
)
627 ; Alteration commands:
628 (" " allout-open-sibtopic
)
629 ("." allout-open-subtopic
)
630 ("," allout-open-supertopic
)
631 ("'" allout-shift-in
)
632 (">" allout-shift-in
)
633 ("<" allout-shift-out
)
634 ("\C-m" allout-rebullet-topic
)
635 ("*" allout-rebullet-current-heading
)
636 ("#" allout-number-siblings
)
637 ("\C-k" allout-kill-line t
)
638 ("\C-y" allout-yank t
)
639 ("\M-y" allout-yank-pop t
)
640 ("\C-k" allout-kill-topic
)
641 ; Miscellaneous commands:
642 ;([?\C-\ ] allout-mark-topic)
643 ("@" allout-resolve-xref
)
644 ("=c" allout-copy-exposed-to-buffer
)
645 ("=i" allout-indented-exposed-to-buffer
)
646 ("=t" allout-latexify-exposed
)
647 ("=p" allout-flatten-exposed-to-buffer
)))
649 ;;;_ = allout-inhibit-auto-fill
650 (defcustom allout-inhibit-auto-fill nil
651 "*If non-nil, auto-fill will be inhibited in the allout buffers.
653 You can customize this setting to set it for all allout buffers, or set it
654 in individual buffers if you want to inhibit auto-fill only in particular
655 buffers. \(You could use a function on `allout-mode-hook' to inhibit
656 auto-fill according, eg, to the major mode.\)
658 If you don't set this and auto-fill-mode is enabled, allout will use the
659 value that `normal-auto-fill-function', if any, when allout mode starts, or
660 else allout's special hanging-indent maintaining auto-fill function,
664 (make-variable-buffer-local 'allout-inhibit-auto-fill
)
666 ;;;_ = allout-use-hanging-indents
667 (defcustom allout-use-hanging-indents t
668 "*If non-nil, topic body text auto-indent defaults to indent of the header.
669 Ie, it is indented to be just past the header prefix. This is
670 relevant mostly for use with indented-text-mode, or other situations
671 where auto-fill occurs."
674 (make-variable-buffer-local 'allout-use-hanging-indents
)
676 (put 'allout-use-hanging-indents
'safe-local-variable
677 (if (fboundp 'booleanp
) 'booleanp
'(lambda (x) (member x
'(t nil
)))))
679 ;;;_ = allout-reindent-bodies
680 (defcustom allout-reindent-bodies
(if allout-use-hanging-indents
682 "*Non-nil enables auto-adjust of topic body hanging indent with depth shifts.
684 When active, topic body lines that are indented even with or beyond
685 their topic header are reindented to correspond with depth shifts of
688 A value of t enables reindent in non-programming-code buffers, ie
689 those that do not have the variable `comment-start' set. A value of
690 `force' enables reindent whether or not `comment-start' is set."
691 :type
'(choice (const nil
) (const t
) (const text
) (const force
))
694 (make-variable-buffer-local 'allout-reindent-bodies
)
696 (put 'allout-reindent-bodies
'safe-local-variable
697 '(lambda (x) (memq x
'(nil t text force
))))
699 ;;;_ = allout-enable-file-variable-adjustment
700 (defcustom allout-enable-file-variable-adjustment t
701 "*If non-nil, some allout outline actions edit Emacs local file var text.
703 This can range from changes to existing entries, addition of new ones,
704 and creation of a new local variables section when necessary.
706 Emacs file variables adjustments are also inhibited if `enable-local-variables'
709 Operations potentially causing edits include allout encryption routines.
710 For details, see `allout-toggle-current-subtree-encryption's docstring."
713 (make-variable-buffer-local 'allout-enable-file-variable-adjustment
)
715 ;;;_* CODE - no user customizations below.
717 ;;;_ #1 Internal Outline Formatting and Configuration
719 ;;;_ = allout-version
720 (defvar allout-version
"2.2.1"
721 "Version of currently loaded outline package. \(allout.el)")
722 ;;;_ > allout-version
723 (defun allout-version (&optional here
)
724 "Return string describing the loaded outline version."
726 (let ((msg (concat "Allout Outline Mode v " allout-version
)))
727 (if here
(insert msg
))
730 ;;;_ : Mode activation (defined here because it's referenced early)
732 (defvar allout-mode nil
"Allout outline mode minor-mode flag.")
733 (make-variable-buffer-local 'allout-mode
)
734 ;;;_ = allout-layout nil
735 (defvar allout-layout nil
; LEAVE GLOBAL VALUE NIL - see docstring.
736 "Buffer-specific setting for allout layout.
738 In buffers where this is non-nil \(and if `allout-init' has been run, to
739 enable this behavior), `allout-mode' will be automatically activated. The
740 layout dictated by the value will be used to set the initial exposure when
741 `allout-mode' is activated.
743 \*You should not setq-default this variable non-nil unless you want every
744 visited file to be treated as an allout file.*
746 The value would typically be set by a file local variable. For
747 example, the following lines at the bottom of an Emacs Lisp file:
750 ;;;allout-layout: \(0 : -1 -1 0)
753 dictate activation of `allout-mode' mode when the file is visited
754 \(presuming allout-init was already run), followed by the
755 equivalent of `\(allout-expose-topic 0 : -1 -1 0)'. \(This is
756 the layout used for the allout.el source file.)
758 `allout-default-layout' describes the specification format.
759 `allout-layout' can additionally have the value `t', in which
760 case the value of `allout-default-layout' is used.")
761 (make-variable-buffer-local 'allout-layout
)
763 (put 'allout-layout
'safe-local-variable
764 '(lambda (x) (or (numberp x
) (listp x
) (memq x
'(: * + -
)))))
766 ;;;_ : Topic header format
768 (defvar allout-regexp
""
769 "*Regular expression to match the beginning of a heading line.
771 Any line whose beginning matches this regexp is considered a
772 heading. This var is set according to the user configuration vars
773 by `set-allout-regexp'.")
774 (make-variable-buffer-local 'allout-regexp
)
775 ;;;_ = allout-bullets-string
776 (defvar allout-bullets-string
""
777 "A string dictating the valid set of outline topic bullets.
779 This var should *not* be set by the user - it is set by `set-allout-regexp',
780 and is produced from the elements of `allout-plain-bullets-string'
781 and `allout-distinctive-bullets-string'.")
782 (make-variable-buffer-local 'allout-bullets-string
)
783 ;;;_ = allout-bullets-string-len
784 (defvar allout-bullets-string-len
0
785 "Length of current buffers' `allout-plain-bullets-string'.")
786 (make-variable-buffer-local 'allout-bullets-string-len
)
787 ;;;_ = allout-line-boundary-regexp
788 (defvar allout-line-boundary-regexp
()
789 "`allout-regexp' with outline style beginning-of-line anchor.
791 This is properly set when `allout-regexp' is produced by
792 `set-allout-regexp', so that (match-beginning 2) and (match-end
793 2) delimit the prefix.")
794 (make-variable-buffer-local 'allout-line-boundary-regexp
)
795 ;;;_ = allout-bob-regexp
796 (defvar allout-bob-regexp
()
797 "Like `allout-line-boundary-regexp', for headers at beginning of buffer.
798 \(match-beginning 2) and \(match-end 2) delimit the prefix.")
799 (make-variable-buffer-local 'allout-bob-regexp
)
800 ;;;_ = allout-header-subtraction
801 (defvar allout-header-subtraction
(1- (length allout-header-prefix
))
802 "Allout-header prefix length to subtract when computing topic depth.")
803 (make-variable-buffer-local 'allout-header-subtraction
)
804 ;;;_ = allout-plain-bullets-string-len
805 (defvar allout-plain-bullets-string-len
(length allout-plain-bullets-string
)
806 "Length of `allout-plain-bullets-string', updated by `set-allout-regexp'.")
807 (make-variable-buffer-local 'allout-plain-bullets-string-len
)
810 ;;;_ X allout-reset-header-lead (header-lead)
811 (defun allout-reset-header-lead (header-lead)
812 "*Reset the leading string used to identify topic headers."
813 (interactive "sNew lead string: ")
814 (setq allout-header-prefix header-lead
)
815 (setq allout-header-subtraction
(1- (length allout-header-prefix
)))
817 ;;;_ X allout-lead-with-comment-string (header-lead)
818 (defun allout-lead-with-comment-string (&optional header-lead
)
819 "*Set the topic-header leading string to specified string.
821 Useful when for encapsulating outline structure in programming
822 language comments. Returns the leading string."
825 (if (not (stringp header-lead
))
826 (setq header-lead
(read-string
827 "String prefix for topic headers: ")))
828 (setq allout-reindent-bodies nil
)
829 (allout-reset-header-lead header-lead
)
831 ;;;_ > allout-infer-header-lead ()
832 (defun allout-infer-header-lead ()
833 "Determine appropriate `allout-header-prefix'.
835 Works according to settings of:
838 `allout-header-prefix' (default)
839 `allout-use-mode-specific-leader'
840 and `allout-mode-leaders'.
842 Apply this via \(re)activation of `allout-mode', rather than
843 invoking it directly."
844 (let* ((use-leader (and (boundp 'allout-use-mode-specific-leader
)
845 (if (or (stringp allout-use-mode-specific-leader
)
846 (memq allout-use-mode-specific-leader
847 '(allout-mode-leaders
850 allout-use-mode-specific-leader
851 ;; Oops - garbled value, equate with effect of 't:
855 ((not use-leader
) nil
)
856 ;; Use the explicitly designated leader:
857 ((stringp use-leader
) use-leader
)
858 (t (or (and (memq use-leader
'(t allout-mode-leaders
))
859 ;; Get it from outline mode leaders?
860 (cdr (assq major-mode allout-mode-leaders
)))
861 ;; ... didn't get from allout-mode-leaders...
862 (and (memq use-leader
'(t comment-start
))
864 ;; Use comment-start, maybe tripled, and with
868 (substring comment-start
869 (1- (length comment-start
))))
870 ;; Use comment-start, sans trailing space:
871 (substring comment-start
0 -
1)
872 (concat comment-start comment-start comment-start
))
873 ;; ... and append underscore, whichever:
877 (if (string= leader allout-header-prefix
)
878 nil
; no change, nothing to do.
879 (setq allout-header-prefix leader
)
880 allout-header-prefix
))))
881 ;;;_ > allout-infer-body-reindent ()
882 (defun allout-infer-body-reindent ()
883 "Determine proper setting for `allout-reindent-bodies'.
885 Depends on default setting of `allout-reindent-bodies' \(which see)
886 and presence of setting for `comment-start', to tell whether the
887 file is programming code."
888 (if (and allout-reindent-bodies
890 (not (eq 'force allout-reindent-bodies
)))
891 (setq allout-reindent-bodies nil
)))
892 ;;;_ > set-allout-regexp ()
893 (defun set-allout-regexp ()
894 "Generate proper topic-header regexp form for outline functions.
896 Works with respect to `allout-plain-bullets-string' and
897 `allout-distinctive-bullets-string'."
900 ;; Derive allout-bullets-string from user configured components:
901 (setq allout-bullets-string
"")
902 (let ((strings (list 'allout-plain-bullets-string
903 'allout-distinctive-bullets-string
904 'allout-primary-bullet
))
911 (setq cur-len
(length (setq cur-string
(symbol-value (car strings
)))))
912 (while (< index cur-len
)
913 (setq cur-char
(aref cur-string index
))
914 (setq allout-bullets-string
915 (concat allout-bullets-string
917 ; Single dash would denote a
918 ; sequence, repeated denotes
920 ((eq cur-char ?-
) "--")
921 ; literal close-square-bracket
922 ; doesn't work right in the
924 ((eq cur-char ?\
]) "")
925 (t (regexp-quote (char-to-string cur-char
))))))
926 (setq index
(1+ index
)))
927 (setq strings
(cdr strings
)))
929 ;; Derive next for repeated use in allout-pending-bullet:
930 (setq allout-plain-bullets-string-len
(length allout-plain-bullets-string
))
931 (setq allout-header-subtraction
(1- (length allout-header-prefix
)))
932 ;; Produce the new allout-regexp:
933 (setq allout-regexp
(concat "\\(\\"
936 allout-bullets-string
938 allout-primary-bullet
940 (setq allout-line-boundary-regexp
941 (concat "\\(\n\\)\\(" allout-regexp
"\\)"))
942 (setq allout-bob-regexp
943 (concat "\\(\\`\\)\\(" allout-regexp
"\\)"))
946 ;;;_ = allout-mode-map
947 (defvar allout-mode-map nil
"Keybindings for (allout) outline minor mode.")
948 ;;;_ > produce-allout-mode-map (keymap-alist &optional base-map)
949 (defun produce-allout-mode-map (keymap-list &optional base-map
)
950 "Produce keymap for use as allout-mode-map, from KEYMAP-LIST.
952 Built on top of optional BASE-MAP, or empty sparse map if none specified.
953 See doc string for allout-keybindings-list for format of binding list."
954 (let ((map (or base-map
(make-sparse-keymap)))
955 (pref (list allout-command-prefix
)))
958 (let ((add-pref (null (cdr (cdr cell
))))
959 (key-suff (list (car cell
))))
962 (apply 'concat
(if add-pref
963 (append pref key-suff
)
965 (car (cdr cell
)))))))
968 ;;;_ = allout-prior-bindings - being deprecated.
969 (defvar allout-prior-bindings nil
970 "Variable for use in V18, with allout-added-bindings, for
971 resurrecting, on mode deactivation, bindings that existed before
972 activation. Being deprecated.")
973 ;;;_ = allout-added-bindings - being deprecated
974 (defvar allout-added-bindings nil
975 "Variable for use in V18, with allout-prior-bindings, for
976 resurrecting, on mode deactivation, bindings that existed before
977 activation. Being deprecated.")
979 (defvar allout-mode-exposure-menu
)
980 (defvar allout-mode-editing-menu
)
981 (defvar allout-mode-navigation-menu
)
982 (defvar allout-mode-misc-menu
)
983 (defun produce-allout-mode-menubar-entries ()
985 (easy-menu-define allout-mode-exposure-menu
987 "Allout outline exposure menu."
989 ["Show Entry" allout-show-current-entry t
]
990 ["Show Children" allout-show-children t
]
991 ["Show Subtree" allout-show-current-subtree t
]
992 ["Hide Subtree" allout-hide-current-subtree t
]
993 ["Hide Leaves" allout-hide-current-leaves t
]
995 ["Show All" allout-show-all t
]))
996 (easy-menu-define allout-mode-editing-menu
998 "Allout outline editing menu."
1000 ["Open Sibling" allout-open-sibtopic t
]
1001 ["Open Subtopic" allout-open-subtopic t
]
1002 ["Open Supertopic" allout-open-supertopic t
]
1004 ["Shift Topic In" allout-shift-in t
]
1005 ["Shift Topic Out" allout-shift-out t
]
1006 ["Rebullet Topic" allout-rebullet-topic t
]
1007 ["Rebullet Heading" allout-rebullet-current-heading t
]
1008 ["Number Siblings" allout-number-siblings t
]
1010 ["Toggle Topic Encryption"
1011 allout-toggle-current-subtree-encryption
1012 (> (allout-current-depth) 1)]))
1013 (easy-menu-define allout-mode-navigation-menu
1015 "Allout outline navigation menu."
1017 ["Next Visible Heading" allout-next-visible-heading t
]
1018 ["Previous Visible Heading"
1019 allout-previous-visible-heading t
]
1021 ["Up Level" allout-up-current-level t
]
1022 ["Forward Current Level" allout-forward-current-level t
]
1023 ["Backward Current Level"
1024 allout-backward-current-level t
]
1026 ["Beginning of Entry"
1027 allout-beginning-of-current-entry t
]
1028 ["End of Entry" allout-end-of-entry t
]
1029 ["End of Subtree" allout-end-of-current-subtree t
]))
1030 (easy-menu-define allout-mode-misc-menu
1032 "Allout outlines miscellaneous bindings."
1034 ["Version" allout-version t
]
1036 ["Duplicate Exposed" allout-copy-exposed-to-buffer t
]
1037 ["Duplicate Exposed, numbered"
1038 allout-flatten-exposed-to-buffer t
]
1039 ["Duplicate Exposed, indented"
1040 allout-indented-exposed-to-buffer t
]
1042 ["Set Header Lead" allout-reset-header-lead t
]
1043 ["Set New Exposure" allout-expose-topic t
])))
1044 ;;;_ : Allout Modal-Variables Utilities
1045 ;;;_ = allout-mode-prior-settings
1046 (defvar allout-mode-prior-settings nil
1047 "Internal `allout-mode' use; settings to be resumed on mode deactivation.
1049 See `allout-add-resumptions' and `allout-do-resumptions'.")
1050 (make-variable-buffer-local 'allout-mode-prior-settings
)
1051 ;;;_ > allout-add-resumptions (&rest pairs)
1052 (defun allout-add-resumptions (&rest pairs
)
1053 "Set name/value pairs.
1055 Old settings are preserved for later resumption using `allout-do-resumptions'.
1057 The pairs are lists whose car is the name of the variable and car of the
1058 cdr is the new value: '(some-var some-value)'.
1060 The new value is set as a buffer local.
1062 If the variable was not previously buffer-local, then that is noted and the
1063 `allout-do-resumptions' will just `kill-local-variable' of that binding.
1065 If it previously was buffer-local, the old value is noted and resurrected
1066 by `allout-do-resumptions'. \(If the local value was previously void, then
1067 it is left as nil on resumption.\)
1069 The settings are stored on `allout-mode-prior-settings'."
1071 (let* ((pair (pop pairs
))
1073 (value (cadr pair
)))
1074 (if (not (symbolp name
))
1075 (error "Pair's name, %S, must be a symbol, not %s"
1076 name
(type-of name
)))
1077 (when (not (assoc name allout-mode-prior-settings
))
1078 ;; Not already added as a resumption, create the prior setting entry.
1079 (if (local-variable-p name
)
1080 ;; is already local variable - preserve the prior value:
1081 (push (list name
(condition-case err
1083 (void-variable nil
)))
1084 allout-mode-prior-settings
)
1085 ;; wasn't local variable, indicate so for resumption by killing
1086 ;; local value, and make it local:
1087 (push (list name
) allout-mode-prior-settings
)
1088 (make-local-variable name
)))
1090 ;;;_ > allout-do-resumptions ()
1091 (defun allout-do-resumptions ()
1092 "Resume all name/value settings registered by `allout-add-resumptions'.
1094 This is used when concluding allout-mode, to resume selected variables to
1095 their settings before allout-mode was started."
1097 (while allout-mode-prior-settings
1098 (let* ((pair (pop allout-mode-prior-settings
))
1100 (value-cell (cdr pair
)))
1101 (if (not value-cell
)
1102 ;; Prior value was global:
1103 (kill-local-variable name
)
1104 ;; Prior value was explicit:
1105 (set name
(car value-cell
))))))
1106 ;;;_ : Mode-specific incidentals
1107 ;;;_ > allout-unprotected (expr)
1108 (defmacro allout-unprotected
(expr)
1109 "Enable internal outline operations to alter invisible text."
1110 `(let ((inhibit-read-only t
)
1111 (inhibit-field-text-motion t
))
1113 ;;;_ = allout-mode-hook
1114 (defvar allout-mode-hook nil
1115 "*Hook that's run when allout mode starts.")
1116 ;;;_ = allout-mode-deactivate-hook
1117 (defvar allout-mode-deactivate-hook nil
1118 "*Hook that's run when allout mode ends.")
1119 ;;;_ = allout-exposure-category
1120 (defvar allout-exposure-category nil
1121 "Symbol for use as allout invisible-text overlay category.")
1122 ;;;_ x allout-view-change-hook
1123 (defvar allout-view-change-hook nil
1124 "*\(Deprecated\) Hook that's run after allout outline exposure changes.
1126 Switch to using `allout-exposure-change-hook' instead. Both
1127 variables are currently respected, but this one will be ignored
1128 in a subsequent allout version.")
1129 ;;;_ = allout-exposure-change-hook
1130 (defvar allout-exposure-change-hook nil
1131 "*Hook that's run after allout outline exposure changes.
1133 This variable will replace `allout-view-change-hook' in a subsequent allout
1134 version, though both are currently respected.")
1136 ;;;_ = allout-outside-normal-auto-fill-function
1137 (defvar allout-outside-normal-auto-fill-function nil
1138 "Value of normal-auto-fill-function outside of allout mode.
1140 Used by allout-auto-fill to do the mandated normal-auto-fill-function
1141 wrapped within allout's automatic fill-prefix setting.")
1142 (make-variable-buffer-local 'allout-outside-normal-auto-fill-function
)
1143 ;;;_ = file-var-bug hack
1144 (defvar allout-v18
/19-file-var-hack nil
1145 "Horrible hack used to prevent invalid multiple triggering of outline
1146 mode from prop-line file-var activation. Used by `allout-mode' function
1148 ;;;_ = allout-passphrase-verifier-string
1149 (defvar allout-passphrase-verifier-string nil
1150 "Setting used to test solicited encryption passphrases against the one
1151 already associated with a file.
1153 It consists of an encrypted random string useful only to verify that a
1154 passphrase entered by the user is effective for decryption. The passphrase
1155 itself is \*not* recorded in the file anywhere, and the encrypted contents
1156 are random binary characters to avoid exposing greater susceptibility to
1159 The verifier string is retained as an Emacs file variable, as well as in
1160 the emacs buffer state, if file variable adjustments are enabled. See
1161 `allout-enable-file-variable-adjustment' for details about that.")
1162 (make-variable-buffer-local 'allout-passphrase-verifier-string
)
1164 (put 'allout-passphrase-verifier-string
'safe-local-variable
'stringp
)
1165 ;;;_ = allout-passphrase-hint-string
1166 (defvar allout-passphrase-hint-string
""
1167 "Variable used to retain reminder string for file's encryption passphrase.
1169 See the description of `allout-passphrase-hint-handling' for details about how
1170 the reminder is deployed.
1172 The hint is retained as an Emacs file variable, as well as in the emacs buffer
1173 state, if file variable adjustments are enabled. See
1174 `allout-enable-file-variable-adjustment' for details about that.")
1175 (make-variable-buffer-local 'allout-passphrase-hint-string
)
1176 (setq-default allout-passphrase-hint-string
"")
1178 (put 'allout-passphrase-hint-string
'safe-local-variable
'stringp
)
1179 ;;;_ = allout-after-save-decrypt
1180 (defvar allout-after-save-decrypt nil
1181 "Internal variable, is nil or has the value of two points:
1183 - the location of a topic to be decrypted after saving is done
1184 - where to situate the cursor after the decryption is performed
1186 This is used to decrypt the topic that was currently being edited, if it
1187 was encrypted automatically as part of a file write or autosave.")
1188 (make-variable-buffer-local 'allout-after-save-decrypt
)
1189 ;;;_ > allout-mode-p ()
1190 ;; Must define this macro above any uses, or byte compilation will lack
1191 ;; proper def, if file isn't loaded - eg, during emacs build!
1192 (defmacro allout-mode-p
()
1193 "Return t if `allout-mode' is active in current buffer."
1195 ;;;_ > allout-write-file-hook-handler ()
1196 (defun allout-write-file-hook-handler ()
1197 "Implement `allout-encrypt-unencrypted-on-saves' policy for file writes."
1199 (if (or (not (allout-mode-p))
1200 (not (boundp 'allout-encrypt-unencrypted-on-saves
))
1201 (not allout-encrypt-unencrypted-on-saves
))
1203 (let ((except-mark (and (equal allout-encrypt-unencrypted-on-saves
1206 (if (save-excursion (goto-char (point-min))
1207 (allout-next-topic-pending-encryption except-mark
))
1209 (message "auto-encrypting pending topics")
1211 (condition-case failure
1212 (setq allout-after-save-decrypt
1213 (allout-encrypt-decrypted except-mark
))
1216 "allout-write-file-hook-handler suppressing error %s"
1221 ;;;_ > allout-auto-save-hook-handler ()
1222 (defun allout-auto-save-hook-handler ()
1223 "Implement `allout-encrypt-unencrypted-on-saves' policy for auto save."
1225 (if (and (allout-mode-p) allout-encrypt-unencrypted-on-saves
)
1226 ;; Always implement 'except-current policy when enabled.
1227 (let ((allout-encrypt-unencrypted-on-saves 'except-current
))
1228 (allout-write-file-hook-handler))))
1229 ;;;_ > allout-after-saves-handler ()
1230 (defun allout-after-saves-handler ()
1231 "Decrypt topic encrypted for save, if it's currently being edited.
1233 Ie, if it was pending encryption and contained the point in its body before
1236 We use values stored in `allout-after-save-decrypt' to locate the topic
1237 and the place for the cursor after the decryption is done."
1238 (if (not (and (allout-mode-p)
1239 (boundp 'allout-after-save-decrypt
)
1240 allout-after-save-decrypt
))
1242 (goto-char (car allout-after-save-decrypt
))
1243 (let ((was-modified (buffer-modified-p)))
1244 (allout-toggle-subtree-encryption)
1245 (if (not was-modified
)
1246 (set-buffer-modified-p nil
)))
1247 (goto-char (cadr allout-after-save-decrypt
))
1248 (setq allout-after-save-decrypt nil
))
1251 ;;;_ #2 Mode activation
1252 ;;;_ = allout-explicitly-deactivated
1253 (defvar allout-explicitly-deactivated nil
1254 "If t, `allout-mode's last deactivation was deliberate.
1255 So `allout-post-command-business' should not reactivate it...")
1256 (make-variable-buffer-local 'allout-explicitly-deactivated
)
1257 ;;;_ > allout-init (&optional mode)
1258 (defun allout-init (&optional mode
)
1259 "Prime `allout-mode' to enable/disable auto-activation, wrt `allout-layout'.
1261 MODE is one of the following symbols:
1263 - nil \(or no argument) deactivate auto-activation/layout;
1264 - `activate', enable auto-activation only;
1265 - `ask', enable auto-activation, and enable auto-layout but with
1266 confirmation for layout operation solicited from user each time;
1267 - `report', just report and return the current auto-activation state;
1268 - anything else \(eg, t) for auto-activation and auto-layout, without
1269 any confirmation check.
1271 Use this function to setup your Emacs session for automatic activation
1272 of allout outline mode, contingent to the buffer-specific setting of
1273 the `allout-layout' variable. (See `allout-layout' and
1274 `allout-expose-topic' docstrings for more details on auto layout).
1276 `allout-init' works by setting up (or removing) the `allout-mode'
1277 find-file-hook, and giving `allout-auto-activation' a suitable
1280 To prime your Emacs session for full auto-outline operation, include
1281 the following two lines in your Emacs init file:
1291 (concat "Select outline auto setup mode "
1292 "(empty for report, ? for options) ")
1293 '(("nil")("full")("activate")("deactivate")
1294 ("ask") ("report") (""))
1297 (if (string= mode
"")
1299 (setq mode
(intern-soft mode
)))))
1301 ;; convenience aliases, for consistent ref to respective vars:
1302 ((hook 'allout-find-file-hook
)
1303 (find-file-hook-var-name (if (boundp 'find-file-hook
)
1306 (curr-mode 'allout-auto-activation
))
1309 (set find-file-hook-var-name
1310 (delq hook
(symbol-value find-file-hook-var-name
)))
1312 (message "Allout outline mode auto-activation inhibited.")))
1314 (if (not (memq hook
(symbol-value find-file-hook-var-name
)))
1316 ;; Just punt and use the reports from each of the modes:
1317 (allout-init (symbol-value curr-mode
))))
1318 (t (add-hook find-file-hook-var-name hook
)
1319 (set curr-mode
; `set', not `setq'!
1320 (cond ((eq mode
'activate
)
1322 "Outline mode auto-activation enabled.")
1325 ;; Return the current mode setting:
1329 (concat "Outline mode auto-activation and "
1330 "-layout \(upon confirmation) enabled."))
1333 "Outline mode auto-activation and -layout enabled.")
1335 ;;;_ > allout-setup-menubar ()
1336 (defun allout-setup-menubar ()
1337 "Populate the current buffer's menubar with `allout-mode' stuff."
1338 (let ((menus (list allout-mode-exposure-menu
1339 allout-mode-editing-menu
1340 allout-mode-navigation-menu
1341 allout-mode-misc-menu
))
1344 (setq cur
(car menus
)
1346 (easy-menu-add cur
))))
1347 ;;;_ > allout-overlay-preparations
1348 (defun allout-overlay-preparations ()
1349 "Set the properties of the allout invisible-text overlay and others."
1350 (setplist 'allout-exposure-category nil
)
1351 (put 'allout-exposure-category
'invisible
'allout
)
1352 (put 'allout-exposure-category
'evaporate t
)
1353 ;; XXX We use isearch-open-invisible *and* isearch-mode-end-hook. The
1354 ;; latter would be sufficient, but it seems that a separate behavior -
1355 ;; the _transient_ opening of invisible text during isearch - is keyed to
1356 ;; presence of the isearch-open-invisible property - even though this
1357 ;; property controls the isearch _arrival_ behavior. This is the case at
1358 ;; least in emacs 21, 22.0, and xemacs 21.4.
1359 (put 'allout-exposure-category
'isearch-open-invisible
1360 'allout-isearch-end-handler
)
1361 (if (featurep 'xemacs
)
1362 (put 'allout-exposure-category
'start-open t
)
1363 (put 'allout-exposure-category
'insert-in-front-hooks
1364 '(allout-overlay-insert-in-front-handler)))
1365 (put 'allout-exposure-category
'modification-hooks
1366 '(allout-overlay-interior-modification-handler)))
1367 ;;;_ > allout-mode (&optional toggle)
1370 (defun allout-mode (&optional toggle
)
1372 "Toggle minor mode for controlling exposure and editing of text outlines.
1375 Optional arg forces mode to re-initialize iff arg is positive num or
1376 symbol. Allout outline mode always runs as a minor mode.
1378 Allout outline mode provides extensive outline oriented formatting and
1379 manipulation. It enables structural editing of outlines, as well as
1380 navigation and exposure. It also is specifically aimed at
1381 accommodating syntax-sensitive text like programming languages. \(For
1382 an example, see the allout code itself, which is organized as an allout
1385 In addition to outline navigation and exposure, allout includes:
1387 - topic-oriented repositioning, promotion/demotion, cut, and paste
1388 - integral outline exposure-layout
1389 - incremental search with dynamic exposure and reconcealment of hidden text
1390 - automatic topic-number maintenance
1391 - easy topic encryption and decryption
1392 - \"Hot-spot\" operation, for single-keystroke maneuvering and
1393 exposure control. \(See the allout-mode docstring.)
1395 and many other features.
1397 Below is a description of the bindings, and then explanation of
1398 special `allout-mode' features and terminology. See also the outline
1399 menubar additions for quick reference to many of the features, and see
1400 the docstring of the function `allout-init' for instructions on
1401 priming your emacs session for automatic activation of `allout-mode'.
1404 The bindings are dictated by the `allout-keybindings-list' and
1405 `allout-command-prefix' variables.
1407 Navigation: Exposure Control:
1408 ---------- ----------------
1409 \\[allout-next-visible-heading] allout-next-visible-heading | \\[allout-hide-current-subtree] allout-hide-current-subtree
1410 \\[allout-previous-visible-heading] allout-previous-visible-heading | \\[allout-show-children] allout-show-children
1411 \\[allout-up-current-level] allout-up-current-level | \\[allout-show-current-subtree] allout-show-current-subtree
1412 \\[allout-forward-current-level] allout-forward-current-level | \\[allout-show-current-entry] allout-show-current-entry
1413 \\[allout-backward-current-level] allout-backward-current-level | \\[allout-show-all] allout-show-all
1414 \\[allout-end-of-entry] allout-end-of-entry
1415 \\[allout-beginning-of-current-entry] allout-beginning-of-current-entry, alternately, goes to hot-spot
1417 Topic Header Production:
1418 -----------------------
1419 \\[allout-open-sibtopic] allout-open-sibtopic Create a new sibling after current topic.
1420 \\[allout-open-subtopic] allout-open-subtopic ... an offspring of current topic.
1421 \\[allout-open-supertopic] allout-open-supertopic ... a sibling of the current topic's parent.
1423 Topic Level and Prefix Adjustment:
1424 ---------------------------------
1425 \\[allout-shift-in] allout-shift-in Shift current topic and all offspring deeper.
1426 \\[allout-shift-out] allout-shift-out ... less deep.
1427 \\[allout-rebullet-current-heading] allout-rebullet-current-heading Prompt for alternate bullet for
1429 \\[allout-rebullet-topic] allout-rebullet-topic Reconcile bullets of topic and its offspring
1430 - distinctive bullets are not changed, others
1431 alternated according to nesting depth.
1432 \\[allout-number-siblings] allout-number-siblings Number bullets of topic and siblings - the
1433 offspring are not affected. With repeat
1434 count, revoke numbering.
1436 Topic-oriented Killing and Yanking:
1437 ----------------------------------
1438 \\[allout-kill-topic] allout-kill-topic Kill current topic, including offspring.
1439 \\[allout-kill-line] allout-kill-line Like kill-line, but reconciles numbering, etc.
1440 \\[allout-yank] allout-yank Yank, adjusting depth of yanked topic to
1441 depth of heading if yanking into bare topic
1442 heading (ie, prefix sans text).
1443 \\[allout-yank-pop] allout-yank-pop Is to allout-yank as yank-pop is to yank
1445 Topic-oriented Encryption:
1446 -------------------------
1447 \\[allout-toggle-current-subtree-encryption] allout-toggle-current-subtree-encryption Encrypt/Decrypt topic content
1451 M-x outlineify-sticky Activate outline mode for current buffer,
1452 and establish a default file-var setting
1453 for `allout-layout'.
1454 \\[allout-mark-topic] allout-mark-topic
1455 \\[allout-copy-exposed-to-buffer] allout-copy-exposed-to-buffer
1456 Duplicate outline, sans concealed text, to
1457 buffer with name derived from derived from that
1458 of current buffer - \"*BUFFERNAME exposed*\".
1459 \\[allout-flatten-exposed-to-buffer] allout-flatten-exposed-to-buffer
1460 Like above 'copy-exposed', but convert topic
1461 prefixes to section.subsection... numeric
1463 \\[eval-expression] (allout-init t) Setup Emacs session for outline mode
1468 Outline mode supports gpg encryption of topics, with support for
1469 symmetric and key-pair modes, passphrase timeout, passphrase
1470 consistency checking, user-provided hinting for symmetric key
1471 mode, and auto-encryption of topics pending encryption on save.
1472 \(Topics pending encryption are, by default, automatically
1473 encrypted during file saves; if you're editing the contents of
1474 such a topic, it is automatically decrypted for continued
1475 editing.) The aim is reliable topic privacy while preventing
1476 accidents like neglected encryption before saves, forgetting
1477 which passphrase was used, and other practical pitfalls.
1479 See `allout-toggle-current-subtree-encryption' function docstring and
1480 `allout-encrypt-unencrypted-on-saves' customization variable for details.
1484 Hot-spot operation provides a means for easy, single-keystroke outline
1485 navigation and exposure control.
1487 When the text cursor is positioned directly on the bullet character of
1488 a topic, regular characters (a to z) invoke the commands of the
1489 corresponding allout-mode keymap control chars. For example, \"f\"
1490 would invoke the command typically bound to \"C-c<space>C-f\"
1491 \(\\[allout-forward-current-level] `allout-forward-current-level').
1493 Thus, by positioning the cursor on a topic bullet, you can
1494 execute the outline navigation and manipulation commands with a
1495 single keystroke. Regular navigation keys (eg, \\[forward-char], \\[next-line]) never get
1496 this special translation, so you can use them to get out of the
1497 hot-spot and back to normal operation.
1499 Note that the command `allout-beginning-of-current-entry' \(\\[allout-beginning-of-current-entry]\)
1500 will move to the hot-spot when the cursor is already located at the
1501 beginning of the current entry, so you usually can hit \\[allout-beginning-of-current-entry]
1502 twice in a row to get to the hot-spot.
1506 Topic hierarchy constituents - TOPICS and SUBTOPICS:
1508 TOPIC: A basic, coherent component of an Emacs outline. It can
1509 contain and be contained by other topics.
1511 The visible topic most immediately containing the cursor.
1512 DEPTH: The degree of nesting of a topic; it increases with
1513 containment. Also called the:
1514 LEVEL: The same as DEPTH.
1517 The topics that contain a topic.
1518 PARENT: A topic's immediate ancestor. It has a depth one less than
1521 The topics contained by a topic;
1523 An immediate offspring of a topic;
1525 The immediate offspring of a topic.
1527 Topics having the same parent and depth.
1529 Topic text constituents:
1531 HEADER: The first line of a topic, include the topic PREFIX and header
1533 PREFIX: The leading text of a topic which distinguishes it from normal
1534 text. It has a strict form, which consists of a prefix-lead
1535 string, padding, and a bullet. The bullet may be followed by a
1536 number, indicating the ordinal number of the topic among its
1537 siblings, a space, and then the header text.
1539 The relative length of the PREFIX determines the nesting depth
1542 The string at the beginning of a topic prefix, normally a `.'.
1543 It can be customized by changing the setting of
1544 `allout-header-prefix' and then reinitializing `allout-mode'.
1546 By setting the prefix-lead to the comment-string of a
1547 programming language, you can embed outline structuring in
1548 program code without interfering with the language processing
1549 of that code. See `allout-use-mode-specific-leader'
1550 docstring for more detail.
1552 Spaces or asterisks which separate the prefix-lead and the
1553 bullet, determining the depth of the topic.
1554 BULLET: A character at the end of the topic prefix, it must be one of
1555 the characters listed on `allout-plain-bullets-string' or
1556 `allout-distinctive-bullets-string'. (See the documentation
1557 for these variables for more details.) The default choice of
1558 bullet when generating topics varies in a cycle with the depth of
1560 ENTRY: The text contained in a topic before any offspring.
1561 BODY: Same as ENTRY.
1565 The state of a topic which determines the on-screen visibility
1566 of its offspring and contained text.
1568 Topics and entry text whose display is inhibited. Contiguous
1569 units of concealed text is represented by `...' ellipses.
1571 Concealed topics are effectively collapsed within an ancestor.
1572 CLOSED: A topic whose immediate offspring and body-text is concealed.
1573 OPEN: A topic that is not closed, though its offspring or body may be."
1577 (let* ((active (and (not (equal major-mode
'outline
))
1579 ; Massage universal-arg `toggle' val:
1581 (or (and (listp toggle
)(car toggle
))
1583 ; Activation specifically demanded?
1584 (explicit-activation (and toggle
1585 (or (symbolp toggle
)
1586 (and (wholenump toggle
)
1587 (not (zerop toggle
))))))
1588 ;; allout-mode already called once during this complex command?
1589 (same-complex-command (eq allout-v18
/19-file-var-hack
1590 (car command-history
)))
1591 (write-file-hook-var-name (cond ((boundp 'write-file-functions
)
1592 'write-file-functions
)
1593 ((boundp 'write-file-hooks
)
1595 (t 'local-write-file-hooks
)))
1599 ; See comments below re v19.18,.19 bug.
1600 (setq allout-v18
/19-file-var-hack
(car command-history
))
1604 ;; Provision for v19.18, 19.19 bug -
1605 ;; Emacs v 19.18, 19.19 file-var code invokes prop-line-designated
1606 ;; modes twice when file is visited. We have to avoid toggling mode
1607 ;; off on second invocation, so we detect it as best we can, and
1609 ((and same-complex-command
; Still in same complex command
1610 ; as last time `allout-mode' invoked.
1611 active
; Already activated.
1612 (not explicit-activation
) ; Prop-line file-vars don't have args.
1613 (string-match "^19.1[89]" ; Bug only known to be in v19.18 and
1614 emacs-version
)); 19.19.
1618 ((and (not explicit-activation
)
1620 ; Activation not explicitly
1621 ; requested, and either in
1622 ; active state or *de*activation
1623 ; specifically requested:
1624 (setq allout-explicitly-deactivated t
)
1626 (allout-do-resumptions)
1628 (remove-from-invisibility-spec '(allout . t
))
1629 (remove-hook 'pre-command-hook
'allout-pre-command-business t
)
1630 (remove-hook 'post-command-hook
'allout-post-command-business t
)
1631 (when (featurep 'xemacs
)
1632 (remove-hook 'before-change-functions
'allout-before-change-handler t
))
1633 (remove-hook 'isearch-mode-end-hook
'allout-isearch-end-handler t
)
1634 (remove-hook write-file-hook-var-name
'allout-write-file-hook-handler t
)
1635 (remove-hook 'auto-save-hook
'allout-auto-save-hook-handler t
)
1637 (remove-overlays (point-min) (point-max)
1638 'category
'allout-exposure-category
)
1640 (run-hooks 'allout-mode-deactivate-hook
)
1641 (setq allout-mode nil
))
1645 (setq allout-explicitly-deactivated nil
)
1646 (if allout-old-style-prefixes
1647 ;; Inhibit all the fancy formatting:
1648 (allout-add-resumptions '((allout-primary-bullet "*")
1649 (allout-old-style-prefixes ()))))
1651 (allout-overlay-preparations) ; Doesn't hurt to redo this.
1653 (allout-infer-header-lead)
1654 (allout-infer-body-reindent)
1658 ;; Produce map from current version of allout-keybindings-list:
1659 (setq allout-mode-map
1660 (produce-allout-mode-map allout-keybindings-list
))
1661 (substitute-key-definition 'beginning-of-line
1662 'move-beginning-of-line
1663 allout-mode-map global-map
)
1664 (substitute-key-definition 'end-of-line
1666 allout-mode-map global-map
)
1667 (produce-allout-mode-menubar-entries)
1668 (fset 'allout-mode-map allout-mode-map
)
1670 ;; Include on minor-mode-map-alist, if not already there:
1671 (if (not (member '(allout-mode . allout-mode-map
)
1672 minor-mode-map-alist
))
1673 (setq minor-mode-map-alist
1674 (cons '(allout-mode . allout-mode-map
)
1675 minor-mode-map-alist
)))
1677 (add-to-invisibility-spec '(allout . t
))
1678 (allout-add-resumptions '(line-move-ignore-invisible t
))
1679 (add-hook 'pre-command-hook
'allout-pre-command-business nil t
)
1680 (add-hook 'post-command-hook
'allout-post-command-business nil t
)
1681 (when (featurep 'xemacs
)
1682 (add-hook 'before-change-functions
'allout-before-change-handler
1684 (add-hook 'isearch-mode-end-hook
'allout-isearch-end-handler nil t
)
1685 (add-hook write-file-hook-var-name
'allout-write-file-hook-handler
1687 (add-hook 'auto-save-hook
'allout-auto-save-hook-handler
1690 ;; Stash auto-fill settings and adjust so custom allout auto-fill
1691 ;; func will be used if auto-fill is active or activated. (The
1692 ;; custom func respects topic headline, maintains hanging-indents,
1694 (if (and auto-fill-function
(not allout-inhibit-auto-fill
))
1695 ;; allout-auto-fill will use the stashed values and so forth.
1696 (allout-add-resumptions '(auto-fill-function allout-auto-fill
)))
1697 (allout-add-resumptions (list 'allout-former-auto-filler
1699 ;; Register allout-auto-fill to be used if
1700 ;; filling is active:
1701 (list 'allout-outside-normal-auto-fill-function
1702 normal-auto-fill-function
)
1703 '(normal-auto-fill-function allout-auto-fill
)
1704 ;; Paragraphs are broken by topic headlines.
1705 (list 'paragraph-start
1706 (concat paragraph-start
"\\|^\\("
1707 allout-regexp
"\\)"))
1708 (list 'paragraph-separate
1709 (concat paragraph-separate
"\\|^\\("
1710 allout-regexp
"\\)")))
1711 (or (assq 'allout-mode minor-mode-alist
)
1712 (setq minor-mode-alist
1713 (cons '(allout-mode " Allout") minor-mode-alist
)))
1715 (allout-setup-menubar)
1720 (run-hooks 'allout-mode-hook
)
1721 (setq allout-mode t
))
1725 (allout-infer-body-reindent))
1726 ) ;; end of activation-mode cases.
1728 ;; Do auto layout if warranted:
1729 (let ((use-layout (if (listp allout-layout
)
1731 allout-default-layout
)))
1733 allout-auto-activation
1735 (and (not (eq allout-auto-activation
'activate
))
1736 (if (eq allout-auto-activation
'ask
)
1737 (if (y-or-n-p (format "Expose %s with layout '%s'? "
1741 (message "Skipped %s layout." (buffer-name))
1745 (message "Adjusting '%s' exposure..." (buffer-name))
1747 (allout-this-or-next-heading)
1750 (apply 'allout-expose-topic
(list use-layout
))
1751 (message "Adjusting '%s' exposure... done." (buffer-name)))
1752 ;; Problem applying exposure - notify user, but don't
1753 ;; interrupt, eg, file visit:
1754 (error (message "%s" (car (cdr err
)))
1759 ;;;_ > allout-minor-mode
1760 (defalias 'allout-minor-mode
'allout-mode
)
1762 ;;;_ - Position Assessment
1763 ;;;_ > allout-hidden-p (&optional pos)
1764 (defsubst allout-hidden-p
(&optional pos
)
1765 "Non-nil if the character after point is invisible."
1766 (eq (get-char-property (or pos
(point)) 'invisible
) 'allout
))
1768 ;;;_ > allout-overlay-insert-in-front-handler (ol after beg end
1769 ;;; &optional prelen)
1770 (defun allout-overlay-insert-in-front-handler (ol after beg end
1772 "Shift the overlay so stuff inserted in front of it are excluded."
1774 (move-overlay ol
(1+ beg
) (overlay-end ol
))))
1775 ;;;_ > allout-overlay-interior-modification-handler (ol after beg end
1776 ;;; &optional prelen)
1777 (defun allout-overlay-interior-modification-handler (ol after beg end
1779 "Get confirmation before making arbitrary changes to invisible text.
1781 We expose the invisible text and ask for confirmation. Refusal or
1782 keyboard-quit abandons the changes, with keyboard-quit additionally
1783 reclosing the opened text.
1785 No confirmation is necessary when inhibit-read-only is set - eg, allout
1786 internal functions use this feature cohesively bunch changes."
1788 (when (and (not inhibit-read-only
) (not after
))
1789 (let ((start (point))
1790 (ol-start (overlay-start ol
))
1791 (ol-end (overlay-end ol
))
1794 (while (< (point) end
)
1795 (when (allout-hidden-p)
1796 (allout-show-to-offshoot)
1797 (if (allout-hidden-p)
1798 (save-excursion (forward-char 1)
1799 (allout-show-to-offshoot)))
1801 (setq first
(point))))
1802 (goto-char (if (featurep 'xemacs
)
1803 (next-property-change (1+ (point)) nil end
)
1804 (next-char-property-change (1+ (point)) end
))))
1810 (substitute-command-keys
1811 (concat "Modify concealed text? (\"no\" just aborts,"
1812 " \\[keyboard-quit] also reconceals) "))))
1813 (progn (goto-char start
)
1814 (error "Concealed-text change refused.")))
1815 (quit (allout-flag-region ol-start ol-end nil
)
1816 (allout-flag-region ol-start ol-end t
)
1817 (error "Concealed-text change abandoned, text reconcealed."))))
1818 (goto-char start
))))
1819 ;;;_ > allout-before-change-handler (beg end)
1820 (defun allout-before-change-handler (beg end
)
1821 "Protect against changes to invisible text.
1823 See allout-overlay-interior-modification-handler for details.
1825 This before-change handler is used only where modification-hooks
1826 overlay property is not supported."
1827 ;; allout-overlay-interior-modification-handler on an overlay handles
1828 ;; this in other emacs, via `allout-exposure-category's 'modification-hooks.
1829 (when (and (featurep 'xemacs
) (allout-mode-p))
1830 ;; process all of the pending overlays:
1831 (dolist (overlay (overlays-in beg end
))
1832 (if (eq (overlay-get ol
'invisible
) 'allout
)
1833 (allout-overlay-interior-modification-handler
1834 overlay nil beg end nil
)))))
1835 ;;;_ > allout-isearch-end-handler (&optional overlay)
1836 (defun allout-isearch-end-handler (&optional overlay
)
1837 "Reconcile allout outline exposure on arriving in hidden text after isearch.
1839 Optional OVERLAY parameter is for when this function is used by
1840 `isearch-open-invisible' overlay property. It is otherwise unused, so this
1841 function can also be used as an `isearch-mode-end-hook'."
1843 (if (and (allout-mode-p) (allout-hidden-p))
1844 (allout-show-to-offshoot)))
1846 ;;;_ #3 Internal Position State-Tracking - "allout-recent-*" funcs
1847 ;;; All the basic outline functions that directly do string matches to
1848 ;;; evaluate heading prefix location set the variables
1849 ;;; `allout-recent-prefix-beginning' and `allout-recent-prefix-end'
1850 ;;; when successful. Functions starting with `allout-recent-' all
1851 ;;; use this state, providing the means to avoid redundant searches
1852 ;;; for just-established data. This optimization can provide
1853 ;;; significant speed improvement, but it must be employed carefully.
1854 ;;;_ = allout-recent-prefix-beginning
1855 (defvar allout-recent-prefix-beginning
0
1856 "Buffer point of the start of the last topic prefix encountered.")
1857 (make-variable-buffer-local 'allout-recent-prefix-beginning
)
1858 ;;;_ = allout-recent-prefix-end
1859 (defvar allout-recent-prefix-end
0
1860 "Buffer point of the end of the last topic prefix encountered.")
1861 (make-variable-buffer-local 'allout-recent-prefix-end
)
1862 ;;;_ = allout-recent-end-of-subtree
1863 (defvar allout-recent-end-of-subtree
0
1864 "Buffer point last returned by `allout-end-of-current-subtree'.")
1865 (make-variable-buffer-local 'allout-recent-end-of-subtree
)
1866 ;;;_ > allout-prefix-data (beg end)
1867 (defmacro allout-prefix-data
(beg end
)
1868 "Register allout-prefix state data - BEGINNING and END of prefix.
1870 For reference by `allout-recent' funcs. Returns BEGINNING."
1871 `(setq allout-recent-prefix-end
,end
1872 allout-recent-prefix-beginning
,beg
))
1873 ;;;_ > allout-recent-depth ()
1874 (defmacro allout-recent-depth
()
1875 "Return depth of last heading encountered by an outline maneuvering function.
1877 All outline functions which directly do string matches to assess
1878 headings set the variables `allout-recent-prefix-beginning' and
1879 `allout-recent-prefix-end' if successful. This function uses those settings
1880 to return the current depth."
1882 '(max 1 (- allout-recent-prefix-end
1883 allout-recent-prefix-beginning
1884 allout-header-subtraction
)))
1885 ;;;_ > allout-recent-prefix ()
1886 (defmacro allout-recent-prefix
()
1887 "Like `allout-recent-depth', but returns text of last encountered prefix.
1889 All outline functions which directly do string matches to assess
1890 headings set the variables `allout-recent-prefix-beginning' and
1891 `allout-recent-prefix-end' if successful. This function uses those settings
1892 to return the current depth."
1893 '(buffer-substring allout-recent-prefix-beginning
1894 allout-recent-prefix-end
))
1895 ;;;_ > allout-recent-bullet ()
1896 (defmacro allout-recent-bullet
()
1897 "Like allout-recent-prefix, but returns bullet of last encountered prefix.
1899 All outline functions which directly do string matches to assess
1900 headings set the variables `allout-recent-prefix-beginning' and
1901 `allout-recent-prefix-end' if successful. This function uses those settings
1902 to return the current depth of the most recently matched topic."
1903 '(buffer-substring (1- allout-recent-prefix-end
)
1904 allout-recent-prefix-end
))
1908 ;;;_ - Position Assessment
1909 ;;;_ : Location Predicates
1910 ;;;_ > allout-on-current-heading-p ()
1911 (defun allout-on-current-heading-p ()
1912 "Return non-nil if point is on current visible topics' header line.
1914 Actually, returns prefix beginning point."
1916 (allout-beginning-of-current-line)
1917 (and (looking-at allout-regexp
)
1918 (allout-prefix-data (match-beginning 0) (match-end 0)))))
1919 ;;;_ > allout-on-heading-p ()
1920 (defalias 'allout-on-heading-p
'allout-on-current-heading-p
)
1921 ;;;_ > allout-e-o-prefix-p ()
1922 (defun allout-e-o-prefix-p ()
1923 "True if point is located where current topic prefix ends, heading begins."
1924 (and (save-excursion (let ((inhibit-field-text-motion t
))
1925 (beginning-of-line))
1926 (looking-at allout-regexp
))
1927 (= (point)(save-excursion (allout-end-of-prefix)(point)))))
1928 ;;;_ : Location attributes
1929 ;;;_ > allout-depth ()
1930 (defun allout-depth ()
1931 "Return depth of topic most immediately containing point.
1933 Return zero if point is not within any topic.
1935 Like `allout-current-depth', but respects hidden as well as visible topics."
1937 (let ((start-point (point)))
1938 (if (and (allout-goto-prefix)
1939 (not (< start-point
(point))))
1940 (allout-recent-depth)
1942 ;; Oops, no prefix, zero prefix data:
1943 (allout-prefix-data (point)(point))
1944 ;; ... and return 0:
1946 ;;;_ > allout-current-depth ()
1947 (defun allout-current-depth ()
1948 "Return depth of visible topic most immediately containing point.
1950 Return zero if point is not within any topic."
1952 (if (allout-back-to-current-heading)
1954 (- allout-recent-prefix-end
1955 allout-recent-prefix-beginning
1956 allout-header-subtraction
))
1958 ;;;_ > allout-get-current-prefix ()
1959 (defun allout-get-current-prefix ()
1960 "Topic prefix of the current topic."
1962 (if (allout-goto-prefix)
1963 (allout-recent-prefix))))
1964 ;;;_ > allout-get-bullet ()
1965 (defun allout-get-bullet ()
1966 "Return bullet of containing topic (visible or not)."
1968 (and (allout-goto-prefix)
1969 (allout-recent-bullet))))
1970 ;;;_ > allout-current-bullet ()
1971 (defun allout-current-bullet ()
1972 "Return bullet of current (visible) topic heading, or none if none found."
1975 (allout-back-to-current-heading)
1976 (buffer-substring (- allout-recent-prefix-end
1)
1977 allout-recent-prefix-end
))
1978 ;; Quick and dirty provision, ostensibly for missing bullet:
1979 ('args-out-of-range nil
))
1981 ;;;_ > allout-get-prefix-bullet (prefix)
1982 (defun allout-get-prefix-bullet (prefix)
1983 "Return the bullet of the header prefix string PREFIX."
1984 ;; Doesn't make sense if we're old-style prefixes, but this just
1985 ;; oughtn't be called then, so forget about it...
1986 (if (string-match allout-regexp prefix
)
1987 (substring prefix
(1- (match-end 0)) (match-end 0))))
1988 ;;;_ > allout-sibling-index (&optional depth)
1989 (defun allout-sibling-index (&optional depth
)
1990 "Item number of this prospective topic among its siblings.
1992 If optional arg DEPTH is greater than current depth, then we're
1993 opening a new level, and return 0.
1995 If less than this depth, ascend to that depth and count..."
1998 (cond ((and depth
(<= depth
0) 0))
1999 ((or (not depth
) (= depth
(allout-depth)))
2001 (while (allout-previous-sibling (allout-recent-depth) nil
)
2002 (setq index
(1+ index
)))
2004 ((< depth
(allout-recent-depth))
2005 (allout-ascend-to-depth depth
)
2006 (allout-sibling-index))
2008 ;;;_ > allout-topic-flat-index ()
2009 (defun allout-topic-flat-index ()
2010 "Return a list indicating point's numeric section.subsect.subsubsect...
2011 Outermost is first."
2012 (let* ((depth (allout-depth))
2013 (next-index (allout-sibling-index depth
))
2015 (while (> next-index
0)
2016 (setq rev-sibls
(cons next-index rev-sibls
))
2017 (setq depth
(1- depth
))
2018 (setq next-index
(allout-sibling-index depth
)))
2022 ;;;_ - Navigation routines
2023 ;;;_ > allout-beginning-of-current-line ()
2024 (defun allout-beginning-of-current-line ()
2025 "Like beginning of line, but to visible text."
2027 ;; This combination of move-beginning-of-line and beginning-of-line is
2028 ;; deliberate, but the (beginning-of-line) may now be superfluous.
2029 (let ((inhibit-field-text-motion t
))
2030 (move-beginning-of-line 1)
2032 (while (and (not (bobp)) (or (not (bolp)) (allout-hidden-p)))
2034 (if (or (allout-hidden-p) (not (bolp)))
2035 (forward-char -
1)))))
2036 ;;;_ > allout-end-of-current-line ()
2037 (defun allout-end-of-current-line ()
2038 "Move to the end of line, past concealed text if any."
2039 ;; XXX This is for symmetry with `allout-beginning-of-current-line' -
2040 ;; `move-end-of-line' doesn't suffer the same problem as
2041 ;; `move-beginning-of-line'.
2042 (let ((inhibit-field-text-motion t
))
2044 (while (allout-hidden-p)
2046 (if (allout-hidden-p) (forward-char 1)))))
2047 ;;;_ > allout-next-heading ()
2048 (defsubst allout-next-heading
()
2049 "Move to the heading for the topic \(possibly invisible) after this one.
2051 Returns the location of the heading, or nil if none found."
2053 (if (and (bobp) (not (eobp)) (looking-at allout-regexp
))
2056 (if (re-search-forward allout-line-boundary-regexp nil
0)
2057 (allout-prefix-data ; Got valid location state - set vars:
2058 (goto-char (or (match-beginning 2)
2059 allout-recent-prefix-beginning
))
2060 (or (match-end 2) allout-recent-prefix-end
))))
2061 ;;;_ > allout-this-or-next-heading
2062 (defun allout-this-or-next-heading ()
2063 "Position cursor on current or next heading."
2064 ;; A throwaway non-macro that is defined after allout-next-heading
2065 ;; and usable by allout-mode.
2066 (if (not (allout-goto-prefix)) (allout-next-heading)))
2067 ;;;_ > allout-previous-heading ()
2068 (defmacro allout-previous-heading
()
2069 "Move to the prior \(possibly invisible) heading line.
2071 Return the location of the beginning of the heading, or nil if not found."
2075 (allout-goto-prefix)
2077 ;; searches are unbounded and return nil if failed:
2078 (or (re-search-backward allout-line-boundary-regexp nil
0)
2079 (looking-at allout-bob-regexp
))
2080 (progn ; Got valid location state - set vars:
2082 (goto-char (or (match-beginning 2)
2083 allout-recent-prefix-beginning
))
2084 (or (match-end 2) allout-recent-prefix-end
))))))
2085 ;;;_ > allout-get-invisibility-overlay ()
2086 (defun allout-get-invisibility-overlay ()
2087 "Return the overlay at point that dictates allout invisibility."
2088 (let ((overlays (overlays-at (point)))
2090 (while (and overlays
(not got
))
2091 (if (equal (overlay-get (car overlays
) 'invisible
) 'allout
)
2092 (setq got
(car overlays
))))
2094 ;;;_ > allout-back-to-visible-text ()
2095 (defun allout-back-to-visible-text ()
2096 "Move to most recent prior character that is visible, and return point."
2097 (if (allout-hidden-p)
2098 (goto-char (overlay-start (allout-get-invisibility-overlay))))
2101 ;;;_ - Subtree Charting
2102 ;;;_ " These routines either produce or assess charts, which are
2103 ;;; nested lists of the locations of topics within a subtree.
2105 ;;; Use of charts enables efficient navigation of subtrees, by
2106 ;;; requiring only a single regexp-search based traversal, to scope
2107 ;;; out the subtopic locations. The chart then serves as the basis
2108 ;;; for assessment or adjustment of the subtree, without redundant
2109 ;;; traversal of the structure.
2111 ;;;_ > allout-chart-subtree (&optional levels orig-depth prev-depth)
2112 (defun allout-chart-subtree (&optional levels orig-depth prev-depth
)
2113 "Produce a location \"chart\" of subtopics of the containing topic.
2115 Optional argument LEVELS specifies the depth \(relative to start
2116 depth) for the chart. Subsequent optional args are not for public
2119 Point is left at the end of the subtree.
2121 Charts are used to capture outline structure, so that outline-altering
2122 routines need assess the structure only once, and then use the chart
2123 for their elaborate manipulations.
2125 Topics are entered in the chart so the last one is at the car.
2126 The entry for each topic consists of an integer indicating the point
2127 at the beginning of the topic. Charts for offspring consists of a
2128 list containing, recursively, the charts for the respective subtopics.
2129 The chart for a topics' offspring precedes the entry for the topic
2132 The other function parameters are for internal recursion, and should
2133 not be specified by external callers. ORIG-DEPTH is depth of topic at
2134 starting point, and PREV-DEPTH is depth of prior topic."
2136 (let ((original (not orig-depth
)) ; `orig-depth' set only in recursion.
2139 (if original
; Just starting?
2140 ; Register initial settings and
2141 ; position to first offspring:
2142 (progn (setq orig-depth
(allout-depth))
2143 (or prev-depth
(setq prev-depth
(1+ orig-depth
)))
2144 (allout-next-heading)))
2146 ;; Loop over the current levels' siblings. Besides being more
2147 ;; efficient than tail-recursing over a level, it avoids exceeding
2148 ;; the typically quite constrained Emacs max-lisp-eval-depth.
2150 ;; Probably would speed things up to implement loop-based stack
2151 ;; operation rather than recursing for lower levels. Bah.
2153 (while (and (not (eobp))
2154 ; Still within original topic?
2155 (< orig-depth
(setq curr-depth
(allout-recent-depth)))
2156 (cond ((= prev-depth curr-depth
)
2157 ;; Register this one and move on:
2158 (setq chart
(cons (point) chart
))
2159 (if (and levels
(<= levels
1))
2160 ;; At depth limit - skip sublevels:
2161 (or (allout-next-sibling curr-depth
)
2162 ;; or no more siblings - proceed to
2163 ;; next heading at lesser depth:
2164 (while (and (<= curr-depth
2165 (allout-recent-depth))
2166 (allout-next-heading))))
2167 (allout-next-heading)))
2169 ((and (< prev-depth curr-depth
)
2172 ;; Recurse on deeper level of curr topic:
2174 (cons (allout-chart-subtree (and levels
2179 ;; ... then continue with this one.
2182 ;; ... else nil if we've ascended back to prev-depth.
2186 (if original
; We're at the last sibling on
2187 ; the original level. Position
2189 (progn (and (not (eobp)) (forward-char -
1))
2190 (and (= (preceding-char) ?
\n)
2191 (= (aref (buffer-substring (max 1 (- (point) 3))
2196 (setq allout-recent-end-of-subtree
(point))))
2198 chart
; (nreverse chart) not necessary,
2199 ; and maybe not preferable.
2201 ;;;_ > allout-chart-siblings (&optional start end)
2202 (defun allout-chart-siblings (&optional start end
)
2203 "Produce a list of locations of this and succeeding sibling topics.
2204 Effectively a top-level chart of siblings. See `allout-chart-subtree'
2205 for an explanation of charts."
2207 (if (allout-goto-prefix)
2208 (let ((chart (list (point))))
2209 (while (allout-next-sibling)
2210 (setq chart
(cons (point) chart
)))
2211 (if chart
(setq chart
(nreverse chart
)))))))
2212 ;;;_ > allout-chart-to-reveal (chart depth)
2213 (defun allout-chart-to-reveal (chart depth
)
2215 "Return a flat list of hidden points in subtree CHART, up to DEPTH.
2217 Note that point can be left at any of the points on chart, or at the
2221 (while (and (or (eq depth t
) (> depth
0))
2223 (setq here
(car chart
))
2225 (let ((further (allout-chart-to-reveal here
(or (eq depth t
)
2227 ;; We're on the start of a subtree - recurse with it, if there's
2228 ;; more depth to go:
2229 (if further
(setq result
(append further result
)))
2230 (setq chart
(cdr chart
)))
2232 (if (allout-hidden-p)
2233 (setq result
(cons here result
)))
2234 (setq chart
(cdr chart
))))
2236 ;;;_ X allout-chart-spec (chart spec &optional exposing)
2237 ;; (defun allout-chart-spec (chart spec &optional exposing)
2238 ;; "Not yet \(if ever) implemented.
2240 ;; Produce exposure directives given topic/subtree CHART and an exposure SPEC.
2242 ;; Exposure spec indicates the locations to be exposed and the prescribed
2243 ;; exposure status. Optional arg EXPOSING is an integer, with 0
2244 ;; indicating pending concealment, anything higher indicating depth to
2245 ;; which subtopic headers should be exposed, and negative numbers
2246 ;; indicating (negative of) the depth to which subtopic headers and
2247 ;; bodies should be exposed.
2249 ;; The produced list can have two types of entries. Bare numbers
2250 ;; indicate points in the buffer where topic headers that should be
2253 ;; - bare negative numbers indicates that the topic starting at the
2254 ;; point which is the negative of the number should be opened,
2255 ;; including their entries.
2256 ;; - bare positive values indicate that this topic header should be
2258 ;; - Lists signify the beginning and end points of regions that should
2259 ;; be flagged, and the flag to employ. (For concealment: `\(\?r\)', and
2262 ;; (cond ((listp spec)
2265 ;; (setq spec (cdr spec)))
2269 ;;;_ > allout-goto-prefix ()
2270 (defun allout-goto-prefix ()
2271 "Put point at beginning of immediately containing outline topic.
2273 Goes to most immediate subsequent topic if none immediately containing.
2275 Not sensitive to topic visibility.
2277 Returns the point at the beginning of the prefix, or nil if none."
2280 (while (and (not done
)
2281 (search-backward "\n" nil
1))
2283 (if (looking-at allout-regexp
)
2284 (setq done
(allout-prefix-data (match-beginning 0)
2288 (cond ((looking-at allout-regexp
)
2289 (allout-prefix-data (match-beginning 0)(match-end 0)))
2290 ((allout-next-heading))
2293 ;;;_ > allout-end-of-prefix ()
2294 (defun allout-end-of-prefix (&optional ignore-decorations
)
2295 "Position cursor at beginning of header text.
2297 If optional IGNORE-DECORATIONS is non-nil, put just after bullet,
2298 otherwise skip white space between bullet and ensuing text."
2300 (if (not (allout-goto-prefix))
2302 (let ((match-data (match-data)))
2303 (goto-char (match-end 0))
2304 (if ignore-decorations
2306 (while (looking-at "[0-9]") (forward-char 1))
2307 (if (and (not (eolp)) (looking-at "\\s-")) (forward-char 1)))
2308 (store-match-data match-data
))
2309 ;; Reestablish where we are:
2310 (allout-current-depth)))
2311 ;;;_ > allout-current-bullet-pos ()
2312 (defun allout-current-bullet-pos ()
2313 "Return position of current \(visible) topic's bullet."
2315 (if (not (allout-current-depth))
2317 (1- (match-end 0))))
2318 ;;;_ > allout-back-to-current-heading ()
2319 (defun allout-back-to-current-heading ()
2320 "Move to heading line of current topic, or beginning if already on the line.
2322 Return value of point, unless we started outside of (before any) topics,
2323 in which case we return nil."
2325 (allout-beginning-of-current-line)
2326 (if (or (allout-on-current-heading-p)
2327 (and (re-search-backward (concat "^\\(" allout-regexp
"\\)")
2329 (progn (while (allout-hidden-p)
2330 (allout-beginning-of-current-line)
2331 (if (not (looking-at allout-regexp
))
2332 (re-search-backward (concat
2333 "^\\(" allout-regexp
"\\)")
2335 (allout-prefix-data (match-beginning 1)
2338 (allout-end-of-prefix)
2340 ;;;_ > allout-back-to-heading ()
2341 (defalias 'allout-back-to-heading
'allout-back-to-current-heading
)
2342 ;;;_ > allout-pre-next-prefix ()
2343 (defun allout-pre-next-prefix ()
2344 "Skip forward to just before the next heading line.
2346 Returns that character position."
2348 (if (re-search-forward allout-line-boundary-regexp nil
'move
)
2349 (prog1 (goto-char (match-beginning 0))
2350 (allout-prefix-data (match-beginning 2)(match-end 2)))))
2351 ;;;_ > allout-end-of-subtree (&optional current include-trailing-blank)
2352 (defun allout-end-of-subtree (&optional current include-trailing-blank
)
2353 "Put point at the end of the last leaf in the containing topic.
2355 Optional CURRENT means put point at the end of the containing
2358 Optional INCLUDE-TRAILING-BLANK means include a trailing blank line, if
2359 any, as part of the subtree. Otherwise, that trailing blank will be
2360 excluded as delimiting whitespace between topics.
2362 Returns the value of point."
2365 (allout-back-to-current-heading)
2366 (allout-goto-prefix))
2367 (let ((level (allout-recent-depth)))
2368 (allout-next-heading)
2369 (while (and (not (eobp))
2370 (> (allout-recent-depth) level
))
2371 (allout-next-heading))
2372 (and (not (eobp)) (forward-char -
1))
2373 (if (and (not include-trailing-blank
) (= ?
\n (preceding-char)))
2375 (setq allout-recent-end-of-subtree
(point))))
2376 ;;;_ > allout-end-of-current-subtree (&optional include-trailing-blank)
2377 (defun allout-end-of-current-subtree (&optional include-trailing-blank
)
2379 "Put point at end of last leaf in currently visible containing topic.
2381 Optional INCLUDE-TRAILING-BLANK means include a trailing blank line, if
2382 any, as part of the subtree. Otherwise, that trailing blank will be
2383 excluded as delimiting whitespace between topics.
2385 Returns the value of point."
2387 (allout-end-of-subtree t include-trailing-blank
))
2388 ;;;_ > allout-beginning-of-current-entry ()
2389 (defun allout-beginning-of-current-entry ()
2390 "When not already there, position point at beginning of current topic header.
2392 If already there, move cursor to bullet for hot-spot operation.
2393 \(See `allout-mode' doc string for details of hot-spot operation.)"
2395 (let ((start-point (point)))
2396 (move-beginning-of-line 1)
2397 (allout-end-of-prefix)
2398 (if (and (interactive-p)
2399 (= (point) start-point
))
2400 (goto-char (allout-current-bullet-pos)))))
2401 ;;;_ > allout-end-of-entry (&optional inclusive)
2402 (defun allout-end-of-entry (&optional inclusive
)
2403 "Position the point at the end of the current topics' entry.
2405 Optional INCLUSIVE means also include trailing empty line, if any. When
2406 unset, whitespace between items separates them even when the items are
2409 (allout-pre-next-prefix)
2410 (if (and (not inclusive
) (not (bobp)) (= ?
\n (preceding-char)))
2413 ;;;_ > allout-end-of-current-heading ()
2414 (defun allout-end-of-current-heading ()
2416 (allout-beginning-of-current-entry)
2417 (search-forward "\n" nil t
)
2419 (defalias 'allout-end-of-heading
'allout-end-of-current-heading
)
2420 ;;;_ > allout-get-body-text ()
2421 (defun allout-get-body-text ()
2422 "Return the unmangled body text of the topic immediately containing point."
2424 (allout-end-of-prefix)
2425 (if (not (search-forward "\n" nil t
))
2428 (let ((pre-body (point)))
2431 (allout-end-of-entry t
)
2432 (if (not (= pre-body
(point)))
2433 (buffer-substring-no-properties (1+ pre-body
) (point))))
2440 ;;;_ > allout-ascend-to-depth (depth)
2441 (defun allout-ascend-to-depth (depth)
2442 "Ascend to depth DEPTH, returning depth if successful, nil if not."
2443 (if (and (> depth
0)(<= depth
(allout-depth)))
2444 (let ((last-good (point)))
2445 (while (and (< depth
(allout-depth))
2446 (setq last-good
(point))
2447 (allout-beginning-of-level)
2448 (allout-previous-heading)))
2449 (if (= (allout-recent-depth) depth
)
2450 (progn (goto-char allout-recent-prefix-beginning
)
2452 (goto-char last-good
)
2454 (if (interactive-p) (allout-end-of-prefix))))
2455 ;;;_ > allout-ascend ()
2456 (defun allout-ascend ()
2457 "Ascend one level, returning t if successful, nil if not."
2459 (if (allout-beginning-of-level)
2460 (allout-previous-heading))
2461 (if (interactive-p) (allout-end-of-prefix))))
2462 ;;;_ > allout-descend-to-depth (depth)
2463 (defun allout-descend-to-depth (depth)
2464 "Descend to depth DEPTH within current topic.
2466 Returning depth if successful, nil if not."
2467 (let ((start-point (point))
2468 (start-depth (allout-depth)))
2470 (and (> (allout-depth) 0)
2471 (not (= depth
(allout-recent-depth))) ; ... not there yet
2472 (allout-next-heading) ; ... go further
2473 (< start-depth
(allout-recent-depth)))) ; ... still in topic
2474 (if (and (> (allout-depth) 0)
2475 (= (allout-recent-depth) depth
))
2477 (goto-char start-point
)
2480 ;;;_ > allout-up-current-level (arg &optional dont-complain)
2481 (defun allout-up-current-level (arg &optional dont-complain
)
2482 "Move out ARG levels from current visible topic.
2484 Positions on heading line of containing topic. Error if unable to
2485 ascend that far, or nil if unable to ascend but optional arg
2486 DONT-COMPLAIN is non-nil."
2488 (allout-back-to-current-heading)
2489 (let ((present-level (allout-recent-depth))
2492 ;; Loop for iterating arg:
2493 (while (and (> (allout-recent-depth) 1)
2497 (setq last-good
(point))
2498 ;; Loop for going back over current or greater depth:
2499 (while (and (not (< (allout-recent-depth) present-level
))
2500 (or (allout-previous-visible-heading 1)
2501 (not (setq failed present-level
)))))
2502 (setq present-level
(allout-current-depth))
2503 (setq arg
(- arg
1)))
2506 (progn (goto-char last-good
)
2507 (if (interactive-p) (allout-end-of-prefix))
2508 (if (not dont-complain
)
2509 (error "Can't ascend past outermost level")
2510 (if (interactive-p) (allout-end-of-prefix))
2512 (if (interactive-p) (allout-end-of-prefix))
2513 allout-recent-prefix-beginning
)))
2516 ;;;_ > allout-next-sibling (&optional depth backward)
2517 (defun allout-next-sibling (&optional depth backward
)
2518 "Like `allout-forward-current-level', but respects invisible topics.
2520 Traverse at optional DEPTH, or current depth if none specified.
2522 Go backward if optional arg BACKWARD is non-nil.
2524 Return depth if successful, nil otherwise."
2526 (if (and backward
(bobp))
2528 (let ((start-depth (or depth
(allout-depth)))
2529 (start-point (point))
2531 (while (and (not (if backward
(bobp) (eobp)))
2532 (if backward
(allout-previous-heading)
2533 (allout-next-heading))
2534 (> (setq last-depth
(allout-recent-depth)) start-depth
)))
2535 (if (and (not (eobp))
2536 (and (> (or last-depth
(allout-depth)) 0)
2537 (= (allout-recent-depth) start-depth
)))
2538 allout-recent-prefix-beginning
2539 (goto-char start-point
)
2540 (if depth
(allout-depth) start-depth
)
2542 ;;;_ > allout-previous-sibling (&optional depth backward)
2543 (defun allout-previous-sibling (&optional depth backward
)
2544 "Like `allout-forward-current-level' backwards, respecting invisible topics.
2546 Optional DEPTH specifies depth to traverse, default current depth.
2548 Optional BACKWARD reverses direction.
2550 Return depth if successful, nil otherwise."
2551 (allout-next-sibling depth
(not backward
))
2553 ;;;_ > allout-snug-back ()
2554 (defun allout-snug-back ()
2555 "Position cursor at end of previous topic.
2557 Presumes point is at the start of a topic prefix."
2558 (if (or (bobp) (eobp))
2561 (if (or (bobp) (not (= ?
\n (preceding-char))))
2565 ;;;_ > allout-beginning-of-level ()
2566 (defun allout-beginning-of-level ()
2567 "Go back to the first sibling at this level, visible or not."
2568 (allout-end-of-level 'backward
))
2569 ;;;_ > allout-end-of-level (&optional backward)
2570 (defun allout-end-of-level (&optional backward
)
2571 "Go to the last sibling at this level, visible or not."
2573 (let ((depth (allout-depth)))
2574 (while (allout-previous-sibling depth nil
))
2575 (prog1 (allout-recent-depth)
2576 (if (interactive-p) (allout-end-of-prefix)))))
2577 ;;;_ > allout-next-visible-heading (arg)
2578 (defun allout-next-visible-heading (arg)
2579 "Move to the next ARG'th visible heading line, backward if arg is negative.
2581 Move to buffer limit in indicated direction if headings are exhausted."
2584 (let* ((inhibit-field-text-motion t
)
2585 (backward (if (< arg
0) (setq arg
(* -
1 arg
))))
2586 (step (if backward -
1 1))
2589 (while (> arg
0) ; limit condition
2590 (while (and (not (if backward
(bobp)(eobp))) ; boundary condition
2591 ;; Move, skipping over all those concealed lines:
2592 (prog1 (condition-case nil
(or (line-move step
) t
)
2594 (allout-beginning-of-current-line))
2595 (not (setq got
(looking-at allout-regexp
)))))
2596 ;; Register this got, it may be the last:
2597 (if got
(setq prev got
))
2598 (setq arg
(1- arg
)))
2599 (cond (got ; Last move was to a prefix:
2600 (allout-prefix-data (match-beginning 0) (match-end 0))
2601 (allout-end-of-prefix))
2602 (prev ; Last move wasn't, but prev was:
2603 (allout-prefix-data (match-beginning 0) (match-end 0)))
2604 ((not backward
) (end-of-line) nil
))))
2605 ;;;_ > allout-previous-visible-heading (arg)
2606 (defun allout-previous-visible-heading (arg)
2607 "Move to the previous heading line.
2609 With argument, repeats or can move forward if negative.
2610 A heading line is one that starts with a `*' (or that `allout-regexp'
2613 (allout-next-visible-heading (- arg
)))
2614 ;;;_ > allout-forward-current-level (arg)
2615 (defun allout-forward-current-level (arg)
2616 "Position point at the next heading of the same level.
2618 Takes optional repeat-count, goes backward if count is negative.
2620 Returns resulting position, else nil if none found."
2622 (let ((start-depth (allout-current-depth))
2624 (backward (> 0 arg
))
2628 (if (= 0 start-depth
)
2629 (error "No siblings, not in a topic..."))
2630 (if backward
(setq arg
(* -
1 arg
)))
2631 (while (not (or (zerop arg
)
2633 (while (and (not (if backward
(bobp) (eobp)))
2634 (if backward
(allout-previous-visible-heading 1)
2635 (allout-next-visible-heading 1))
2636 (> (setq last-depth
(allout-recent-depth)) start-depth
)))
2637 (if (and last-depth
(= last-depth start-depth
)
2638 (not (if backward
(bobp) (eobp))))
2639 (setq last-good
(point)
2641 (setq at-boundary t
)))
2642 (if (and (not (eobp))
2644 (and (> (or last-depth
(allout-depth)) 0)
2645 (= (allout-recent-depth) start-depth
)))
2646 allout-recent-prefix-beginning
2647 (goto-char last-good
)
2648 (if (not (interactive-p))
2650 (allout-end-of-prefix)
2651 (error "Hit %s level %d topic, traversed %d of %d requested"
2652 (if backward
"first" "last")
2653 (allout-recent-depth)
2654 (- (abs start-arg
) arg
)
2655 (abs start-arg
))))))
2656 ;;;_ > allout-backward-current-level (arg)
2657 (defun allout-backward-current-level (arg)
2658 "Inverse of `allout-forward-current-level'."
2661 (let ((current-prefix-arg (* -
1 arg
)))
2662 (call-interactively 'allout-forward-current-level
))
2663 (allout-forward-current-level (* -
1 arg
))))
2668 ;;;_ = allout-post-goto-bullet
2669 (defvar allout-post-goto-bullet nil
2670 "Outline internal var, for `allout-pre-command-business' hot-spot operation.
2672 When set, tells post-processing to reposition on topic bullet, and
2673 then unset it. Set by `allout-pre-command-business' when implementing
2674 hot-spot operation, where literal characters typed over a topic bullet
2675 are mapped to the command of the corresponding control-key on the
2676 `allout-mode-map'.")
2677 (make-variable-buffer-local 'allout-post-goto-bullet
)
2678 ;;;_ > allout-post-command-business ()
2679 (defun allout-post-command-business ()
2680 "Outline `post-command-hook' function.
2682 - Implement (and clear) `allout-post-goto-bullet', for hot-spot
2685 - Decrypt topic currently being edited if it was encrypted for a save."
2687 ; Apply any external change func:
2688 (if (not (allout-mode-p)) ; In allout-mode.
2691 (if (and (boundp 'allout-after-save-decrypt
)
2692 allout-after-save-decrypt
)
2693 (allout-after-saves-handler))
2695 ;; Implement -post-goto-bullet, if set:
2696 (if (and allout-post-goto-bullet
2697 (allout-current-bullet-pos))
2698 (progn (goto-char (allout-current-bullet-pos))
2699 (setq allout-post-goto-bullet nil
)))
2701 ;;;_ > allout-pre-command-business ()
2702 (defun allout-pre-command-business ()
2703 "Outline `pre-command-hook' function for outline buffers.
2704 Implements special behavior when cursor is on bullet character.
2706 When the cursor is on the bullet character, self-insert characters are
2707 reinterpreted as the corresponding control-character in the
2708 `allout-mode-map'. The `allout-mode' `post-command-hook' insures that
2709 the cursor which has moved as a result of such reinterpretation is
2710 positioned on the bullet character of the destination topic.
2712 The upshot is that you can get easy, single (ie, unmodified) key
2713 outline maneuvering operations by positioning the cursor on the bullet
2714 char. When in this mode you can use regular cursor-positioning
2715 command/keystrokes to relocate the cursor off of a bullet character to
2716 return to regular interpretation of self-insert characters."
2718 (if (not (allout-mode-p))
2720 (if (and (eq this-command
'self-insert-command
)
2721 (eq (point)(allout-current-bullet-pos)))
2722 (allout-hotspot-key-handler))))
2723 ;;;_ > allout-hotspot-key-handler ()
2724 (defun allout-hotspot-key-handler ()
2725 "Catchall handling of key bindings in hot-spots.
2727 Translates unmodified keystrokes to corresponding allout commands, when
2728 they would qualify if prefixed with the allout-command-prefix, and sets
2729 this-command accordingly.
2731 Returns the qualifying command, if any, else nil."
2733 (let* ((key-num (cond ((numberp last-command-char
) last-command-char
)
2734 ;; for XEmacs character type:
2735 ((and (fboundp 'characterp
)
2736 (apply 'characterp
(list last-command-char
)))
2737 (apply 'char-to-int
(list last-command-char
)))
2740 (on-bullet (eq (point) (allout-current-bullet-pos))))
2745 (if (and (<= 33 key-num
)
2746 (setq mapped-binding
2747 (key-binding (concat allout-command-prefix
2749 (if (and (<= 97 key-num
) ; "a"
2750 (>= 122 key-num
)) ; "z"
2751 (- key-num
96) key-num
)))
2753 ;; Qualified with the allout prefix - do hot-spot operation.
2754 (setq allout-post-goto-bullet t
)
2755 ;; accept-defaults nil, or else we'll get allout-item-icon-key-handler.
2756 (setq mapped-binding
(key-binding (char-to-string key-num
))))
2758 (while (keymapp mapped-binding
)
2759 (setq mapped-binding
2760 (lookup-key mapped-binding
(read-key-sequence-vector nil t
))))
2763 (setq this-command mapped-binding
)))))
2765 ;;;_ > allout-find-file-hook ()
2766 (defun allout-find-file-hook ()
2767 "Activate `allout-mode' on non-nil `allout-auto-activation', `allout-layout'.
2769 See `allout-init' for setup instructions."
2770 (if (and allout-auto-activation
2771 (not (allout-mode-p))
2775 ;;;_ - Topic Format Assessment
2776 ;;;_ > allout-solicit-alternate-bullet (depth &optional current-bullet)
2777 (defun allout-solicit-alternate-bullet (depth &optional current-bullet
)
2779 "Prompt for and return a bullet char as an alternative to the current one.
2781 Offer one suitable for current depth DEPTH as default."
2783 (let* ((default-bullet (or (and (stringp current-bullet
) current-bullet
)
2784 (allout-bullet-for-depth depth
)))
2785 (sans-escapes (regexp-sans-escapes allout-bullets-string
))
2788 (goto-char (allout-current-bullet-pos))
2789 (setq choice
(solicit-char-in-string
2790 (format "Select bullet: %s ('%s' default): "
2796 (if (string= choice
"") default-bullet choice
))
2798 ;;;_ > allout-distinctive-bullet (bullet)
2799 (defun allout-distinctive-bullet (bullet)
2800 "True if BULLET is one of those on `allout-distinctive-bullets-string'."
2801 (string-match (regexp-quote bullet
) allout-distinctive-bullets-string
))
2802 ;;;_ > allout-numbered-type-prefix (&optional prefix)
2803 (defun allout-numbered-type-prefix (&optional prefix
)
2804 "True if current header prefix bullet is numbered bullet."
2805 (and allout-numbered-bullet
2806 (string= allout-numbered-bullet
2808 (allout-get-prefix-bullet prefix
)
2809 (allout-get-bullet)))))
2810 ;;;_ > allout-encrypted-type-prefix (&optional prefix)
2811 (defun allout-encrypted-type-prefix (&optional prefix
)
2812 "True if current header prefix bullet is for an encrypted entry \(body)."
2813 (and allout-topic-encryption-bullet
2814 (string= allout-topic-encryption-bullet
2816 (allout-get-prefix-bullet prefix
)
2817 (allout-get-bullet)))))
2818 ;;;_ > allout-bullet-for-depth (&optional depth)
2819 (defun allout-bullet-for-depth (&optional depth
)
2820 "Return outline topic bullet suited to optional DEPTH, or current depth."
2821 ;; Find bullet in plain-bullets-string modulo DEPTH.
2822 (if allout-stylish-prefixes
2823 (char-to-string (aref allout-plain-bullets-string
2824 (%
(max 0 (- depth
2))
2825 allout-plain-bullets-string-len
)))
2826 allout-primary-bullet
)
2829 ;;;_ - Topic Production
2830 ;;;_ > allout-make-topic-prefix (&optional prior-bullet
2831 (defun allout-make-topic-prefix (&optional prior-bullet
2837 ;; Depth null means use current depth, non-null means we're either
2838 ;; opening a new topic after current topic, lower or higher, or we're
2839 ;; changing level of current topic.
2840 ;; Solicit dominates specified bullet-char.
2842 "Generate a topic prefix suitable for optional arg DEPTH, or current depth.
2844 All the arguments are optional.
2846 PRIOR-BULLET indicates the bullet of the prefix being changed, or
2847 nil if none. This bullet may be preserved (other options
2848 notwithstanding) if it is on the `allout-distinctive-bullets-string',
2851 Second arg NEW indicates that a new topic is being opened after the
2852 topic at point, if non-nil. Default bullet for new topics, eg, may
2853 be set (contingent to other args) to numbered bullets if previous
2854 sibling is one. The implication otherwise is that the current topic
2855 is being adjusted - shifted or rebulleted - and we don't consider
2856 bullet or previous sibling.
2858 Third arg DEPTH forces the topic prefix to that depth, regardless of
2859 the current topics' depth.
2861 If SOLICIT is non-nil, then the choice of bullet is solicited from
2862 user. If it's a character, then that character is offered as the
2863 default, otherwise the one suited to the context \(according to
2864 distinction or depth) is offered. \(This overrides other options,
2865 including, eg, a distinctive PRIOR-BULLET.) If non-nil, then the
2866 context-specific bullet is used.
2868 Fifth arg, NUMBER-CONTROL, matters only if `allout-numbered-bullet'
2869 is non-nil *and* soliciting was not explicitly invoked. Then
2870 NUMBER-CONTROL non-nil forces prefix to either numbered or
2871 denumbered format, depending on the value of the sixth arg, INDEX.
2873 \(Note that NUMBER-CONTROL does *not* apply to level 1 topics. Sorry...)
2875 If NUMBER-CONTROL is non-nil and sixth arg INDEX is non-nil then
2876 the prefix of the topic is forced to be numbered. Non-nil
2877 NUMBER-CONTROL and nil INDEX forces non-numbered format on the
2878 bullet. Non-nil NUMBER-CONTROL and non-nil, non-number INDEX means
2879 that the index for the numbered prefix will be derived, by counting
2880 siblings back to start of level. If INDEX is a number, then that
2881 number is used as the index for the numbered prefix (allowing, eg,
2882 sequential renumbering to not require this function counting back the
2883 index for each successive sibling)."
2885 ;; The options are ordered in likely frequence of use, most common
2886 ;; highest, least lowest. Ie, more likely to be doing prefix
2887 ;; adjustments than soliciting, and yet more than numbering.
2888 ;; Current prefix is least dominant, but most likely to be commonly
2894 (depth (or depth
(allout-depth)))
2895 (header-lead allout-header-prefix
)
2898 ;; Getting value for bullet char is practically the whole job:
2901 ; Simplest situation - level 1:
2902 ((<= depth
1) (setq header-lead
"") allout-primary-bullet
)
2903 ; Simple, too: all asterisks:
2904 (allout-old-style-prefixes
2905 ;; Cheat - make body the whole thing, null out header-lead and
2907 (setq body
(make-string depth
2908 (string-to-char allout-primary-bullet
)))
2909 (setq header-lead
"")
2912 ;; (Neither level 1 nor old-style, so we're space padding.
2913 ;; Sneak it in the condition of the next case, whatever it is.)
2915 ;; Solicitation overrides numbering and other cases:
2916 ((progn (setq body
(make-string (- depth
2) ?\
))
2917 ;; The actual condition:
2919 (let* ((got (allout-solicit-alternate-bullet depth solicit
)))
2920 ;; Gotta check whether we're numbering and got a numbered bullet:
2921 (setq numbering
(and allout-numbered-bullet
2922 (not (and number-control
(not index
)))
2923 (string= got allout-numbered-bullet
)))
2924 ;; Now return what we got, regardless:
2927 ;; Numbering invoked through args:
2928 ((and allout-numbered-bullet number-control
)
2929 (if (setq numbering
(not (setq denumbering
(not index
))))
2930 allout-numbered-bullet
2931 (if (and prior-bullet
2932 (not (string= allout-numbered-bullet
2935 (allout-bullet-for-depth depth
))))
2937 ;;; Neither soliciting nor controlled numbering ;;;
2938 ;;; (may be controlled denumbering, tho) ;;;
2940 ;; Check wrt previous sibling:
2941 ((and new
; only check for new prefixes
2942 (<= depth
(allout-depth))
2943 allout-numbered-bullet
; ... & numbering enabled
2945 (let ((sibling-bullet
2947 ;; Locate correct sibling:
2948 (or (>= depth
(allout-depth))
2949 (allout-ascend-to-depth depth
))
2950 (allout-get-bullet))))
2951 (if (and sibling-bullet
2952 (string= allout-numbered-bullet sibling-bullet
))
2953 (setq numbering sibling-bullet
)))))
2955 ;; Distinctive prior bullet?
2957 (allout-distinctive-bullet prior-bullet
)
2958 ;; Either non-numbered:
2959 (or (not (and allout-numbered-bullet
2960 (string= prior-bullet allout-numbered-bullet
)))
2961 ;; or numbered, and not denumbering:
2962 (setq numbering
(not denumbering
)))
2966 ;; Else, standard bullet per depth:
2967 ((allout-bullet-for-depth depth
)))))
2973 (format "%d" (cond ((and index
(numberp index
)) index
)
2974 (new (1+ (allout-sibling-index depth
)))
2975 ((allout-sibling-index))))))
2978 ;;;_ > allout-open-topic (relative-depth &optional before offer-recent-bullet)
2979 (defun allout-open-topic (relative-depth &optional before offer-recent-bullet
)
2980 "Open a new topic at depth DEPTH.
2982 New topic is situated after current one, unless optional flag BEFORE
2983 is non-nil, or unless current line is completely empty - lacking even
2984 whitespace - in which case open is done on the current line.
2986 When adding an offspring, it will be added immediately after the parent if
2987 the other offspring are exposed, or after the last child if the offspring
2988 are hidden. \(The intervening offspring will be exposed in the latter
2991 If OFFER-RECENT-BULLET is true, offer to use the bullet of the prior sibling.
2995 - Creation of new topics is with respect to the visible topic
2996 containing the cursor, regardless of intervening concealed ones.
2998 - New headers are generally created after/before the body of a
2999 topic. However, they are created right at cursor location if the
3000 cursor is on a blank line, even if that breaks the current topic
3001 body. This is intentional, to provide a simple means for
3002 deliberately dividing topic bodies.
3004 - Double spacing of topic lists is preserved. Also, the first
3005 level two topic is created double-spaced (and so would be
3006 subsequent siblings, if that's left intact). Otherwise,
3007 single-spacing is used.
3009 - Creation of sibling or nested topics is with respect to the topic
3010 you're starting from, even when creating backwards. This way you
3011 can easily create a sibling in front of the current topic without
3012 having to go to its preceding sibling, and then open forward
3015 (allout-beginning-of-current-line)
3016 (let* ((inhibit-field-text-motion t
)
3017 (depth (+ (allout-current-depth) relative-depth
))
3018 (opening-on-blank (if (looking-at "^\$")
3019 (not (setq before nil
))))
3020 ;; bunch o vars set while computing ref-topic
3024 (ref-topic (save-excursion
3025 (cond ((< relative-depth
0)
3026 (allout-ascend-to-depth depth
))
3027 ((>= relative-depth
1) nil
)
3028 (t (allout-back-to-current-heading)))
3029 (setq ref-depth
(allout-recent-depth))
3031 (if (> allout-recent-prefix-end
1)
3032 (allout-recent-bullet)
3034 (setq opening-numbered
3036 (and allout-numbered-bullet
3037 (or (<= relative-depth
0)
3038 (allout-descend-to-depth depth
))
3039 (if (allout-numbered-type-prefix)
3040 allout-numbered-bullet
))))
3045 (if (not opening-on-blank
)
3046 ; Positioning and vertical
3047 ; padding - only if not
3050 (goto-char ref-topic
)
3051 (setq dbl-space
; Determine double space action:
3052 (or (and (<= relative-depth
0) ; not descending;
3054 ;; at b-o-b or preceded by a blank line?
3055 (or (> 0 (forward-line -
1))
3056 (looking-at "^\\s-*$")
3059 ;; succeeded by a blank line?
3060 (allout-end-of-current-subtree)
3061 (looking-at "\n\n")))
3062 (and (= ref-depth
1)
3066 ;; Don't already have following
3067 ;; vertical padding:
3068 (not (allout-pre-next-prefix)))))))
3070 ;; Position to prior heading, if inserting backwards, and not
3072 (if (and before
(>= relative-depth
0))
3073 (progn (allout-back-to-current-heading)
3074 (setq doing-beginning
(bobp))
3076 (allout-previous-heading)))
3077 (if (and before
(bobp))
3080 (if (<= relative-depth
0)
3081 ;; Not going inwards, don't snug up:
3087 (progn (end-of-line)
3088 (allout-pre-next-prefix)
3089 (while (and (= ?
\n (following-char))
3094 (if (not (looking-at "^$"))
3096 (allout-end-of-current-subtree)
3097 (if (looking-at "\n\n") (forward-char 1))))
3098 ;; Going inwards - double-space if first offspring is
3099 ;; double-spaced, otherwise snug up.
3100 (allout-end-of-entry)
3104 (allout-beginning-of-current-line)
3107 ;; Blank lines between current header body and next
3108 ;; header - get to last substantive (non-white-space)
3110 (progn (setq dbl-space t
)
3111 (re-search-backward "[^ \t\n]" nil t
)))
3112 (if (looking-at "\n\n")
3115 (allout-next-heading)
3116 (when (> (allout-recent-depth) ref-depth
)
3117 ;; This is an offspring.
3119 (looking-at "^\\s-*$")))
3120 (progn (forward-line 1)
3123 (allout-end-of-current-line))
3125 ;;(if doing-beginning (goto-char doing-beginning))
3127 ;; We insert a newline char rather than using open-line to
3128 ;; avoid rear-stickiness inheritence of read-only property.
3129 (progn (if (and (not (> depth ref-depth
))
3132 (if (and (not dbl-space
) (> depth ref-depth
))
3138 (if (and dbl-space
(not (> relative-depth
0)))
3140 (if (and (not (eobp))
3144 (insert (concat (allout-make-topic-prefix opening-numbered t depth
)
3147 (allout-rebullet-heading (and offer-recent-bullet ref-bullet
)
3149 (if (> relative-depth
0)
3150 (save-excursion (goto-char ref-topic
)
3151 (allout-show-children)))
3155 ;;;_ > allout-open-subtopic (arg)
3156 (defun allout-open-subtopic (arg)
3157 "Open new topic header at deeper level than the current one.
3159 Negative universal arg means to open deeper, but place the new topic
3160 prior to the current one."
3162 (allout-open-topic 1 (> 0 arg
) (< 1 arg
)))
3163 ;;;_ > allout-open-sibtopic (arg)
3164 (defun allout-open-sibtopic (arg)
3165 "Open new topic header at same level as the current one.
3167 Positive universal arg means to use the bullet of the prior sibling.
3169 Negative universal arg means to place the new topic prior to the current
3172 (allout-open-topic 0 (> 0 arg
) (not (= 1 arg
))))
3173 ;;;_ > allout-open-supertopic (arg)
3174 (defun allout-open-supertopic (arg)
3175 "Open new topic header at shallower level than the current one.
3177 Negative universal arg means to open shallower, but place the new
3178 topic prior to the current one."
3181 (allout-open-topic -
1 (> 0 arg
) (< 1 arg
)))
3183 ;;;_ - Outline Alteration
3184 ;;;_ : Topic Modification
3185 ;;;_ = allout-former-auto-filler
3186 (defvar allout-former-auto-filler nil
3187 "Name of modal fill function being wrapped by `allout-auto-fill'.")
3188 ;;;_ > allout-auto-fill ()
3189 (defun allout-auto-fill ()
3190 "`allout-mode' autofill function.
3192 Maintains outline hanging topic indentation if
3193 `allout-use-hanging-indents' is set."
3195 (when (not allout-inhibit-auto-fill
)
3196 (let ((fill-prefix (if allout-use-hanging-indents
3197 ;; Check for topic header indentation:
3200 (if (looking-at allout-regexp
)
3201 ;; ... construct indentation to account for
3202 ;; length of topic prefix:
3203 (make-string (progn (allout-end-of-prefix)
3206 (use-auto-fill-function (or allout-outside-normal-auto-fill-function
3209 (if (or allout-former-auto-filler allout-use-hanging-indents
)
3210 (funcall use-auto-fill-function
)))))
3211 ;;;_ > allout-reindent-body (old-depth new-depth &optional number)
3212 (defun allout-reindent-body (old-depth new-depth
&optional number
)
3213 "Reindent body lines which were indented at OLD-DEPTH to NEW-DEPTH.
3215 Optional arg NUMBER indicates numbering is being added, and it must
3218 Note that refill of indented paragraphs is not done."
3221 (allout-end-of-prefix)
3222 (let* ((new-margin (current-column))
3223 excess old-indent-begin old-indent-end
3224 ;; We want the column where the header-prefix text started
3225 ;; *before* the prefix was changed, so we infer it relative
3226 ;; to the new margin and the shift in depth:
3227 (old-margin (+ old-depth
(- new-margin new-depth
))))
3229 ;; Process lines up to (but excluding) next topic header:
3233 (and (re-search-forward "\n\\(\\s-*\\)"
3236 ;; Register the indent data, before we reset the
3237 ;; match data with a subsequent `looking-at':
3238 (setq old-indent-begin
(match-beginning 1)
3239 old-indent-end
(match-end 1))
3240 (not (looking-at allout-regexp
)))
3241 (if (> 0 (setq excess
(- (- old-indent-end old-indent-begin
)
3243 ;; Text starts left of old margin - don't adjust:
3245 ;; Text was hanging at or right of old left margin -
3246 ;; reindent it, preserving its existing indentation
3247 ;; beyond the old margin:
3248 (delete-region old-indent-begin old-indent-end
)
3249 (indent-to (+ new-margin excess
(current-column))))))))))
3250 ;;;_ > allout-rebullet-current-heading (arg)
3251 (defun allout-rebullet-current-heading (arg)
3252 "Solicit new bullet for current visible heading."
3254 (let ((initial-col (current-column))
3255 (on-bullet (eq (point)(allout-current-bullet-pos)))
3256 (backwards (if (< arg
0)
3257 (setq arg
(* arg -
1)))))
3259 (save-excursion (allout-back-to-current-heading)
3260 (allout-end-of-prefix)
3261 (allout-rebullet-heading t
;;; solicit
3263 nil
;;; number-control
3265 t
)) ;;; do-successors
3269 (setq initial-col nil
) ; Override positioning back to init col
3271 (allout-next-visible-heading 1)
3272 (allout-goto-prefix)
3273 (allout-next-visible-heading -
1))))
3275 (cond (on-bullet (goto-char (allout-current-bullet-pos)))
3276 (initial-col (move-to-column initial-col
)))))
3277 ;;;_ > allout-rebullet-heading (&optional solicit ...)
3278 (defun allout-rebullet-heading (&optional solicit
3284 "Adjust bullet of current topic prefix.
3286 All args are optional.
3288 If SOLICIT is non-nil, then the choice of bullet is solicited from
3289 user. If it's a character, then that character is offered as the
3290 default, otherwise the one suited to the context \(according to
3291 distinction or depth) is offered. If non-nil, then the
3292 context-specific bullet is just used.
3294 Second arg DEPTH forces the topic prefix to that depth, regardless
3295 of the topic's current depth.
3297 Third arg NUMBER-CONTROL can force the prefix to or away from
3298 numbered form. It has effect only if `allout-numbered-bullet' is
3299 non-nil and soliciting was not explicitly invoked (via first arg).
3300 Its effect, numbering or denumbering, then depends on the setting
3301 of the forth arg, INDEX.
3303 If NUMBER-CONTROL is non-nil and forth arg INDEX is nil, then the
3304 prefix of the topic is forced to be non-numbered. Null index and
3305 non-nil NUMBER-CONTROL forces denumbering. Non-nil INDEX (and
3306 non-nil NUMBER-CONTROL) forces a numbered-prefix form. If non-nil
3307 INDEX is a number, then that number is used for the numbered
3308 prefix. Non-nil and non-number means that the index for the
3309 numbered prefix will be derived by allout-make-topic-prefix.
3311 Fifth arg DO-SUCCESSORS t means re-resolve count on succeeding
3314 Cf vars `allout-stylish-prefixes', `allout-old-style-prefixes',
3315 and `allout-numbered-bullet', which all affect the behavior of
3318 (let* ((current-depth (allout-depth))
3319 (new-depth (or new-depth current-depth
))
3320 (mb allout-recent-prefix-beginning
)
3321 (me allout-recent-prefix-end
)
3322 (current-bullet (buffer-substring (- me
1) me
))
3323 (new-prefix (allout-make-topic-prefix current-bullet
3330 ;; Is new one is identical to old?
3331 (if (and (= current-depth new-depth
)
3332 (string= current-bullet
3333 (substring new-prefix
(1- (length new-prefix
)))))
3337 ;; New prefix probably different from old:
3338 ; get rid of old one:
3339 (allout-unprotected (delete-region mb me
))
3341 ; Dispense with number if
3342 ; numbered-bullet prefix:
3343 (if (and allout-numbered-bullet
3344 (string= allout-numbered-bullet current-bullet
)
3345 (looking-at "[0-9]+"))
3347 (delete-region (match-beginning 0)(match-end 0))))
3349 ; Put in new prefix:
3350 (allout-unprotected (insert new-prefix
))
3352 ;; Reindent the body if elected, margin changed, and not encrypted body:
3353 (if (and allout-reindent-bodies
3354 (not (= new-depth current-depth
))
3355 (not (allout-encrypted-topic-p)))
3356 (allout-reindent-body current-depth new-depth
))
3358 ;; Recursively rectify successive siblings of orig topic if
3359 ;; caller elected for it:
3362 (while (allout-next-sibling new-depth nil
)
3364 (cond ((numberp index
) (1+ index
))
3365 ((not number-control
) (allout-sibling-index))))
3366 (if (allout-numbered-type-prefix)
3367 (allout-rebullet-heading nil
;;; solicit
3368 new-depth
;;; new-depth
3369 number-control
;;; number-control
3371 nil
))))) ;;;(dont!)do-successors
3372 ) ; (if (and (= current-depth new-depth)...))
3373 ) ; let* ((current-depth (allout-depth))...)
3375 ;;;_ > allout-rebullet-topic (arg)
3376 (defun allout-rebullet-topic (arg)
3377 "Rebullet the visible topic containing point and all contained subtopics.
3379 Descends into invisible as well as visible topics, however.
3381 With repeat count, shift topic depth by that amount."
3383 (let ((start-col (current-column)))
3386 (cond ((null arg
) (setq arg
0))
3387 ((listp arg
) (setq arg
(car arg
))))
3388 ;; Fill the user in, in case we're shifting a big topic:
3389 (if (not (zerop arg
)) (message "Shifting..."))
3390 (allout-back-to-current-heading)
3391 (if (<= (+ (allout-recent-depth) arg
) 0)
3392 (error "Attempt to shift topic below level 1"))
3393 (allout-rebullet-topic-grunt arg
)
3394 (if (not (zerop arg
)) (message "Shifting... done.")))
3395 (move-to-column (max 0 (+ start-col arg
)))))
3396 ;;;_ > allout-rebullet-topic-grunt (&optional relative-depth ...)
3397 (defun allout-rebullet-topic-grunt (&optional relative-depth
3402 "Like `allout-rebullet-topic', but on nearest containing topic
3405 See `allout-rebullet-heading' for rebulleting behavior.
3407 All arguments are optional.
3409 First arg RELATIVE-DEPTH means to shift the depth of the entire
3412 The rest of the args are for internal recursive use by the function
3413 itself. The are STARTING-DEPTH, STARTING-POINT, and INDEX."
3415 (let* ((relative-depth (or relative-depth
0))
3416 (new-depth (allout-depth))
3417 (starting-depth (or starting-depth new-depth
))
3418 (on-starting-call (null starting-point
))
3420 ;; Leave index null on starting call, so rebullet-heading
3421 ;; calculates it at what might be new depth:
3422 (and (or (zerop relative-depth
)
3423 (not on-starting-call
))
3424 (allout-sibling-index))))
3425 (moving-outwards (< 0 relative-depth
))
3426 (starting-point (or starting-point
(point))))
3428 ;; Sanity check for excessive promotion done only on starting call:
3429 (and on-starting-call
3431 (> 0 (+ starting-depth relative-depth
))
3432 (error "Attempt to shift topic out beyond level 1")) ;;; ====>
3434 (cond ((= starting-depth new-depth
)
3435 ;; We're at depth to work on this one:
3436 (allout-rebullet-heading nil
;;; solicit
3437 (+ starting-depth
;;; starting-depth
3441 ;; Every contained topic will get hit,
3442 ;; and we have to get to outside ones
3444 nil
) ;;; do-successors
3445 ;; ... and work on subsequent ones which are at greater depth:
3447 (allout-next-heading)
3448 (while (and (not (eobp))
3449 (< starting-depth
(allout-recent-depth)))
3450 (setq index
(1+ index
))
3451 (allout-rebullet-topic-grunt relative-depth
;;; relative-depth
3452 (1+ starting-depth
);;;starting-depth
3453 starting-point
;;; starting-point
3456 ((< starting-depth new-depth
)
3457 ;; Rare case - subtopic more than one level deeper than parent.
3458 ;; Treat this one at an even deeper level:
3459 (allout-rebullet-topic-grunt relative-depth
;;; relative-depth
3460 new-depth
;;; starting-depth
3461 starting-point
;;; starting-point
3464 (if on-starting-call
3466 ;; Rectify numbering of former siblings of the adjusted topic,
3467 ;; if topic has changed depth
3468 (if (or do-successors
3469 (and (not (zerop relative-depth
))
3470 (or (= (allout-recent-depth) starting-depth
)
3471 (= (allout-recent-depth) (+ starting-depth
3473 (allout-rebullet-heading nil nil nil nil t
))
3474 ;; Now rectify numbering of new siblings of the adjusted topic,
3475 ;; if depth has been changed:
3476 (progn (goto-char starting-point
)
3477 (if (not (zerop relative-depth
))
3478 (allout-rebullet-heading nil nil nil nil t
)))))
3481 ;;;_ > allout-renumber-to-depth (&optional depth)
3482 (defun allout-renumber-to-depth (&optional depth
)
3483 "Renumber siblings at current depth.
3485 Affects superior topics if optional arg DEPTH is less than current depth.
3487 Returns final depth."
3489 ;; Proceed by level, processing subsequent siblings on each,
3490 ;; ascending until we get shallower than the start depth:
3492 (let ((ascender (allout-depth))
3494 (while (and (not (eobp))
3496 (>= (allout-recent-depth) depth
)
3497 (>= ascender depth
))
3498 ; Skip over all topics at
3499 ; lesser depths, which can not
3500 ; have been disturbed:
3501 (while (and (not (setq was-eobp
(eobp)))
3502 (> (allout-recent-depth) ascender
))
3503 (allout-next-heading))
3504 ; Prime ascender for ascension:
3505 (setq ascender
(1- (allout-recent-depth)))
3506 (if (>= (allout-recent-depth) depth
)
3507 (allout-rebullet-heading nil
;;; solicit
3509 nil
;;; number-control
3511 t
)) ;;; do-successors
3512 (if was-eobp
(goto-char (point-max)))))
3513 (allout-recent-depth))
3514 ;;;_ > allout-number-siblings (&optional denumber)
3515 (defun allout-number-siblings (&optional denumber
)
3516 "Assign numbered topic prefix to this topic and its siblings.
3518 With universal argument, denumber - assign default bullet to this
3519 topic and its siblings.
3521 With repeated universal argument (`^U^U'), solicit bullet for each
3522 rebulleting each topic at this level."
3527 (allout-back-to-current-heading)
3528 (allout-beginning-of-level)
3529 (let ((depth (allout-recent-depth))
3530 (index (if (not denumber
) 1))
3531 (use-bullet (equal '(16) denumber
))
3534 (allout-rebullet-heading use-bullet
;;; solicit
3536 t
;;; number-control
3538 nil
) ;;; do-successors
3539 (if index
(setq index
(1+ index
)))
3540 (setq more
(allout-next-sibling depth nil
))))))
3541 ;;;_ > allout-shift-in (arg)
3542 (defun allout-shift-in (arg)
3543 "Increase depth of current heading and any topics collapsed within it.
3545 We disallow shifts that would result in the topic having a depth more than
3546 one level greater than the immediately previous topic, to avoid containment
3547 discontinuity. The first topic in the file can be adjusted to any positive
3552 (allout-back-to-current-heading)
3554 (let* ((current-depth (allout-recent-depth))
3555 (start-point (point))
3556 (predecessor-depth (progn
3558 (allout-goto-prefix)
3559 (if (< (point) start-point
)
3560 (allout-recent-depth)
3562 (if (and (> predecessor-depth
0)
3563 (> (+ current-depth arg
)
3564 (1+ predecessor-depth
)))
3565 (error (concat "Disallowed shift deeper than"
3566 " containing topic's children.")))))))
3567 (allout-rebullet-topic arg
))
3568 ;;;_ > allout-shift-out (arg)
3569 (defun allout-shift-out (arg)
3570 "Decrease depth of current heading and any topics collapsed within it.
3572 We disallow shifts that would result in the topic having a depth more than
3573 one level greater than the immediately previous topic, to avoid containment
3574 discontinuity. The first topic in the file can be adjusted to any positive
3578 (allout-shift-in (* arg -
1)))
3579 (allout-rebullet-topic (* arg -
1)))
3580 ;;;_ : Surgery (kill-ring) functions with special provisions for outlines:
3581 ;;;_ > allout-kill-line (&optional arg)
3582 (defun allout-kill-line (&optional arg
)
3583 "Kill line, adjusting subsequent lines suitably for outline mode."
3587 (if (or (not (allout-mode-p))
3589 (not (looking-at allout-regexp
)))
3590 ;; Just do a regular kill:
3592 ;; Ah, have to watch out for adjustments:
3593 (let* ((beg (point))
3594 (beg-hidden (allout-hidden-p))
3595 (end-hidden (save-excursion (allout-end-of-current-line)
3597 (depth (allout-depth))
3598 (collapsed (allout-current-topic-collapsed-p)))
3601 (put-text-property beg
(1+ beg
) 'allout-was-collapsed t
)
3602 (remove-text-properties beg
(1+ beg
) '(allout-was-collapsed t
)))
3604 (if (and (not beg-hidden
) (not end-hidden
))
3605 (allout-unprotected (kill-line arg
))
3607 ; Provide some feedback:
3609 (if allout-numbered-bullet
3610 (save-excursion ; Renumber subsequent topics if needed:
3611 (if (not (looking-at allout-regexp
))
3612 (allout-next-heading))
3613 (allout-renumber-to-depth depth
))))))
3614 ;;;_ > allout-kill-topic ()
3615 (defun allout-kill-topic ()
3616 "Kill topic together with subtopics.
3618 Trailing whitespace is killed with a topic if that whitespace:
3620 - would separate the topic from a subsequent sibling
3621 - would separate the topic from the end of buffer
3622 - would not be added to whitespace already separating the topic from the
3625 Completely collapsed topics are marked as such, for re-collapse
3626 when yank with allout-yank into an outline as a heading."
3628 ;; Some finagling is done to make complex topic kills appear faster
3629 ;; than they actually are. A redisplay is performed immediately
3630 ;; after the region is deleted, though the renumbering process
3631 ;; has yet to be performed. This means that there may appear to be
3632 ;; a lag *after* a kill has been performed.
3635 (let* ((inhibit-field-text-motion t
)
3636 (collapsed (allout-current-topic-collapsed-p))
3637 (beg (prog1 (allout-back-to-current-heading) (beginning-of-line)))
3638 (depth (allout-recent-depth)))
3639 (allout-end-of-current-subtree)
3640 (if (and (/= (current-column) 0) (not (eobp)))
3643 (if (and (looking-at "\n")
3645 (or (not (allout-next-heading))
3646 (= depth
(allout-recent-depth))))
3647 (and (> (- beg
(point-min)) 3)
3648 (string= (buffer-substring (- beg
2) beg
) "\n\n"))))
3653 (put-text-property beg
(1+ beg
) 'allout-was-collapsed t
))
3655 (remove-text-properties beg
(1+ beg
) '(allout-was-collapsed t
))))
3656 (allout-unprotected (kill-region beg
(point)))
3659 (allout-renumber-to-depth depth
))))
3660 ;;;_ > allout-yank-processing ()
3661 (defun allout-yank-processing (&optional arg
)
3663 "Incidental allout-specific business to be done just after text yanks.
3665 Does depth adjustment of yanked topics, when:
3667 1 the stuff being yanked starts with a valid outline header prefix, and
3668 2 it is being yanked at the end of a line which consists of only a valid
3671 Also, adjusts numbering of subsequent siblings when appropriate.
3673 Depth adjustment alters the depth of all the topics being yanked
3674 the amount it takes to make the first topic have the depth of the
3675 header into which it's being yanked.
3677 The point is left in front of yanked, adjusted topics, rather than
3678 at the end (and vice-versa with the mark). Non-adjusted yanks,
3679 however, are left exactly like normal, non-allout-specific yanks."
3682 ; Get to beginning, leaving
3683 ; region around subject:
3684 (if (< (allout-mark-marker t
) (point))
3685 (exchange-point-and-mark))
3686 (let* ((inhibit-field-text-motion t
)
3689 (subj-end (allout-mark-marker t
))
3690 (was-collapsed (get-text-property subj-beg
'allout-was-collapsed
))
3691 ;; 'resituate' if yanking an entire topic into topic header:
3692 (resituate (and (allout-e-o-prefix-p)
3693 (looking-at (concat "\\(" allout-regexp
"\\)"))
3694 (allout-prefix-data (match-beginning 1)
3696 ;; `rectify-numbering' if resituating (where several topics may
3697 ;; be resituating) or yanking a topic into a topic slot (bol):
3698 (rectify-numbering (or resituate
3699 (and into-bol
(looking-at allout-regexp
)))))
3701 ; The yanked stuff is a topic:
3702 (let* ((prefix-len (- (match-end 1) subj-beg
))
3703 (subj-depth (allout-recent-depth))
3704 (prefix-bullet (allout-recent-bullet))
3706 ;; Nil if adjustment unnecessary, otherwise depth to which
3707 ;; adjustment should be made:
3709 (and (goto-char subj-end
)
3711 (goto-char subj-beg
)
3712 (and (looking-at allout-regexp
)
3715 (not (= (point) subj-beg
)))
3716 (looking-at allout-regexp
)
3717 (allout-prefix-data (match-beginning 0)
3719 (allout-recent-depth))))
3721 (setq rectify-numbering allout-numbered-bullet
)
3723 ; Do the adjustment:
3725 (message "... yanking") (sit-for 0)
3727 (narrow-to-region subj-beg subj-end
)
3728 ; Trim off excessive blank
3729 ; line at end, if any:
3730 (goto-char (point-max))
3731 (if (looking-at "^$")
3732 (allout-unprotected (delete-char -
1)))
3733 ; Work backwards, with each
3735 ; successively excluding the
3736 ; last processed topic from
3737 ; the narrow region:
3739 (allout-back-to-current-heading)
3740 ; go as high as we can in each bunch:
3741 (while (allout-ascend-to-depth (1- (allout-depth))))
3743 (allout-rebullet-topic-grunt (- adjust-to-depth
3746 (if (setq more
(not (bobp)))
3749 (narrow-to-region subj-beg
(point))))))
3751 ;; Preserve new bullet if it's a distinctive one, otherwise
3753 (if (string-match (regexp-quote prefix-bullet
)
3754 allout-distinctive-bullets-string
)
3755 ; Delete from bullet of old to
3756 ; before bullet of new:
3759 (delete-region (point) subj-beg
)
3760 (set-marker (allout-mark-marker t
) subj-end
)
3761 (goto-char subj-beg
)
3762 (allout-end-of-prefix))
3763 ; Delete base subj prefix,
3765 (delete-region (point) (+ (point)
3767 (- adjust-to-depth subj-depth
)))
3768 ; and delete residual subj
3769 ; prefix digits and space:
3770 (while (looking-at "[0-9]") (delete-char 1))
3771 (if (looking-at " ") (delete-char 1))))
3772 (exchange-point-and-mark))))
3773 (if rectify-numbering
3776 ; Give some preliminary feedback:
3777 (message "... reconciling numbers") (sit-for 0)
3778 ; ... and renumber, in case necessary:
3779 (goto-char subj-beg
)
3780 (if (allout-goto-prefix)
3781 (allout-rebullet-heading nil
;;; solicit
3782 (allout-depth) ;;; depth
3783 nil
;;; number-control
3787 (when (and (or into-bol resituate
) was-collapsed
)
3788 (remove-text-properties subj-beg
(1+ subj-beg
) '(allout-was-collapsed))
3789 (allout-hide-current-subtree))
3791 (exchange-point-and-mark))))
3792 ;;;_ > allout-yank (&optional arg)
3793 (defun allout-yank (&optional arg
)
3794 "`allout-mode' yank, with depth and numbering adjustment of yanked topics.
3796 Non-topic yanks work no differently than normal yanks.
3798 If a topic is being yanked into a bare topic prefix, the depth of the
3799 yanked topic is adjusted to the depth of the topic prefix.
3801 1 we're yanking in an `allout-mode' buffer
3802 2 the stuff being yanked starts with a valid outline header prefix, and
3803 3 it is being yanked at the end of a line which consists of only a valid
3806 If these conditions hold then the depth of the yanked topics are all
3807 adjusted the amount it takes to make the first one at the depth of the
3808 header into which it's being yanked.
3810 The point is left in front of yanked, adjusted topics, rather than
3811 at the end (and vice-versa with the mark). Non-adjusted yanks,
3812 however, (ones that don't qualify for adjustment) are handled
3813 exactly like normal yanks.
3815 Numbering of yanked topics, and the successive siblings at the depth
3816 into which they're being yanked, is adjusted.
3818 `allout-yank-pop' works with `allout-yank' just like normal `yank-pop'
3819 works with normal `yank' in non-outline buffers."
3822 (setq this-command
'yank
)
3825 (allout-yank-processing))
3827 ;;;_ > allout-yank-pop (&optional arg)
3828 (defun allout-yank-pop (&optional arg
)
3829 "Yank-pop like `allout-yank' when popping to bare outline prefixes.
3831 Adapts level of popped topics to level of fresh prefix.
3833 Note - prefix changes to distinctive bullets will stick, if followed
3834 by pops to non-distinctive yanks. Bug..."
3837 (setq this-command
'yank
)
3840 (allout-yank-processing)))
3842 ;;;_ - Specialty bullet functions
3843 ;;;_ : File Cross references
3844 ;;;_ > allout-resolve-xref ()
3845 (defun allout-resolve-xref ()
3846 "Pop to file associated with current heading, if it has an xref bullet.
3848 \(Works according to setting of `allout-file-xref-bullet')."
3850 (if (not allout-file-xref-bullet
)
3852 "Outline cross references disabled - no `allout-file-xref-bullet'")
3853 (if (not (string= (allout-current-bullet) allout-file-xref-bullet
))
3854 (error "Current heading lacks cross-reference bullet `%s'"
3855 allout-file-xref-bullet
)
3856 (let ((inhibit-field-text-motion t
)
3859 (let* ((text-start allout-recent-prefix-end
)
3860 (heading-end (progn (end-of-line) (point))))
3861 (goto-char text-start
)
3863 (if (re-search-forward "\\s-\\(\\S-*\\)" heading-end t
)
3864 (buffer-substring (match-beginning 1) (match-end 1))))))
3865 (setq file-name
(expand-file-name file-name
))
3866 (if (or (file-exists-p file-name
)
3867 (if (file-writable-p file-name
)
3868 (y-or-n-p (format "%s not there, create one? "
3870 (error "%s not found and can't be created" file-name
)))
3871 (condition-case failure
3872 (find-file-other-window file-name
)
3874 (error "%s not found" file-name
))
3880 ;;;_ #6 Exposure Control
3883 ;;;_ > allout-flag-region (from to flag)
3884 (defun allout-flag-region (from to flag
)
3885 "Conceal text from FROM to TO if FLAG is non-nil, else reveal it.
3887 Text is shown if flag is nil and hidden otherwise."
3888 ;; We use outline invisibility spec.
3889 (remove-overlays from to
'category
'allout-exposure-category
)
3891 (let ((o (make-overlay from to
)))
3892 (overlay-put o
'category
'allout-exposure-category
)
3893 (when (featurep 'xemacs
)
3894 (let ((props (symbol-plist 'allout-exposure-category
)))
3896 (overlay-put o
(pop props
) (pop props
)))))))
3897 (run-hooks 'allout-view-change-hook
)
3898 (run-hooks 'allout-exposure-change-hook
))
3899 ;;;_ > allout-flag-current-subtree (flag)
3900 (defun allout-flag-current-subtree (flag)
3901 "Conceal currently-visible topic's subtree if FLAG non-nil, else reveal it."
3904 (allout-back-to-current-heading)
3905 (let ((inhibit-field-text-motion t
))
3907 (allout-flag-region (point)
3908 ;; Exposing must not leave trailing blanks hidden,
3909 ;; but can leave them exposed when hiding, so we
3910 ;; can use flag's inverse as the
3911 ;; include-trailing-blank cue:
3912 (allout-end-of-current-subtree (not flag
))
3915 ;;;_ - Topic-specific
3916 ;;;_ > allout-show-entry ()
3917 (defun allout-show-entry ()
3918 "Like `allout-show-current-entry', but reveals entries in hidden topics.
3920 This is a way to give restricted peek at a concealed locality without the
3921 expense of exposing its context, but can leave the outline with aberrant
3922 exposure. `allout-show-offshoot' should be used after the peek to rectify
3928 (allout-goto-prefix)
3929 (setq beg
(if (allout-hidden-p) (1- (point)) (point)))
3930 (setq end
(allout-pre-next-prefix))
3931 (allout-flag-region beg end nil
)
3933 ;;;_ > allout-show-children (&optional level strict)
3934 (defun allout-show-children (&optional level strict
)
3936 "If point is visible, show all direct subheadings of this heading.
3938 Otherwise, do `allout-show-to-offshoot', and then show subheadings.
3940 Optional LEVEL specifies how many levels below the current level
3941 should be shown, or all levels if t. Default is 1.
3943 Optional STRICT means don't resort to -show-to-offshoot, no matter
3944 what. This is basically so -show-to-offshoot, which is called by
3945 this function, can employ the pure offspring-revealing capabilities of
3948 Returns point at end of subtree that was opened, if any. (May get a
3949 point of non-opened subtree?)"
3952 (let ((start-point (point)))
3953 (if (and (not strict
)
3956 (progn (allout-show-to-offshoot) ; Point's concealed, open to
3958 ;; Then recurse, but with "strict" set so we don't
3959 ;; infinite regress:
3960 (allout-show-children level t
))
3963 (allout-beginning-of-current-line)
3965 (let* ((chart (allout-chart-subtree (or level
1)))
3966 (to-reveal (allout-chart-to-reveal chart
(or level
1))))
3967 (goto-char start-point
)
3968 (when (and strict
(allout-hidden-p))
3969 ;; Concealed root would already have been taken care of,
3970 ;; unless strict was set.
3971 (allout-flag-region (point) (allout-snug-back) nil
)
3972 (when allout-show-bodies
3973 (goto-char (car to-reveal
))
3974 (allout-show-current-entry)))
3976 (goto-char (car to-reveal
))
3977 (allout-flag-region (save-excursion (allout-snug-back) (point))
3978 (progn (search-forward "\n" nil t
)
3981 (when allout-show-bodies
3982 (goto-char (car to-reveal
))
3983 (allout-show-current-entry))
3984 (setq to-reveal
(cdr to-reveal
)))))))
3985 ;; Compensate for `save-excursion's maintenance of point
3986 ;; within invisible text:
3987 (goto-char start-point
)))
3988 ;;;_ > allout-show-to-offshoot ()
3989 (defun allout-show-to-offshoot ()
3990 "Like `allout-show-entry', but reveals all concealed ancestors, as well.
3992 Useful for coherently exposing to a random point in a hidden region."
3995 (let ((inhibit-field-text-motion t
)
3997 (orig-pref (allout-goto-prefix))
4000 (while (or bag-it
(allout-hidden-p))
4001 (while (allout-hidden-p)
4002 ;; XXX We would use `(move-beginning-of-line 1)', but it gets
4003 ;; stuck on hidden newlines at column 80, as of GNU Emacs 22.0.50.
4005 (if (allout-hidden-p) (forward-char -
1)))
4006 (if (= last-at
(setq last-at
(point)))
4007 ;; Oops, we're not making any progress! Show the current
4008 ;; topic completely, and bag this try.
4009 (progn (beginning-of-line)
4010 (allout-show-current-subtree)
4015 "allout-show-to-offshoot: "
4016 "Aberrant nesting encountered.")))
4017 (allout-show-children)
4018 (goto-char orig-pref
))
4019 (goto-char orig-pt
)))
4020 (if (allout-hidden-p)
4021 (allout-show-entry)))
4022 ;;;_ > allout-hide-current-entry ()
4023 (defun allout-hide-current-entry ()
4024 "Hide the body directly following this heading."
4026 (allout-back-to-current-heading)
4028 (let ((inhibit-field-text-motion t
))
4030 (allout-flag-region (point)
4031 (progn (allout-end-of-entry) (point))
4033 ;;;_ > allout-show-current-entry (&optional arg)
4034 (defun allout-show-current-entry (&optional arg
)
4035 "Show body following current heading, or hide entry with universal argument."
4039 (allout-hide-current-entry)
4040 (save-excursion (allout-show-to-offshoot))
4042 (allout-flag-region (point)
4043 (progn (allout-end-of-entry t
) (point))
4046 ;;;_ > allout-show-current-subtree (&optional arg)
4047 (defun allout-show-current-subtree (&optional arg
)
4048 "Show everything within the current topic. With a repeat-count,
4049 expose this topic and its siblings."
4052 (if (<= (allout-current-depth) 0)
4053 ;; Outside any topics - try to get to the first:
4054 (if (not (allout-next-heading))
4056 ;; got to first, outermost topic - set to expose it and siblings:
4057 (message "Above outermost topic - exposing all.")
4058 (allout-flag-region (point-min)(point-max) nil
))
4059 (allout-beginning-of-current-line)
4061 (allout-flag-current-subtree nil
)
4062 (allout-beginning-of-level)
4063 (allout-expose-topic '(* :))))))
4064 ;;;_ > allout-current-topic-collapsed-p (&optional include-single-liners)
4065 (defun allout-current-topic-collapsed-p (&optional include-single-liners
)
4066 "True if the currently visible containing topic is already collapsed.
4068 Single line topics intrinsically can be considered as being both
4069 collapsed and uncollapsed. If optional INCLUDE-SINGLE-LINERS is
4070 true, then single-line topics are considered to be collapsed. By
4071 default, they are treated as being uncollapsed."
4074 (= (progn (allout-back-to-current-heading)
4075 (move-end-of-line 1)
4077 (allout-end-of-current-subtree (not (looking-at "\n\n"))))
4078 (or include-single-liners
4079 (progn (backward-char 1) (allout-hidden-p))))))
4080 ;;;_ > allout-hide-current-subtree (&optional just-close)
4081 (defun allout-hide-current-subtree (&optional just-close
)
4082 "Close the current topic, or containing topic if this one is already closed.
4084 If this topic is closed and it's a top level topic, close this topic
4087 If optional arg JUST-CLOSE is non-nil, do not close the parent or
4088 siblings, even if the target topic is already closed."
4091 (let* ((from (point))
4092 (sibs-msg "Top-level topic already closed - closing siblings...")
4093 (current-exposed (not (allout-current-topic-collapsed-p t
))))
4094 (cond (current-exposed (allout-flag-current-subtree t
))
4096 ((allout-up-current-level 1 t
) (allout-hide-current-subtree))
4099 (allout-goto-prefix)
4100 (allout-expose-topic '(0 :))
4101 (message (concat sibs-msg
" Done."))))
4103 ;;;_ > allout-show-current-branches ()
4104 (defun allout-show-current-branches ()
4105 "Show all subheadings of this heading, but not their bodies."
4107 (let ((inhibit-field-text-motion t
))
4108 (beginning-of-line))
4109 (allout-show-children t
))
4110 ;;;_ > allout-hide-current-leaves ()
4111 (defun allout-hide-current-leaves ()
4112 "Hide the bodies of the current topic and all its offspring."
4114 (allout-back-to-current-heading)
4115 (allout-hide-region-body (point) (progn (allout-end-of-current-subtree)
4118 ;;;_ - Region and beyond
4119 ;;;_ > allout-show-all ()
4120 (defun allout-show-all ()
4121 "Show all of the text in the buffer."
4123 (message "Exposing entire buffer...")
4124 (allout-flag-region (point-min) (point-max) nil
)
4125 (message "Exposing entire buffer... Done."))
4126 ;;;_ > allout-hide-bodies ()
4127 (defun allout-hide-bodies ()
4128 "Hide all of buffer except headings."
4130 (allout-hide-region-body (point-min) (point-max)))
4131 ;;;_ > allout-hide-region-body (start end)
4132 (defun allout-hide-region-body (start end
)
4133 "Hide all body lines in the region, but not headings."
4136 (narrow-to-region start end
)
4137 (goto-char (point-min))
4138 (let ((inhibit-field-text-motion t
))
4141 (allout-flag-region (point) (allout-end-of-entry) t
)
4144 (if (looking-at "\n\n")
4147 ;;;_ > allout-expose-topic (spec)
4148 (defun allout-expose-topic (spec)
4149 "Apply exposure specs to successive outline topic items.
4151 Use the more convenient frontend, `allout-new-exposure', if you don't
4152 need evaluation of the arguments, or even better, the `allout-layout'
4153 variable-keyed mode-activation/auto-exposure feature of allout outline
4154 mode. See the respective documentation strings for more details.
4156 Cursor is left at start position.
4158 SPEC is either a number or a list.
4160 Successive specs on a list are applied to successive sibling topics.
4162 A simple spec \(either a number, one of a few symbols, or the null
4163 list) dictates the exposure for the corresponding topic.
4165 Non-null lists recursively designate exposure specs for respective
4166 subtopics of the current topic.
4168 The `:' repeat spec is used to specify exposure for any number of
4169 successive siblings, up to the trailing ones for which there are
4170 explicit specs following the `:'.
4172 Simple (numeric and null-list) specs are interpreted as follows:
4174 Numbers indicate the relative depth to open the corresponding topic.
4175 - negative numbers force the topic to be closed before opening to the
4176 absolute value of the number, so all siblings are open only to
4178 - positive numbers open to the relative depth indicated by the
4179 number, but do not force already opened subtopics to be closed.
4180 - 0 means to close topic - hide all offspring.
4182 apply prior element to all siblings at current level, *up to*
4183 those siblings that would be covered by specs following the `:'
4184 on the list. Ie, apply to all topics at level but the last
4185 ones. \(Only first of multiple colons at same level is
4186 respected - subsequent ones are discarded.)
4187 * - completely opens the topic, including bodies.
4188 + - shows all the sub headers, but not the bodies
4189 - - exposes the body of the corresponding topic.
4192 \(allout-expose-topic '(-1 : 0))
4193 Close this and all following topics at current level, exposing
4194 only their immediate children, but close down the last topic
4195 at this current level completely.
4196 \(allout-expose-topic '(-1 () : 1 0))
4197 Close current topic so only the immediate subtopics are shown;
4198 show the children in the second to last topic, and completely
4200 \(allout-expose-topic '(-2 : -1 *))
4201 Expose children and grandchildren of all topics at current
4202 level except the last two; expose children of the second to
4203 last and completely open the last one."
4205 (interactive "xExposure spec: ")
4206 (if (not (listp spec
))
4208 (let ((depth (allout-depth))
4213 (setq prev-elem curr-elem
4214 curr-elem
(car spec
)
4216 (cond ; Do current element:
4217 ((null curr-elem
) nil
)
4218 ((symbolp curr-elem
)
4219 (cond ((eq curr-elem
'*) (allout-show-current-subtree)
4220 (if (> allout-recent-end-of-subtree max-pos
)
4221 (setq max-pos allout-recent-end-of-subtree
)))
4222 ((eq curr-elem
'+) (allout-show-current-branches)
4223 (if (> allout-recent-end-of-subtree max-pos
)
4224 (setq max-pos allout-recent-end-of-subtree
)))
4225 ((eq curr-elem
'-
) (allout-show-current-entry))
4228 ;; Expand the `repeat' spec to an explicit version,
4229 ;; w.r.t. remaining siblings:
4230 (let ((residue ; = # of sibs not covered by remaining spec
4231 ;; Dang - could be nice to make use of the chart, sigh:
4232 (- (length (allout-chart-siblings))
4235 ;; Some residue - cover it with prev-elem:
4236 (setq spec
(append (make-list residue prev-elem
)
4238 ((numberp curr-elem
)
4239 (if (and (>= 0 curr-elem
) (not (allout-hidden-p)))
4240 (save-excursion (allout-hide-current-subtree t
)
4243 (if (> allout-recent-end-of-subtree max-pos
)
4245 allout-recent-end-of-subtree
)))))
4246 (if (> (abs curr-elem
) 0)
4247 (progn (allout-show-children (abs curr-elem
))
4248 (if (> allout-recent-end-of-subtree max-pos
)
4249 (setq max-pos allout-recent-end-of-subtree
)))))
4251 (if (allout-descend-to-depth (1+ depth
))
4252 (let ((got (allout-expose-topic curr-elem
)))
4253 (if (and got
(> got max-pos
)) (setq max-pos got
))))))
4254 (cond (stay (setq stay nil
))
4255 ((listp (car spec
)) nil
)
4256 ((> max-pos
(point))
4257 ;; Capitalize on max-pos state to get us nearer next sibling:
4258 (progn (goto-char (min (point-max) max-pos
))
4259 (allout-next-heading)))
4260 ((allout-next-sibling depth
))))
4262 ;;;_ > allout-old-expose-topic (spec &rest followers)
4263 (defun allout-old-expose-topic (spec &rest followers
)
4265 "Deprecated. Use `allout-expose-topic' \(with different schema
4268 Dictate wholesale exposure scheme for current topic, according to SPEC.
4270 SPEC is either a number or a list. Optional successive args
4271 dictate exposure for subsequent siblings of current topic.
4273 A simple spec (either a number, a special symbol, or the null list)
4274 dictates the overall exposure for a topic. Non null lists are
4275 composite specs whose first element dictates the overall exposure for
4276 a topic, with the subsequent elements in the list interpreted as specs
4277 that dictate the exposure for the successive offspring of the topic.
4279 Simple (numeric and null-list) specs are interpreted as follows:
4281 - Numbers indicate the relative depth to open the corresponding topic:
4282 - negative numbers force the topic to be close before opening to the
4283 absolute value of the number.
4284 - positive numbers just open to the relative depth indicated by the number.
4286 - `*' completely opens the topic, including bodies.
4287 - `+' shows all the sub headers, but not the bodies
4288 - `-' exposes the body and immediate offspring of the corresponding topic.
4290 If the spec is a list, the first element must be a number, which
4291 dictates the exposure depth of the topic as a whole. Subsequent
4292 elements of the list are nested SPECs, dictating the specific exposure
4293 for the corresponding offspring of the topic.
4295 Optional FOLLOWERS arguments dictate exposure for succeeding siblings."
4297 (interactive "xExposure spec: ")
4298 (let ((inhibit-field-text-motion t
)
4299 (depth (allout-current-depth))
4301 (cond ((null spec
) nil
)
4303 (if (eq spec
'*) (allout-show-current-subtree))
4304 (if (eq spec
'+) (allout-show-current-branches))
4305 (if (eq spec
'-
) (allout-show-current-entry)))
4308 (save-excursion (allout-hide-current-subtree t
)
4310 (if (or (not max-pos
)
4311 (> (point) max-pos
))
4312 (setq max-pos
(point)))
4314 (setq spec
(* -
1 spec
)))))
4316 (allout-show-children spec
)))
4318 ;(let ((got (allout-old-expose-topic (car spec))))
4319 ; (if (and got (or (not max-pos) (> got max-pos)))
4320 ; (setq max-pos got)))
4321 (let ((new-depth (+ (allout-current-depth) 1))
4323 (setq max-pos
(allout-old-expose-topic (car spec
)))
4324 (setq spec
(cdr spec
))
4326 (allout-descend-to-depth new-depth
)
4327 (not (allout-hidden-p)))
4328 (progn (setq got
(apply 'allout-old-expose-topic spec
))
4329 (if (and got
(or (not max-pos
) (> got max-pos
)))
4330 (setq max-pos got
)))))))
4331 (while (and followers
4332 (progn (if (and max-pos
(< (point) max-pos
))
4333 (progn (goto-char max-pos
)
4334 (setq max-pos nil
)))
4336 (allout-next-sibling depth
)))
4337 (allout-old-expose-topic (car followers
))
4338 (setq followers
(cdr followers
)))
4340 ;;;_ > allout-new-exposure '()
4341 (defmacro allout-new-exposure
(&rest spec
)
4342 "Literal frontend for `allout-expose-topic', doesn't evaluate arguments.
4343 Some arguments that would need to be quoted in `allout-expose-topic'
4344 need not be quoted in `allout-new-exposure'.
4346 Cursor is left at start position.
4348 Use this instead of obsolete `allout-exposure'.
4351 \(allout-new-exposure (-1 () () () 1) 0)
4352 Close current topic at current level so only the immediate
4353 subtopics are shown, except also show the children of the
4354 third subtopic; and close the next topic at the current level.
4355 \(allout-new-exposure : -1 0)
4356 Close all topics at current level to expose only their
4357 immediate children, except for the last topic at the current
4358 level, in which even its immediate children are hidden.
4359 \(allout-new-exposure -2 : -1 *)
4360 Expose children and grandchildren of first topic at current
4361 level, and expose children of subsequent topics at current
4362 level *except* for the last, which should be opened completely."
4363 (list 'save-excursion
4364 '(if (not (or (allout-goto-prefix)
4365 (allout-next-heading)))
4366 (error "allout-new-exposure: Can't find any outline topics"))
4367 (list 'allout-expose-topic
(list 'quote spec
))))
4369 ;;;_ #7 Systematic outline presentation - copying, printing, flattening
4371 ;;;_ - Mapping and processing of topics
4372 ;;;_ ( See also Subtree Charting, in Navigation code.)
4373 ;;;_ > allout-stringify-flat-index (flat-index)
4374 (defun allout-stringify-flat-index (flat-index &optional context
)
4375 "Convert list representing section/subsection/... to document string.
4377 Optional arg CONTEXT indicates interior levels to include."
4381 (context-depth (or (and context
2) 1)))
4382 ;; Take care of the explicit context:
4383 (while (> context-depth
0)
4384 (setq numstr
(int-to-string (car flat-index
))
4385 flat-index
(cdr flat-index
)
4386 result
(if flat-index
4387 (cons delim
(cons numstr result
))
4388 (cons numstr result
))
4389 context-depth
(if flat-index
(1- context-depth
) 0)))
4391 ;; Take care of the indentation:
4398 (1+ (truncate (if (zerop (car flat-index
))
4400 (log10 (car flat-index
)))))
4403 (setq flat-index
(cdr flat-index
)))
4404 ;; Dispose of single extra delim:
4405 (setq result
(cdr result
))))
4406 (apply 'concat result
)))
4407 ;;;_ > allout-stringify-flat-index-plain (flat-index)
4408 (defun allout-stringify-flat-index-plain (flat-index)
4409 "Convert list representing section/subsection/... to document string."
4413 (setq result
(cons (int-to-string (car flat-index
))
4415 (cons delim result
))))
4416 (setq flat-index
(cdr flat-index
)))
4417 (apply 'concat result
)))
4418 ;;;_ > allout-stringify-flat-index-indented (flat-index)
4419 (defun allout-stringify-flat-index-indented (flat-index)
4420 "Convert list representing section/subsection/... to document string."
4424 ;; Take care of the explicit context:
4425 (setq numstr
(int-to-string (car flat-index
))
4426 flat-index
(cdr flat-index
)
4427 result
(if flat-index
4428 (cons delim
(cons numstr result
))
4429 (cons numstr result
)))
4431 ;; Take care of the indentation:
4438 (1+ (truncate (if (zerop (car flat-index
))
4440 (log10 (car flat-index
)))))
4443 (setq flat-index
(cdr flat-index
)))
4444 ;; Dispose of single extra delim:
4445 (setq result
(cdr result
))))
4446 (apply 'concat result
)))
4447 ;;;_ > allout-listify-exposed (&optional start end format)
4448 (defun allout-listify-exposed (&optional start end format
)
4450 "Produce a list representing exposed topics in current region.
4452 This list can then be used by `allout-process-exposed' to manipulate
4455 Optional START and END indicate bounds of region.
4457 optional arg, FORMAT, designates an alternate presentation form for
4460 list - Present prefix as numeric section.subsection..., starting with
4461 section indicated by the list, innermost nesting first.
4462 `indent' \(symbol) - Convert header prefixes to all white space,
4463 except for distinctive bullets.
4465 The elements of the list produced are lists that represents a topic
4466 header and body. The elements of that list are:
4468 - a number representing the depth of the topic,
4469 - a string representing the header-prefix, including trailing whitespace and
4471 - a string representing the bullet character,
4472 - and a series of strings, each containing one line of the exposed
4473 portion of the topic entry."
4478 ((inhibit-field-text-motion t
)
4480 strings prefix result depth new-depth out gone-out bullet beg
4485 ;; Goto initial topic, and register preceeding stuff, if any:
4486 (if (> (allout-goto-prefix) start
)
4487 ;; First topic follows beginning point - register preliminary stuff:
4488 (setq result
(list (list 0 "" nil
4489 (buffer-substring start
(1- (point)))))))
4490 (while (and (not done
)
4491 (not (eobp)) ; Loop until we've covered the region.
4492 (not (> (point) end
)))
4493 (setq depth
(allout-recent-depth) ; Current topics depth,
4494 bullet
(allout-recent-bullet) ; ... bullet,
4495 prefix
(allout-recent-prefix)
4496 beg
(progn (allout-end-of-prefix t
) (point))) ; and beginning.
4497 (setq done
; The boundary for the current topic:
4498 (not (allout-next-visible-heading 1)))
4499 (setq new-depth
(allout-recent-depth))
4501 out
(< new-depth depth
))
4506 (while (> next
(point)) ; Get all the exposed text in
4508 (cons (buffer-substring
4510 ;To hidden text or end of line:
4513 (allout-back-to-visible-text)))
4515 (when (< (point) next
) ; Resume from after hid text, if any.
4518 ;; Accumulate list for this topic:
4519 (setq strings
(nreverse strings
))
4523 (let ((special (if (string-match
4524 (regexp-quote bullet
)
4525 allout-distinctive-bullets-string
)
4527 (cond ((listp format
)
4529 (if allout-abbreviate-flattened-numbering
4530 (allout-stringify-flat-index format
4532 (allout-stringify-flat-index-plain
4536 ((eq format
'indent
)
4539 (concat (make-string (1+ depth
) ?
)
4540 (substring prefix -
1))
4543 (make-string depth ?
)
4545 (t (error "allout-listify-exposed: %s %s"
4546 "invalid format" format
))))
4547 (list depth prefix strings
))
4549 ;; Reasses format, if any:
4550 (if (and format
(listp format
))
4551 (cond ((= new-depth depth
)
4552 (setq format
(cons (1+ (car format
))
4554 ((> new-depth depth
) ; descending - assume by 1:
4555 (setq format
(cons 1 format
)))
4558 (while (< new-depth depth
)
4559 (setq format
(cdr format
))
4560 (setq depth
(1- depth
)))
4561 ; And increment the current one:
4563 (cons (1+ (or (car format
)
4566 ;; Put the list with first at front, to last at back:
4567 (nreverse result
))))
4568 ;;;_ > my-region-active-p ()
4569 (defmacro my-region-active-p
()
4570 (if (fboundp 'region-active-p
)
4573 ;;;_ > allout-process-exposed (&optional func from to frombuf
4575 (defun allout-process-exposed (&optional func from to frombuf tobuf
4577 "Map function on exposed parts of current topic; results to another buffer.
4579 All args are options; default values itemized below.
4581 Apply FUNCTION to exposed portions FROM position TO position in buffer
4582 FROMBUF to buffer TOBUF. Sixth optional arg, FORMAT, designates an
4583 alternate presentation form:
4585 `flat' - Present prefix as numeric section.subsection..., starting with
4586 section indicated by the start-num, innermost nesting first.
4587 X`flat-indented' - Prefix is like `flat' for first topic at each
4588 X level, but subsequent topics have only leaf topic
4589 X number, padded with blanks to line up with first.
4590 `indent' \(symbol) - Convert header prefixes to all white space,
4591 except for distinctive bullets.
4594 FUNCTION: `allout-insert-listified'
4595 FROM: region start, if region active, else start of buffer
4596 TO: region end, if region active, else end of buffer
4597 FROMBUF: current buffer
4598 TOBUF: buffer name derived: \"*current-buffer-name exposed*\"
4601 ; Resolve arguments,
4602 ; defaulting if necessary:
4603 (if (not func
) (setq func
'allout-insert-listified
))
4604 (if (not (and from to
))
4605 (if (my-region-active-p)
4606 (setq from
(region-beginning) to
(region-end))
4607 (setq from
(point-min) to
(point-max))))
4609 (if (not (bufferp frombuf
))
4610 ;; Specified but not a buffer - get it:
4611 (let ((got (get-buffer frombuf
)))
4613 (error (concat "allout-process-exposed: source buffer "
4616 (setq frombuf got
))))
4617 ;; not specified - default it:
4618 (setq frombuf
(current-buffer)))
4620 (if (not (bufferp tobuf
))
4621 (setq tobuf
(get-buffer-create tobuf
)))
4622 ;; not specified - default it:
4623 (setq tobuf
(concat "*" (buffer-name frombuf
) " exposed*")))
4628 (progn (set-buffer frombuf
)
4629 (allout-listify-exposed from to format
))))
4631 (mapcar func listified
)
4632 (pop-to-buffer tobuf
)))
4635 ;;;_ > allout-insert-listified (listified)
4636 (defun allout-insert-listified (listified)
4637 "Insert contents of listified outline portion in current buffer.
4639 LISTIFIED is a list representing each topic header and body:
4641 \`(depth prefix text)'
4643 or \`(depth prefix text bullet-plus)'
4645 If `bullet-plus' is specified, it is inserted just after the entire prefix."
4646 (setq listified
(cdr listified
))
4647 (let ((prefix (prog1
4649 (setq listified
(cdr listified
))))
4652 (setq listified
(cdr listified
))))
4653 (bullet-plus (car listified
)))
4655 (if bullet-plus
(insert (concat " " bullet-plus
)))
4658 (if (setq text
(cdr text
))
4661 ;;;_ > allout-copy-exposed-to-buffer (&optional arg tobuf format)
4662 (defun allout-copy-exposed-to-buffer (&optional arg tobuf format
)
4663 "Duplicate exposed portions of current outline to another buffer.
4665 Other buffer has current buffers name with \" exposed\" appended to it.
4667 With repeat count, copy the exposed parts of only the current topic.
4669 Optional second arg TOBUF is target buffer name.
4671 Optional third arg FORMAT, if non-nil, symbolically designates an
4672 alternate presentation format for the outline:
4674 `flat' - Convert topic header prefixes to numeric
4675 section.subsection... identifiers.
4676 `indent' - Convert header prefixes to all white space, except for
4677 distinctive bullets.
4678 `indent-flat' - The best of both - only the first of each level has
4679 the full path, the rest have only the section number
4680 of the leaf, preceded by the right amount of indentation."
4684 (setq tobuf
(get-buffer-create (concat "*" (buffer-name) " exposed*"))))
4685 (let* ((start-pt (point))
4686 (beg (if arg
(allout-back-to-current-heading) (point-min)))
4687 (end (if arg
(allout-end-of-current-subtree) (point-max)))
4688 (buf (current-buffer))
4690 (if (eq format
'flat
)
4691 (setq format
(if arg
(save-excursion
4693 (allout-topic-flat-index))
4695 (save-excursion (set-buffer tobuf
)(erase-buffer))
4696 (allout-process-exposed 'allout-insert-listified
4702 (goto-char (point-min))
4704 (goto-char start-pt
)))
4705 ;;;_ > allout-flatten-exposed-to-buffer (&optional arg tobuf)
4706 (defun allout-flatten-exposed-to-buffer (&optional arg tobuf
)
4707 "Present numeric outline of outline's exposed portions in another buffer.
4709 The resulting outline is not compatible with outline mode - use
4710 `allout-copy-exposed-to-buffer' if you want that.
4712 Use `allout-indented-exposed-to-buffer' for indented presentation.
4714 With repeat count, copy the exposed portions of only current topic.
4716 Other buffer has current buffer's name with \" exposed\" appended to
4717 it, unless optional second arg TOBUF is specified, in which case it is
4720 (allout-copy-exposed-to-buffer arg tobuf
'flat
))
4721 ;;;_ > allout-indented-exposed-to-buffer (&optional arg tobuf)
4722 (defun allout-indented-exposed-to-buffer (&optional arg tobuf
)
4723 "Present indented outline of outline's exposed portions in another buffer.
4725 The resulting outline is not compatible with outline mode - use
4726 `allout-copy-exposed-to-buffer' if you want that.
4728 Use `allout-flatten-exposed-to-buffer' for numeric sectional presentation.
4730 With repeat count, copy the exposed portions of only current topic.
4732 Other buffer has current buffer's name with \" exposed\" appended to
4733 it, unless optional second arg TOBUF is specified, in which case it is
4736 (allout-copy-exposed-to-buffer arg tobuf
'indent
))
4738 ;;;_ - LaTeX formatting
4739 ;;;_ > allout-latex-verb-quote (string &optional flow)
4740 (defun allout-latex-verb-quote (string &optional flow
)
4741 "Return copy of STRING for literal reproduction across LaTeX processing.
4742 Expresses the original characters \(including carriage returns) of the
4743 string across LaTeX processing."
4744 (mapconcat (function
4746 (cond ((memq char
'(?
\\ ?$ ?% ?
# ?
& ?
{ ?
} ?_ ?^ ?- ?
*))
4747 (concat "\\char" (number-to-string char
) "{}"))
4748 ((= char ?
\n) "\\\\")
4749 (t (char-to-string char
)))))
4752 ;;;_ > allout-latex-verbatim-quote-curr-line ()
4753 (defun allout-latex-verbatim-quote-curr-line ()
4754 "Express line for exact \(literal) representation across LaTeX processing.
4756 Adjust line contents so it is unaltered \(from the original line)
4757 across LaTeX processing, within the context of a `verbatim'
4758 environment. Leaves point at the end of the line."
4759 (let ((inhibit-field-text-motion t
))
4762 (end (progn (end-of-line)(point))))
4764 (while (re-search-forward "\\\\"
4765 ;;"\\\\\\|\\{\\|\\}\\|\\_\\|\\$\\|\\\"\\|\\&\\|\\^\\|\\-\\|\\*\\|#"
4766 end
; bounded by end-of-line
4767 1) ; no matches, move to end & return nil
4768 (goto-char (match-beginning 0))
4771 (goto-char (1+ (match-end 0)))))))
4772 ;;;_ > allout-insert-latex-header (buffer)
4773 (defun allout-insert-latex-header (buffer)
4774 "Insert initial LaTeX commands at point in BUFFER."
4775 ;; Much of this is being derived from the stuff in appendix of E in
4776 ;; the TeXBook, pg 421.
4778 (let ((doc-style (format "\n\\documentstyle{%s}\n"
4780 (page-numbering (if allout-number-pages
4781 "\\pagestyle{empty}\n"
4783 (titlecmd (format "\\newcommand{\\titlecmd}[1]{{%s #1}}\n"
4784 allout-title-style
))
4785 (labelcmd (format "\\newcommand{\\labelcmd}[1]{{%s #1}}\n"
4786 allout-label-style
))
4787 (headlinecmd (format "\\newcommand{\\headlinecmd}[1]{{%s #1}}\n"
4788 allout-head-line-style
))
4789 (bodylinecmd (format "\\newcommand{\\bodylinecmd}[1]{{%s #1}}\n"
4790 allout-body-line-style
))
4791 (setlength (format "%s%s%s%s"
4792 "\\newlength{\\stepsize}\n"
4793 "\\setlength{\\stepsize}{"
4796 (oneheadline (format "%s%s%s%s%s%s%s"
4797 "\\newcommand{\\OneHeadLine}[3]{%\n"
4799 "\\hspace*{#2\\stepsize}%\n"
4800 "\\labelcmd{#1}\\hspace*{.2cm}"
4801 "\\headlinecmd{#3}\\\\["
4804 (onebodyline (format "%s%s%s%s%s%s"
4805 "\\newcommand{\\OneBodyLine}[2]{%\n"
4807 "\\hspace*{#1\\stepsize}%\n"
4808 "\\bodylinecmd{#2}\\\\["
4811 (begindoc "\\begin{document}\n\\begin{center}\n")
4812 (title (format "%s%s%s%s"
4814 (allout-latex-verb-quote (if allout-title
4817 ('error
"<unnamed buffer>"))
4820 "\\end{center}\n\n"))
4821 (hsize "\\hsize = 7.5 true in\n")
4822 (hoffset "\\hoffset = -1.5 true in\n")
4823 (vspace "\\vspace{.1cm}\n\n"))
4824 (insert (concat doc-style
4839 ;;;_ > allout-insert-latex-trailer (buffer)
4840 (defun allout-insert-latex-trailer (buffer)
4841 "Insert concluding LaTeX commands at point in BUFFER."
4843 (insert "\n\\end{document}\n"))
4844 ;;;_ > allout-latexify-one-item (depth prefix bullet text)
4845 (defun allout-latexify-one-item (depth prefix bullet text
)
4846 "Insert LaTeX commands for formatting one outline item.
4848 Args are the topics numeric DEPTH, the header PREFIX lead string, the
4849 BULLET string, and a list of TEXT strings for the body."
4850 (let* ((head-line (if text
(car text
)))
4851 (body-lines (cdr text
))
4855 (insert (concat "\\OneHeadLine{\\verb\1 "
4856 (allout-latex-verb-quote bullet
)
4861 (allout-latex-verb-quote head-line
)
4864 (if (not body-lines
)
4866 ;;(insert "\\beginlines\n")
4867 (insert "\\begin{verbatim}\n")
4869 (setq curr-line
(car body-lines
))
4870 (if (and (not body-content
)
4871 (not (string-match "^\\s-*$" curr-line
)))
4872 (setq body-content t
))
4873 ; Mangle any occurrences of
4874 ; "\end{verbatim}" in text,
4876 (if (and body-content
4877 (setq bop
(string-match "\\end{verbatim}" curr-line
)))
4878 (setq curr-line
(concat (substring curr-line
0 bop
)
4880 (substring curr-line bop
))))
4881 ;;(insert "|" (car body-lines) "|")
4883 (allout-latex-verbatim-quote-curr-line)
4885 (setq body-lines
(cdr body-lines
)))
4887 (setq body-content nil
)
4891 ;;(insert "\\endlines\n")
4892 (insert "\\end{verbatim}\n")
4894 ;;;_ > allout-latexify-exposed (arg &optional tobuf)
4895 (defun allout-latexify-exposed (arg &optional tobuf
)
4896 "Format current topics exposed portions to TOBUF for LaTeX processing.
4897 TOBUF defaults to a buffer named the same as the current buffer, but
4898 with \"*\" prepended and \" latex-formed*\" appended.
4900 With repeat count, copy the exposed portions of entire buffer."
4905 (get-buffer-create (concat "*" (buffer-name) " latexified*"))))
4906 (let* ((start-pt (point))
4907 (beg (if arg
(point-min) (allout-back-to-current-heading)))
4908 (end (if arg
(point-max) (allout-end-of-current-subtree)))
4909 (buf (current-buffer)))
4912 (allout-insert-latex-header tobuf
)
4913 (goto-char (point-max))
4914 (allout-process-exposed 'allout-latexify-one-item
4919 (goto-char (point-max))
4920 (allout-insert-latex-trailer tobuf
)
4921 (goto-char (point-min))
4923 (goto-char start-pt
)))
4926 ;;;_ > allout-toggle-current-subtree-encryption (&optional fetch-pass)
4927 (defun allout-toggle-current-subtree-encryption (&optional fetch-pass
)
4928 "Encrypt clear or decrypt encoded text of visibly-containing topic's contents.
4930 Optional FETCH-PASS universal argument provokes key-pair encryption with
4931 single universal argument. With doubled universal argument \(value = 16),
4932 it forces prompting for the passphrase regardless of availability from the
4933 passphrase cache. With no universal argument, the appropriate passphrase
4934 is obtained from the cache, if available, else from the user.
4936 Currently only GnuPG encryption is supported.
4938 \**NOTE WELL** that the encrypted text must be ascii-armored. For gnupg
4939 encryption, include the option ``armor'' in your ~/.gnupg/gpg.conf file.
4941 Both symmetric-key and key-pair encryption is implemented. Symmetric is
4942 the default, use a single \(x4) universal argument for keypair mode.
4944 Encrypted topic's bullet is set to a `~' to signal that the contents of the
4945 topic \(body and subtopics, but not heading) is pending encryption or
4946 encrypted. `*' asterisk immediately after the bullet signals that the body
4947 is encrypted, its' absence means the topic is meant to be encrypted but is
4948 not. When a file with topics pending encryption is saved, topics pending
4949 encryption are encrypted. See allout-encrypt-unencrypted-on-saves for
4950 auto-encryption specifics.
4952 \**NOTE WELL** that automatic encryption that happens during saves will
4953 default to symmetric encryption - you must manually \(re)encrypt key-pair
4954 encrypted topics if you want them to continue to use the key-pair cipher.
4956 Level-1 topics, with prefix consisting solely of an `*' asterisk, cannot be
4957 encrypted. If you want to encrypt the contents of a top-level topic, use
4958 \\[allout-shift-in] to increase its depth.
4962 The encryption passphrase is solicited if not currently available in the
4963 passphrase cache from a recent encryption action.
4965 The solicited passphrase is retained for reuse in a buffer-specific cache
4966 for some set period of time \(default, 60 seconds), after which the string
4967 is nulled. The passphrase cache timeout is customized by setting
4968 `pgg-passphrase-cache-expiry'.
4970 Symmetric Passphrase Hinting and Verification
4972 If the file previously had no associated passphrase, or had a different
4973 passphrase than specified, the user is prompted to repeat the new one for
4974 corroboration. A random string encrypted by the new passphrase is set on
4975 the buffer-specific variable `allout-passphrase-verifier-string', for
4976 confirmation of the passphrase when next obtained, before encrypting or
4977 decrypting anything with it. This helps avoid mistakenly shifting between
4980 If allout customization var `allout-passphrase-verifier-handling' is
4981 non-nil, an entry for `allout-passphrase-verifier-string' and its value is
4982 added to an Emacs 'local variables' section at the end of the file, which
4983 is created if necessary. That setting is for retention of the passphrase
4984 verifier across emacs sessions.
4986 Similarly, `allout-passphrase-hint-string' stores a user-provided reminder
4987 about their passphrase, and `allout-passphrase-hint-handling' specifies
4988 when the hint is presented, or if passphrase hints are disabled. If
4989 enabled \(see the `allout-passphrase-hint-handling' docstring for details),
4990 the hint string is stored in the local-variables section of the file, and
4991 solicited whenever the passphrase is changed."
4994 (allout-back-to-current-heading)
4995 (allout-toggle-subtree-encryption fetch-pass
)
4998 ;;;_ > allout-toggle-subtree-encryption (&optional fetch-pass)
4999 (defun allout-toggle-subtree-encryption (&optional fetch-pass
)
5000 "Encrypt clear text or decrypt encoded topic contents \(body and subtopics.)
5002 Optional FETCH-PASS universal argument provokes key-pair encryption with
5003 single universal argument. With doubled universal argument \(value = 16),
5004 it forces prompting for the passphrase regardless of availability from the
5005 passphrase cache. With no universal argument, the appropriate passphrase
5006 is obtained from the cache, if available, else from the user.
5008 Currently only GnuPG encryption is supported.
5010 \**NOTE WELL** that the encrypted text must be ascii-armored. For gnupg
5011 encryption, include the option ``armor'' in your ~/.gnupg/gpg.conf file.
5013 See `allout-toggle-current-subtree-encryption' for more details."
5017 (allout-end-of-prefix t
)
5019 (if (= (allout-recent-depth) 1)
5020 (error (concat "Cannot encrypt or decrypt level 1 topics -"
5021 " shift it in to make it encryptable")))
5023 (let* ((allout-buffer (current-buffer))
5025 (after-bullet-pos (point))
5027 (progn (if (= (point-max) after-bullet-pos
)
5028 (error "no body to encrypt"))
5029 (allout-encrypted-topic-p)))
5030 (was-collapsed (if (not (search-forward "\n" nil t
))
5034 (subtree-beg (1+ (point)))
5035 (subtree-end (allout-end-of-subtree))
5036 (subject-text (buffer-substring-no-properties subtree-beg
5038 (subtree-end-char (char-after (1- subtree-end
)))
5039 (subtree-trailing-char (char-after subtree-end
))
5040 ;; kluge - result-text needs to be nil, but we also want to
5041 ;; check for the error condition
5042 (result-text (if (or (string= "" subject-text
)
5043 (string= "\n" subject-text
))
5044 (error "No topic contents to %scrypt"
5045 (if was-encrypted
"de" "en"))
5047 ;; Assess key parameters:
5049 ;; detect the type by which it is already encrypted
5051 (allout-encrypted-key-info subject-text
))
5052 (and (member fetch-pass
'(4 (4)))
5055 (for-key-type (car key-info
))
5056 (for-key-identity (cadr key-info
))
5057 (fetch-pass (and fetch-pass
(member fetch-pass
'(16 (16))))))
5060 (allout-encrypt-string subject-text was-encrypted
5062 for-key-type for-key-identity fetch-pass
))
5064 ;; Replace the subtree with the processed product.
5067 (set-buffer allout-buffer
)
5068 (delete-region subtree-beg subtree-end
)
5069 (insert result-text
)
5071 (allout-flag-region (1- subtree-beg
) (point) t
))
5072 ;; adjust trailing-blank-lines to preserve topic spacing:
5073 (if (not was-encrypted
)
5074 (if (and (= subtree-end-char ?
\n)
5075 (= subtree-trailing-char ?
\n))
5076 (insert subtree-trailing-char
)))
5077 ;; Ensure that the item has an encrypted-entry bullet:
5078 (if (not (string= (buffer-substring-no-properties
5079 (1- after-bullet-pos
) after-bullet-pos
)
5080 allout-topic-encryption-bullet
))
5081 (progn (goto-char (1- after-bullet-pos
))
5083 (insert allout-topic-encryption-bullet
)))
5085 ;; Remove the is-encrypted bullet qualifier:
5086 (progn (goto-char after-bullet-pos
)
5088 ;; Add the is-encrypted bullet qualifier:
5089 (goto-char after-bullet-pos
)
5096 ;;;_ > allout-encrypt-string (text decrypt allout-buffer key-type for-key
5097 ;;; fetch-pass &optional retried verifying
5099 (defun allout-encrypt-string (text decrypt allout-buffer key-type for-key
5100 fetch-pass
&optional retried verifying
5102 "Encrypt or decrypt message TEXT.
5104 If DECRYPT is true (default false), then decrypt instead of encrypt.
5106 FETCH-PASS (default false) forces fresh prompting for the passphrase.
5108 KEY-TYPE indicates whether to use a 'symmetric or 'keypair cipher.
5110 FOR-KEY is human readable identification of the first of the user's
5111 eligible secret keys a keypair decryption targets, or else nil.
5113 Optional RETRIED is for internal use - conveys the number of failed keys
5114 that have been solicited in sequence leading to this current call.
5116 Optional PASSPHRASE enables explicit delivery of the decryption passphrase,
5117 for verification purposes.
5119 Returns the resulting string, or nil if the transformation fails."
5123 (if (not (fboundp 'pgg-encrypt-symmetric
))
5124 (error "Allout encryption depends on a newer version of pgg"))
5126 (let* ((scheme (upcase
5127 (format "%s" (or pgg-scheme pgg-default-scheme
"GPG"))))
5128 (for-key (and (equal key-type
'keypair
)
5130 (split-string (read-string
5131 (format "%s message recipients: "
5134 (target-prompt-id (if (equal key-type
'keypair
)
5135 (if (= (length for-key
) 1)
5136 (car for-key
) for-key
)
5137 (buffer-name allout-buffer
)))
5138 (target-cache-id (format "%s-%s"
5140 (if (equal key-type
'keypair
)
5142 (or (buffer-file-name allout-buffer
)
5143 target-prompt-id
))))
5146 (if (and fetch-pass
(not passphrase
))
5147 ;; Force later fetch by evicting passphrase from the cache.
5148 (pgg-remove-passphrase-from-cache target-cache-id t
))
5150 (catch 'encryption-failed
5152 ;; Obtain the passphrase if we don't already have one and we're not
5153 ;; doing a keypair encryption:
5154 (if (not (or passphrase
5155 (and (equal key-type
'keypair
)
5158 (setq passphrase
(allout-obtain-passphrase for-key
5163 retried fetch-pass
)))
5171 ((equal key-type
'symmetric
)
5175 (pgg-decrypt (point-min) (point-max) passphrase
)
5177 (pgg-encrypt-symmetric (point-min) (point-max)
5181 (pgg-situate-output (point-min) (point-max))
5182 ;; failed - handle passphrase caching
5184 (throw 'encryption-failed nil
)
5185 (pgg-remove-passphrase-from-cache target-cache-id t
)
5186 (error "Symmetric-cipher encryption failed - %s"
5187 "try again with different passphrase."))))
5189 ;; encrypt 'keypair:
5194 (pgg-encrypt for-key
5195 nil
(point-min) (point-max) passphrase
))
5198 (pgg-situate-output (point-min) (point-max))
5199 (error (pgg-remove-passphrase-from-cache target-cache-id t
)
5200 (error "encryption failed"))))
5202 ;; decrypt 'keypair:
5206 (pgg-decrypt (point-min) (point-max) passphrase
))
5209 (pgg-situate-output (point-min) (point-max))
5210 (error (pgg-remove-passphrase-from-cache target-cache-id t
)
5211 (error "decryption failed"))))
5215 (buffer-substring 1 (- (point-max) (if decrypt
0 1))))
5217 ;; validate result - non-empty
5218 (cond ((not result-text
)
5221 ;; transform was fruitless, retry w/new passphrase.
5222 (pgg-remove-passphrase-from-cache target-cache-id t
)
5223 (allout-encrypt-string text allout-buffer decrypt nil
5224 (if retried
(1+ retried
) 1)
5227 ;; Barf if encryption yields extraordinary control chars:
5229 (string-match "[\C-a\C-k\C-o-\C-z\C-@]"
5231 (error (concat "encryption produced unusable"
5232 " non-armored text - reconfigure!")))
5234 ;; valid result and just verifying or non-symmetric:
5235 ((or verifying
(not (equal key-type
'symmetric
)))
5236 (if (or verifying decrypt
)
5237 (pgg-add-passphrase-to-cache target-cache-id
5241 ;; valid result and regular symmetric - "register"
5242 ;; passphrase with mnemonic aids/cache.
5244 (set-buffer allout-buffer
)
5246 (pgg-add-passphrase-to-cache target-cache-id
5248 (allout-update-passphrase-mnemonic-aids for-key passphrase
5256 ;;;_ > allout-obtain-passphrase (for-key cache-id prompt-id key-type
5257 ;;; allout-buffer retried fetch-pass)
5258 (defun allout-obtain-passphrase (for-key cache-id prompt-id key-type
5259 allout-buffer retried fetch-pass
)
5260 "Obtain passphrase for a key from the cache or else from the user.
5262 When obtaining from the user, symmetric-cipher passphrases are verified
5263 against either, if available and enabled, a random string that was
5264 encrypted against the passphrase, or else against repeated entry by the
5265 user for corroboration.
5267 FOR-KEY is the key for which the passphrase is being obtained.
5269 CACHE-ID is the cache id of the key for the passphrase.
5271 PROMPT-ID is the id for use when prompting the user.
5273 KEY-TYPE is either 'symmetric or 'keypair.
5275 ALLOUT-BUFFER is the buffer containing the entry being en/decrypted.
5277 RETRIED is the number of this attempt to obtain this passphrase.
5279 FETCH-PASS causes the passphrase to be solicited from the user, regardless
5280 of the availability of a cached copy."
5282 (if (not (equal key-type
'symmetric
))
5283 ;; do regular passphrase read on non-symmetric passphrase:
5284 (pgg-read-passphrase (format "%s passphrase%s: "
5285 (upcase (format "%s" (or pgg-scheme
5289 (format " for %s" prompt-id
)
5293 ;; Symmetric hereon:
5296 (set-buffer allout-buffer
)
5297 (let* ((hint (if (and (not (string= allout-passphrase-hint-string
""))
5298 (or (equal allout-passphrase-hint-handling
'always
)
5299 (and (equal allout-passphrase-hint-handling
5302 (format " [%s]" allout-passphrase-hint-string
)
5304 (retry-message (if retried
(format " (%s retry)" retried
) ""))
5305 (prompt-sans-hint (format "'%s' symmetric passphrase%s: "
5306 prompt-id retry-message
))
5307 (full-prompt (format "'%s' symmetric passphrase%s%s: "
5308 prompt-id hint retry-message
))
5309 (prompt full-prompt
)
5310 (verifier-string (allout-get-encryption-passphrase-verifier))
5312 (cached (and (not fetch-pass
)
5313 (pgg-read-passphrase-from-cache cache-id t
)))
5314 (got-pass (or cached
5315 (pgg-read-passphrase full-prompt cache-id t
)))
5322 ;; Duplicate our handle on the passphrase so it's not clobbered by
5323 ;; deactivate-passwd memory clearing:
5324 (setq got-pass
(format "%s" got-pass
))
5326 (cond (verifier-string
5327 (save-window-excursion
5328 (if (allout-encrypt-string verifier-string
'decrypt
5329 allout-buffer
'symmetric
5330 for-key nil
0 'verifying
5332 (setq confirmation
(format "%s" got-pass
))))
5334 (if (and (not confirmation
)
5336 (concat "Passphrase differs from established"
5337 " - use new one instead? "))
5338 ;; deactivate password for subsequent
5341 (pgg-remove-passphrase-from-cache cache-id t
)
5342 (setq prompt prompt-sans-hint
)
5345 (progn (pgg-remove-passphrase-from-cache cache-id t
)
5346 (error "Wrong passphrase."))))
5347 ;; No verifier string - force confirmation by repetition of
5348 ;; (new) passphrase:
5349 ((or fetch-pass
(not cached
))
5350 (pgg-remove-passphrase-from-cache cache-id t
))))
5351 ;; confirmation vs new input - doing pgg-read-passphrase will do the
5352 ;; right thing, in either case:
5353 (if (not confirmation
)
5355 (pgg-read-passphrase (concat prompt
5356 " ... confirm spelling: ")
5359 (if (equal got-pass confirmation
)
5361 (if (yes-or-no-p (concat "spelling of original and"
5362 " confirmation differ - retry? "))
5363 (progn (setq retried
(if retried
(1+ retried
) 1))
5364 (pgg-remove-passphrase-from-cache cache-id t
)
5365 ;; recurse to this routine:
5366 (pgg-read-passphrase prompt-sans-hint cache-id t
))
5367 (pgg-remove-passphrase-from-cache cache-id t
)
5368 (error "Confirmation failed.")))
5369 ;; reduce opportunity for memory cherry-picking by zeroing duplicate:
5370 (dotimes (i (length got-pass
))
5371 (aset got-pass i
0))
5377 ;;;_ > allout-encrypted-topic-p ()
5378 (defun allout-encrypted-topic-p ()
5379 "True if the current topic is encryptable and encrypted."
5381 (allout-end-of-prefix t
)
5382 (and (string= (buffer-substring-no-properties (1- (point)) (point))
5383 allout-topic-encryption-bullet
)
5387 ;;;_ > allout-encrypted-key-info (text)
5388 ;; XXX gpg-specific, alas
5389 (defun allout-encrypted-key-info (text)
5390 "Return a pair of the key type and identity of a recipient's secret key.
5392 The key type is one of 'symmetric or 'keypair.
5394 if 'keypair, and some of the user's secret keys are among those for which
5395 the message was encoded, return the identity of the first. otherwise,
5396 return nil for the second item of the pair.
5398 An error is raised if the text is not encrypted."
5399 (require 'pgg-parse
)
5403 (let* ((parsed-armor (pgg-parse-armor-region (point-min) (point-max)))
5404 (type (if (pgg-gpg-symmetric-key-p parsed-armor
)
5407 secret-keys first-secret-key for-key-owner
)
5408 (if (equal type
'keypair
)
5409 (setq secret-keys
(pgg-gpg-lookup-all-secret-keys)
5410 first-secret-key
(pgg-gpg-select-matching-key parsed-armor
5412 for-key-owner
(and first-secret-key
5413 (pgg-gpg-lookup-key-owner
5414 first-secret-key
))))
5415 (list type
(pgg-gpg-key-id-from-key-owner for-key-owner
))
5420 ;;;_ > allout-create-encryption-passphrase-verifier (passphrase)
5421 (defun allout-create-encryption-passphrase-verifier (passphrase)
5422 "Encrypt random message for later validation of symmetric key's passphrase."
5423 ;; use 20 random ascii characters, across the entire ascii range.
5425 (let ((spew (make-string 20 ?\
0)))
5426 (dotimes (i (length spew
))
5427 (aset spew i
(1+ (random 254))))
5428 (allout-encrypt-string spew nil
(current-buffer) 'symmetric
5429 nil nil
0 passphrase
))
5431 ;;;_ > allout-update-passphrase-mnemonic-aids (for-key passphrase
5433 (defun allout-update-passphrase-mnemonic-aids (for-key passphrase
5435 "Update passphrase verifier and hint strings if necessary.
5437 See `allout-passphrase-verifier-string' and `allout-passphrase-hint-string'
5440 PASSPHRASE is the passphrase being mnemonicized
5442 OUTLINE-BUFFER is the buffer of the outline being adjusted.
5444 These are used to help the user keep track of the passphrase they use for
5445 symmetric encryption in the file.
5447 Behavior is governed by `allout-passphrase-verifier-handling',
5448 `allout-passphrase-hint-handling', and also, controlling whether the values
5449 are preserved on Emacs local file variables,
5450 `allout-enable-file-variable-adjustment'."
5452 ;; If passphrase doesn't agree with current verifier:
5453 ;; - adjust the verifier
5454 ;; - if passphrase hint handling is enabled, adjust the passphrase hint
5455 ;; - if file var settings are enabled, adjust the file vars
5457 (let* ((new-verifier-needed (not (allout-verify-passphrase
5458 for-key passphrase outline-buffer
)))
5459 (new-verifier-string
5460 (if new-verifier-needed
5461 ;; Collapse to a single line and enclose in string quotes:
5462 (subst-char-in-string
5463 ?
\n ?\C-a
(allout-create-encryption-passphrase-verifier
5466 (when new-verifier-string
5467 ;; do the passphrase hint first, since it's interactive
5468 (when (and allout-passphrase-hint-handling
5469 (not (equal allout-passphrase-hint-handling
'disabled
)))
5471 (read-from-minibuffer "Passphrase hint to jog your memory: "
5472 allout-passphrase-hint-string
))
5473 (when (not (string= new-hint allout-passphrase-hint-string
))
5474 (setq allout-passphrase-hint-string new-hint
)
5475 (allout-adjust-file-variable "allout-passphrase-hint-string"
5476 allout-passphrase-hint-string
)))
5477 (when allout-passphrase-verifier-handling
5478 (setq allout-passphrase-verifier-string new-verifier-string
)
5479 (allout-adjust-file-variable "allout-passphrase-verifier-string"
5480 allout-passphrase-verifier-string
))
5484 ;;;_ > allout-get-encryption-passphrase-verifier ()
5485 (defun allout-get-encryption-passphrase-verifier ()
5486 "Return text of the encrypt passphrase verifier, unmassaged, or nil if none.
5488 Derived from value of `allout-passphrase-verifier-string'."
5490 (let ((verifier-string (and (boundp 'allout-passphrase-verifier-string
)
5491 allout-passphrase-verifier-string
)))
5493 ;; Return it uncollapsed
5494 (subst-char-in-string ?\C-a ?
\n verifier-string
))
5497 ;;;_ > allout-verify-passphrase (key passphrase allout-buffer)
5498 (defun allout-verify-passphrase (key passphrase allout-buffer
)
5499 "True if passphrase successfully decrypts verifier, nil otherwise.
5501 \"Otherwise\" includes absence of passphrase verifier."
5503 (set-buffer allout-buffer
)
5504 (and (boundp 'allout-passphrase-verifier-string
)
5505 allout-passphrase-verifier-string
5506 (allout-encrypt-string (allout-get-encryption-passphrase-verifier)
5507 'decrypt allout-buffer
'symmetric
5508 key nil
0 'verifying passphrase
)
5510 ;;;_ > allout-next-topic-pending-encryption (&optional except-mark)
5511 (defun allout-next-topic-pending-encryption (&optional except-mark
)
5512 "Return the point of the next topic pending encryption, or nil if none.
5514 EXCEPT-MARK identifies a point whose containing topics should be excluded
5515 from encryption. This supports 'except-current mode of
5516 `allout-encrypt-unencrypted-on-saves'.
5518 Such a topic has the allout-topic-encryption-bullet without an
5519 immediately following '*' that would mark the topic as being encrypted. It
5520 must also have content."
5521 (let (done got content-beg
)
5524 (if (not (re-search-forward
5525 (format "\\(\\`\\|\n\\)%s *%s[^*]"
5526 (regexp-quote allout-header-prefix
)
5527 (regexp-quote allout-topic-encryption-bullet
))
5531 (goto-char (setq got
(match-beginning 0)))
5532 (if (looking-at "\n")
5539 ((not (search-forward "\n"))
5548 (setq content-beg
(point))
5550 (allout-end-of-subtree)
5551 (if (or (<= (point) content-beg
)
5553 (<= content-beg except-mark
)
5554 (>= (point) except-mark
)))
5565 ;;;_ > allout-encrypt-decrypted (&optional except-mark)
5566 (defun allout-encrypt-decrypted (&optional except-mark
)
5567 "Encrypt topics pending encryption except those containing exemption point.
5569 EXCEPT-MARK identifies a point whose containing topics should be excluded
5570 from encryption. This supports 'except-current mode of
5571 `allout-encrypt-unencrypted-on-saves'.
5573 If a topic that is currently being edited was encrypted, we return a list
5574 containing the location of the topic and the location of the cursor just
5575 before the topic was encrypted. This can be used, eg, to decrypt the topic
5576 and exactly resituate the cursor if this is being done as part of a file
5577 save. See `allout-encrypt-unencrypted-on-saves' for more info."
5581 (let* ((current-mark (point-marker))
5582 (current-mark-position (marker-position current-mark
))
5585 editing-topic editing-point
)
5586 (goto-char (point-min))
5587 (while (allout-next-topic-pending-encryption except-mark
)
5588 (setq was-modified
(buffer-modified-p))
5589 (when (save-excursion
5590 (and (boundp 'allout-encrypt-unencrypted-on-saves
)
5591 allout-encrypt-unencrypted-on-saves
5592 (setq bo-subtree
(re-search-forward "$"))
5593 (not (allout-hidden-p))
5594 (>= current-mark
(point))
5595 (allout-end-of-current-subtree)
5596 (<= current-mark
(point))))
5597 (setq editing-topic
(point)
5598 ;; we had to wait for this 'til now so prior topics are
5599 ;; encrypted, any relevant text shifts are in place:
5600 editing-point
(- current-mark-position
5601 (count-trailing-whitespace-region
5602 bo-subtree current-mark-position
))))
5603 (allout-toggle-subtree-encryption)
5604 (if (not was-modified
)
5605 (set-buffer-modified-p nil
))
5607 (if (not was-modified
)
5608 (set-buffer-modified-p nil
))
5609 (if editing-topic
(list editing-topic editing-point
))
5614 ;;;_ #9 miscellaneous
5615 ;;;_ > allout-mark-topic ()
5616 (defun allout-mark-topic ()
5617 "Put the region around topic currently containing point."
5619 (let ((inhibit-field-text-motion t
))
5620 (beginning-of-line))
5621 (allout-goto-prefix)
5623 (allout-end-of-current-subtree)
5624 (exchange-point-and-mark))
5625 ;;;_ > outlineify-sticky ()
5626 ;; outlinify-sticky is correct spelling; provide this alias for sticklers:
5628 (defalias 'outlinify-sticky
'outlineify-sticky
)
5630 (defun outlineify-sticky (&optional arg
)
5631 "Activate outline mode and establish file var so it is started subsequently.
5633 See doc-string for `allout-layout' and `allout-init' for details on
5634 setup for auto-startup."
5641 (goto-char (point-min))
5642 (if (looking-at allout-regexp
)
5644 (allout-open-topic 2)
5645 (insert (concat "Dummy outline topic header - see"
5646 "`allout-mode' docstring: `^Hm'."))
5647 (allout-adjust-file-variable
5648 "allout-layout" (or allout-layout
'(-1 : 0))))))
5649 ;;;_ > allout-file-vars-section-data ()
5650 (defun allout-file-vars-section-data ()
5651 "Return data identifying the file-vars section, or nil if none.
5653 Returns list `(beginning-point prefix-string suffix-string)'."
5654 ;; minimally gleaned from emacs 21.4 files.el hack-local-variables function.
5655 (let (beg prefix suffix
)
5657 (goto-char (point-max))
5658 (search-backward "\n\^L" (max (- (point-max) 3000) (point-min)) 'move
)
5659 (if (let ((case-fold-search t
))
5660 (not (search-forward "Local Variables:" nil t
)))
5662 (setq beg
(- (point) 16))
5663 (setq suffix
(buffer-substring-no-properties
5665 (progn (if (search-forward "\n" nil t
)
5668 (setq prefix
(buffer-substring-no-properties
5669 (progn (if (search-backward "\n" nil t
)
5673 (list beg prefix suffix
))
5677 ;;;_ > allout-adjust-file-variable (varname value)
5678 (defun allout-adjust-file-variable (varname value
)
5679 "Adjust the setting of an emacs file variable named VARNAME to VALUE.
5681 This activity is inhibited if either `enable-local-variables'
5682 `allout-enable-file-variable-adjustment' are nil.
5684 When enabled, an entry for the variable is created if not already present,
5685 or changed if established with a different value. The section for the file
5686 variables, itself, is created if not already present. When created, the
5687 section lines \(including the section line) exist as second-level topics in
5688 a top-level topic at the end of the file.
5690 enable-local-variables must be true for any of this to happen."
5691 (if (not (and enable-local-variables
5692 allout-enable-file-variable-adjustment
))
5695 (let ((inhibit-field-text-motion t
)
5696 (section-data (allout-file-vars-section-data))
5699 (setq beg
(car section-data
)
5700 prefix
(cadr section-data
)
5701 suffix
(car (cddr section-data
)))
5702 ;; create the section
5703 (goto-char (point-max))
5705 (allout-open-topic 0)
5707 (insert "Local emacs vars.\n")
5708 (allout-open-topic 1)
5711 prefix
(buffer-substring-no-properties (progn
5716 (insert "Local variables:\n")
5717 (allout-open-topic 0)
5720 ;; look for existing entry or create one, leaving point for insertion
5723 (allout-show-to-offshoot)
5724 (if (search-forward (concat "\n" prefix varname
":") nil t
)
5725 (let* ((value-beg (point))
5726 (line-end (progn (if (search-forward "\n" nil t
)
5729 (value-end (- line-end
(length suffix
))))
5730 (if (> value-end value-beg
)
5731 (delete-region value-beg value-end
)))
5735 (insert (concat prefix varname
":")))
5736 (insert (format " %S%s" value suffix
))
5741 ;;;_ > solicit-char-in-string (prompt string &optional do-defaulting)
5742 (defun solicit-char-in-string (prompt string
&optional do-defaulting
)
5743 "Solicit (with first arg PROMPT) choice of a character from string STRING.
5745 Optional arg DO-DEFAULTING indicates to accept empty input (CR)."
5747 (let ((new-prompt prompt
)
5751 (message "%s" new-prompt
)
5753 ;; We do our own reading here, so we can circumvent, eg, special
5754 ;; treatment for `?' character. (Oughta use minibuffer keymap instead.)
5756 (char-to-string (let ((cursor-in-echo-area nil
)) (read-char))))
5759 (cond ((string-match (regexp-quote got
) string
) got
)
5760 ((and do-defaulting
(string= got
"\r"))
5761 ;; Return empty string to default:
5763 ((string= got
"\C-g") (signal 'quit nil
))
5765 (setq new-prompt
(concat prompt
5771 ;; got something out of loop - return it:
5774 ;;;_ > regexp-sans-escapes (string)
5775 (defun regexp-sans-escapes (regexp &optional successive-backslashes
)
5776 "Return a copy of REGEXP with all character escapes stripped out.
5778 Representations of actual backslashes - '\\\\\\\\' - are left as a
5781 Optional arg SUCCESSIVE-BACKSLASHES is used internally for recursion."
5783 (if (string= regexp
"")
5785 ;; Set successive-backslashes to number if current char is
5786 ;; backslash, or else to nil:
5787 (setq successive-backslashes
5788 (if (= (aref regexp
0) ?
\\)
5789 (if successive-backslashes
(1+ successive-backslashes
) 1)
5791 (if (or (not successive-backslashes
) (= 2 successive-backslashes
))
5792 ;; Include first char:
5793 (concat (substring regexp
0 1)
5794 (regexp-sans-escapes (substring regexp
1)))
5795 ;; Exclude first char, but maintain count:
5796 (regexp-sans-escapes (substring regexp
1) successive-backslashes
))))
5797 ;;;_ > count-trailing-whitespace-region (beg end)
5798 (defun count-trailing-whitespace-region (beg end
)
5799 "Return number of trailing whitespace chars between BEG and END.
5801 If BEG is bigger than END we return 0."
5807 (while (re-search-forward "[ ][ ]*$" end t
)
5808 (goto-char (1+ (match-beginning 0)))
5809 (setq count
(1+ count
)))
5811 ;;;_ > allout-mark-marker to accommodate divergent emacsen:
5812 (defun allout-mark-marker (&optional force buffer
)
5813 "Accommodate the different signature for `mark-marker' across Emacsen.
5815 XEmacs takes two optional args, while mainline GNU Emacs does not,
5816 so pass them along when appropriate."
5817 (if (featurep 'xemacs
)
5818 (apply 'mark-marker force buffer
)
5820 ;;;_ > subst-char-in-string if necessary
5821 (if (not (fboundp 'subst-char-in-string
))
5822 (defun subst-char-in-string (fromchar tochar string
&optional inplace
)
5823 "Replace FROMCHAR with TOCHAR in STRING each time it occurs.
5824 Unless optional argument INPLACE is non-nil, return a new string."
5825 (let ((i (length string
))
5826 (newstr (if inplace string
(copy-sequence string
))))
5829 (if (eq (aref newstr i
) fromchar
)
5830 (aset newstr i tochar
)))
5832 ;;;_ > wholenump if necessary
5833 (if (not (fboundp 'wholenump
))
5834 (defalias 'wholenump
'natnump
))
5835 ;;;_ > remove-overlays if necessary
5836 (if (not (fboundp 'remove-overlays
))
5837 (defun remove-overlays (&optional beg end name val
)
5838 "Clear BEG and END of overlays whose property NAME has value VAL.
5839 Overlays might be moved and/or split.
5840 BEG and END default respectively to the beginning and end of buffer."
5841 (unless beg
(setq beg
(point-min)))
5842 (unless end
(setq end
(point-max)))
5844 (setq beg
(prog1 end
(setq end beg
))))
5846 (dolist (o (overlays-in beg end
))
5847 (when (eq (overlay-get o name
) val
)
5848 ;; Either push this overlay outside beg...end
5849 ;; or split it to exclude beg...end
5850 ;; or delete it entirely (if it is contained in beg...end).
5851 (if (< (overlay-start o
) beg
)
5852 (if (> (overlay-end o
) end
)
5854 (move-overlay (copy-overlay o
)
5855 (overlay-start o
) beg
)
5856 (move-overlay o end
(overlay-end o
)))
5857 (move-overlay o
(overlay-start o
) beg
))
5858 (if (> (overlay-end o
) end
)
5859 (move-overlay o end
(overlay-end o
))
5860 (delete-overlay o
)))))))
5862 ;;;_ > copy-overlay if necessary - xemacs ~ 21.4
5863 (if (not (fboundp 'copy-overlay
))
5864 (defun copy-overlay (o)
5865 "Return a copy of overlay O."
5866 (let ((o1 (make-overlay (overlay-start o
) (overlay-end o
)
5867 ;; FIXME: there's no easy way to find the
5868 ;; insertion-type of the two markers.
5869 (overlay-buffer o
)))
5870 (props (overlay-properties o
)))
5872 (overlay-put o1
(pop props
) (pop props
)))
5874 ;;;_ > add-to-invisibility-spec if necessary - xemacs ~ 21.4
5875 (if (not (fboundp 'add-to-invisibility-spec
))
5876 (defun add-to-invisibility-spec (element)
5877 "Add ELEMENT to `buffer-invisibility-spec'.
5878 See documentation for `buffer-invisibility-spec' for the kind of elements
5880 (if (eq buffer-invisibility-spec t
)
5881 (setq buffer-invisibility-spec
(list t
)))
5882 (setq buffer-invisibility-spec
5883 (cons element buffer-invisibility-spec
))))
5884 ;;;_ > remove-from-invisibility-spec if necessary - xemacs ~ 21.4
5885 (if (not (fboundp 'remove-from-invisibility-spec
))
5886 (defun remove-from-invisibility-spec (element)
5887 "Remove ELEMENT from `buffer-invisibility-spec'."
5888 (if (consp buffer-invisibility-spec
)
5889 (setq buffer-invisibility-spec
(delete element
5890 buffer-invisibility-spec
)))))
5891 ;;;_ > move-beginning-of-line if necessary - older emacs, xemacs
5892 (if (not (fboundp 'move-beginning-of-line
))
5893 (defun move-beginning-of-line (arg)
5894 "Move point to beginning of current line as displayed.
5895 \(This disregards invisible newlines such as those
5896 which are part of the text that an image rests on.)
5898 With argument ARG not nil or 1, move forward ARG - 1 lines first.
5899 If point reaches the beginning or end of buffer, it stops there.
5900 To ignore intangibility, bind `inhibit-point-motion-hooks' to t."
5902 (or arg
(setq arg
1))
5904 (condition-case nil
(line-move (1- arg
)) (error nil
)))
5906 ;; Move to beginning-of-line, ignoring fields and invisibles.
5907 (skip-chars-backward "^\n")
5908 (while (and (not (bobp)) (line-move-invisible-p (1- (point))))
5909 (goto-char (if (featurep 'xemacs
)
5910 (previous-property-change (point))
5911 (previous-char-property-change (point))))
5912 (skip-chars-backward "^\n"))
5913 (vertical-motion 0))
5915 ;;;_ > move-end-of-line if necessary - older emacs, xemacs
5916 (if (not (fboundp 'move-end-of-line
))
5917 (defun move-end-of-line (arg)
5918 "Move point to end of current line as displayed.
5919 \(This disregards invisible newlines such as those
5920 which are part of the text that an image rests on.)
5922 With argument ARG not nil or 1, move forward ARG - 1 lines first.
5923 If point reaches the beginning or end of buffer, it stops there.
5924 To ignore intangibility, bind `inhibit-point-motion-hooks' to t."
5926 (or arg
(setq arg
1))
5931 (let ((goal-column 0))
5932 (and (condition-case nil
5933 (or (line-move arg
) t
)
5937 (while (and (not (bobp))
5938 (line-move-invisible-p (1- (point))))
5940 (previous-char-property-change (point))))
5944 (if (and (> (point) newpos
)
5945 (eq (preceding-char) ?
\n))
5947 (if (and (> (point) newpos
) (not (eobp))
5948 (not (eq (following-char) ?
\n)))
5949 ;; If we skipped something intangible
5950 ;; and now we're not really at eol,
5955 ;;;_ > line-move-invisible-p if necessary
5956 (if (not (fboundp 'line-move-invisible-p
))
5957 (defun line-move-invisible-p (pos)
5958 "Return non-nil if the character after POS is currently invisible."
5960 (get-char-property pos
'invisible
)))
5961 (if (eq buffer-invisibility-spec t
)
5963 (or (memq prop buffer-invisibility-spec
)
5964 (assq prop buffer-invisibility-spec
))))))
5967 ;;;_ > allout-bullet-isearch (&optional bullet)
5968 (defun allout-bullet-isearch (&optional bullet
)
5969 "Isearch \(regexp) for topic with bullet BULLET."
5972 (setq bullet
(solicit-char-in-string
5973 "ISearch for topic with bullet: "
5974 (regexp-sans-escapes allout-bullets-string
))))
5976 (let ((isearch-regexp t
)
5977 (isearch-string (concat "^"
5978 allout-header-prefix
5981 (isearch-repeat 'forward
)
5984 ;;;_ #11 Unit tests - this should be last item before "Provide"
5985 ;;;_ > allout-run-unit-tests ()
5986 (defun allout-run-unit-tests ()
5987 "Run the various allout unit tests."
5988 (message "Running allout tests...")
5989 (allout-test-resumptions)
5990 (message "Running allout tests... Done.")
5992 ;;;_ : test resumptions:
5993 ;;;_ > allout-tests-obliterate-variable (name)
5994 (defun allout-tests-obliterate-variable (name)
5995 "Completely unbind variable with NAME."
5996 (if (local-variable-p name
) (kill-local-variable name
))
5997 (while (boundp name
) (makunbound name
)))
5998 ;;;_ > allout-test-resumptions ()
5999 (defvar allout-tests-globally-unbound nil
6000 "Fodder for allout resumptions tests - defvar just for byte compiler.")
6001 (defvar allout-tests-globally-true nil
6002 "Fodder for allout resumptions tests - defvar just just for byte compiler.")
6003 (defvar allout-tests-locally-true nil
6004 "Fodder for allout resumptions tests - defvar just for byte compiler.")
6005 (defun allout-test-resumptions ()
6006 "Exercise allout resumptions."
6007 ;; for each resumption case, we also test that the right local/global
6008 ;; scopes are affected during resumption effects:
6010 ;; ensure that previously unbound variables return to the unbound state.
6012 (allout-tests-obliterate-variable 'allout-tests-globally-unbound
)
6013 (allout-add-resumptions '(allout-tests-globally-unbound t
))
6014 (assert (not (default-boundp 'allout-tests-globally-unbound
)))
6015 (assert (local-variable-p 'allout-tests-globally-unbound
))
6016 (assert (boundp 'allout-tests-globally-unbound
))
6017 (assert (equal allout-tests-globally-unbound t
))
6018 (allout-do-resumptions)
6019 (assert (not (local-variable-p 'allout-tests-globally-unbound
)))
6020 (assert (not (boundp 'allout-tests-globally-unbound
))))
6022 ;; ensure that variable with prior global value is resumed
6024 (allout-tests-obliterate-variable 'allout-tests-globally-true
)
6025 (setq allout-tests-globally-true t
)
6026 (allout-add-resumptions '(allout-tests-globally-true nil
))
6027 (assert (equal (default-value 'allout-tests-globally-true
) t
))
6028 (assert (local-variable-p 'allout-tests-globally-true
))
6029 (assert (equal allout-tests-globally-true nil
))
6030 (allout-do-resumptions)
6031 (assert (not (local-variable-p 'allout-tests-globally-true
)))
6032 (assert (boundp 'allout-tests-globally-true
))
6033 (assert (equal allout-tests-globally-true t
)))
6035 ;; ensure that prior local value is resumed
6037 (allout-tests-obliterate-variable 'allout-tests-locally-true
)
6038 (set (make-local-variable 'allout-tests-locally-true
) t
)
6039 (assert (not (default-boundp 'allout-tests-locally-true
))
6040 nil
(concat "Test setup mistake - variable supposed to"
6041 " not have global binding, but it does."))
6042 (assert (local-variable-p 'allout-tests-locally-true
)
6043 nil
(concat "Test setup mistake - variable supposed to have"
6044 " local binding, but it lacks one."))
6045 (allout-add-resumptions '(allout-tests-locally-true nil
))
6046 (assert (not (default-boundp 'allout-tests-locally-true
)))
6047 (assert (local-variable-p 'allout-tests-locally-true
))
6048 (assert (equal allout-tests-locally-true nil
))
6049 (allout-do-resumptions)
6050 (assert (boundp 'allout-tests-locally-true
))
6051 (assert (local-variable-p 'allout-tests-locally-true
))
6052 (assert (equal allout-tests-locally-true t
))
6053 (assert (not (default-boundp 'allout-tests-locally-true
))))
6055 ;; ensure that last of multiple resumptions holds, for various scopes.
6057 (allout-tests-obliterate-variable 'allout-tests-globally-unbound
)
6058 (allout-tests-obliterate-variable 'allout-tests-globally-true
)
6059 (setq allout-tests-globally-true t
)
6060 (allout-tests-obliterate-variable 'allout-tests-locally-true
)
6061 (set (make-local-variable 'allout-tests-locally-true
) t
)
6062 (allout-add-resumptions '(allout-tests-globally-unbound t
)
6063 '(allout-tests-globally-true nil
)
6064 '(allout-tests-locally-true nil
))
6065 (allout-add-resumptions '(allout-tests-globally-unbound 2)
6066 '(allout-tests-globally-true 3)
6067 '(allout-tests-locally-true 4))
6068 ;; reestablish many of the basic conditions are maintained after re-add:
6069 (assert (not (default-boundp 'allout-tests-globally-unbound
)))
6070 (assert (local-variable-p 'allout-tests-globally-unbound
))
6071 (assert (equal allout-tests-globally-unbound
2))
6072 (assert (default-boundp 'allout-tests-globally-true
))
6073 (assert (local-variable-p 'allout-tests-globally-true
))
6074 (assert (equal allout-tests-globally-true
3))
6075 (assert (not (default-boundp 'allout-tests-locally-true
)))
6076 (assert (local-variable-p 'allout-tests-locally-true
))
6077 (assert (equal allout-tests-locally-true
4))
6078 (allout-do-resumptions)
6079 (assert (not (local-variable-p 'allout-tests-globally-unbound
)))
6080 (assert (not (boundp 'allout-tests-globally-unbound
)))
6081 (assert (not (local-variable-p 'allout-tests-globally-true
)))
6082 (assert (boundp 'allout-tests-globally-true
))
6083 (assert (equal allout-tests-globally-true t
))
6084 (assert (boundp 'allout-tests-locally-true
))
6085 (assert (local-variable-p 'allout-tests-locally-true
))
6086 (assert (equal allout-tests-locally-true t
))
6087 (assert (not (default-boundp 'allout-tests-locally-true
))))
6089 ;; ensure that deliberately unbinding registered variables doesn't foul things
6091 (allout-tests-obliterate-variable 'allout-tests-globally-unbound
)
6092 (allout-tests-obliterate-variable 'allout-tests-globally-true
)
6093 (setq allout-tests-globally-true t
)
6094 (allout-tests-obliterate-variable 'allout-tests-locally-true
)
6095 (set (make-local-variable 'allout-tests-locally-true
) t
)
6096 (allout-add-resumptions '(allout-tests-globally-unbound t
)
6097 '(allout-tests-globally-true nil
)
6098 '(allout-tests-locally-true nil
))
6099 (allout-tests-obliterate-variable 'allout-tests-globally-unbound
)
6100 (allout-tests-obliterate-variable 'allout-tests-globally-true
)
6101 (allout-tests-obliterate-variable 'allout-tests-locally-true
)
6102 (allout-do-resumptions))
6104 ;;;_ % Run unit tests if `allout-run-unit-tests-after-load' is true:
6105 (when allout-run-unit-tests-on-load
6106 (allout-run-unit-tests))
6111 ;;;_* Local emacs vars.
6112 ;; The following `allout-layout' local variable setting:
6113 ;; - closes all topics from the first topic to just before the third-to-last,
6114 ;; - shows the children of the third to last (config vars)
6115 ;; - and the second to last (code section),
6116 ;; - and closes the last topic (this local-variables section).
6118 ;;allout-layout: (0 : -1 -1 0)
6121 ;; arch-tag: cf38fbc3-c044-450f-8bff-afed8ba5681c
6122 ;;; allout.el ends here