1 ;;; allout.el --- extensive outline mode for use alone and with other modes
3 ;; Copyright (C) 1992, 1993, 1994, 2001, 2002, 2003, 2004,
4 ;; 2005, 2006 Free Software Foundation, Inc.
6 ;; Author: Ken Manheimer <ken dot manheimer at gmail dot com>
7 ;; Maintainer: Ken Manheimer <ken dot manheimer at gmail dot com>
8 ;; Created: Dec 1991 - first release to usenet
10 ;; Keywords: outlines wp languages
11 ;; Website: http://myriadicity.net/Sundry/EmacsAllout
13 ;; This file is part of GNU Emacs.
15 ;; GNU Emacs is free software; you can redistribute it and/or modify
16 ;; it under the terms of the GNU General Public License as published by
17 ;; the Free Software Foundation; either version 2, or (at your option)
20 ;; GNU Emacs is distributed in the hope that it will be useful,
21 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
22 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
23 ;; GNU General Public License for more details.
25 ;; You should have received a copy of the GNU General Public License
26 ;; along with GNU Emacs; see the file COPYING. If not, write to the
27 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
28 ;; Boston, MA 02110-1301, USA.
32 ;; Allout outline minor mode provides extensive outline formatting and
33 ;; and manipulation beyond standard emacs outline mode. Some features:
35 ;; - Classic outline-mode topic-oriented navigation and exposure adjustment
36 ;; - Topic-oriented editing including coherent topic and subtopic
37 ;; creation, promotion, demotion, cut/paste across depths, etc.
38 ;; - Incremental search with dynamic exposure and reconcealment of text
39 ;; - Customizable bullet format - enables programming-language specific
40 ;; outlining, for code-folding editing. (Allout code itself is to try it;
41 ;; formatted as an outline - do ESC-x eval-buffer in allout.el; but
42 ;; emacs local file variables need to be enabled when the
43 ;; file was visited - see `enable-local-variables'.)
44 ;; - Configurable per-file initial exposure settings
45 ;; - Symmetric-key and key-pair topic encryption, plus symmetric passphrase
46 ;; mnemonic support, with verification against an established passphrase
47 ;; (using a stashed encrypted dummy string) and user-supplied hint
48 ;; maintenance. (See allout-toggle-current-subtree-encryption docstring.)
49 ;; - Automatic topic-number maintenance
50 ;; - "Hot-spot" operation, for single-keystroke maneuvering and
51 ;; exposure control (see the allout-mode docstring)
52 ;; - Easy rendering of exposed portions into numbered, latex, indented, etc
54 ;; - Careful attention to whitespace - enabling blank lines between items
55 ;; and maintenance of hanging indentation (in paragraph auto-fill and
56 ;; across topic promotion and demotion) of topic bodies consistent with
57 ;; indentation of their topic header.
61 ;; See the `allout-mode' function's docstring for an introduction to the
64 ;; The latest development version and helpful notes are available at
65 ;; http://myriadicity.net/Sundry/EmacsAllout .
67 ;; The outline menubar additions provide quick reference to many of
68 ;; the features, and see the docstring of the variable `allout-init'
69 ;; for instructions on priming your Emacs session for automatic
70 ;; activation of allout-mode.
72 ;; See the docstring of the variables `allout-layout' and
73 ;; `allout-auto-activation' for details on automatic activation of
74 ;; `allout-mode' as a minor mode. (It has changed since allout
75 ;; 3.x, for those of you that depend on the old method.)
77 ;; Note - the lines beginning with `;;;_' are outline topic headers.
78 ;; Just `ESC-x eval-buffer' to give it a whirl.
80 ;; ken manheimer (ken dot manheimer at gmail dot com)
84 ;;;_* Dependency autoloads
87 ;; Most of the requires here are for stuff covered by autoloads.
88 ;; Since just byte-compiling doesn't trigger autoloads, so that
89 ;; "function not found" warnings would occur without these requires.
94 ;; `cl' is required for `assert'. `assert' is not covered by a standard
95 ;; autoload, but it is a macro, so that eval-when-compile is sufficient
96 ;; to byte-compile it in, or to do the require when the buffer evalled.
100 ;;;_* USER CUSTOMIZATION VARIABLES:
102 ;;;_ > defgroup allout
104 "Extensive outline mode for use alone and with other modes."
108 ;;;_ + Layout, Mode, and Topic Header Configuration
110 ;;;_ = allout-auto-activation
111 (defcustom allout-auto-activation nil
112 "*Regulates auto-activation modality of allout outlines - see `allout-init'.
114 Setq-default by `allout-init' to regulate whether or not allout
115 outline mode is automatically activated when the buffer-specific
116 variable `allout-layout' is non-nil, and whether or not the layout
117 dictated by `allout-layout' should be imposed on mode activation.
119 With value t, auto-mode-activation and auto-layout are enabled.
120 \(This also depends on `allout-find-file-hook' being installed in
121 `find-file-hook', which is also done by `allout-init'.)
123 With value `ask', auto-mode-activation is enabled, and endorsement for
124 performing auto-layout is asked of the user each time.
126 With value `activate', only auto-mode-activation is enabled,
129 With value nil, neither auto-mode-activation nor auto-layout are
132 See the docstring for `allout-init' for the proper interface to
134 :type
'(choice (const :tag
"On" t
)
135 (const :tag
"Ask about layout" "ask")
136 (const :tag
"Mode only" "activate")
137 (const :tag
"Off" nil
))
139 ;;;_ = allout-default-layout
140 (defcustom allout-default-layout
'(-2 : 0)
141 "*Default allout outline layout specification.
143 This setting specifies the outline exposure to use when
144 `allout-layout' has the local value `t'. This docstring describes the
145 layout specifications.
147 A list value specifies a default layout for the current buffer,
148 to be applied upon activation of `allout-mode'. Any non-nil
149 value will automatically trigger `allout-mode', provided
150 `allout-init' has been called to enable this behavior.
152 The types of elements in the layout specification are:
154 integer - dictate the relative depth to open the corresponding topic(s),
156 - negative numbers force the topic to be closed before opening
157 to the absolute value of the number, so all siblings are open
159 - positive numbers open to the relative depth indicated by the
160 number, but do not force already opened subtopics to be closed.
161 - 0 means to close topic - hide all subitems.
162 : - repeat spec - apply the preceeding element to all siblings at
163 current level, *up to* those siblings that would be covered by specs
164 following the `:' on the list. Ie, apply to all topics at level but
165 trailing ones accounted for by trailing specs. (Only the first of
166 multiple colons at the same level is honored - later ones are ignored.)
167 * - completely exposes the topic, including bodies
168 + - exposes all subtopics, but not the bodies
169 - - exposes the body of the corresponding topic, but not subtopics
170 list - a nested layout spec, to be applied intricately to its
171 corresponding item(s)
175 Collapse the top-level topics to show their children and
176 grandchildren, but completely collapse the final top-level topic.
178 Close the first topic so only the immediate subtopics are shown,
179 leave the subsequent topics exposed as they are until the second
180 second to last topic, which is exposed at least one level, and
181 completely close the last topic.
183 Expose children and grandchildren of all topics at current
184 level except the last two; expose children of the second to
185 last and completely expose the last one, including its subtopics.
187 See `allout-expose-topic' for more about the exposure process.
189 Also, allout's mode-specific provisions will make topic prefixes default
190 to the comment-start string, if any, of the language of the file. This
191 is modulo the setting of `allout-use-mode-specific-leader', which see."
192 :type
'allout-layout-type
194 ;;;_ : allout-layout-type
195 (define-widget 'allout-layout-type
'lazy
196 "Allout layout format customization basic building blocks."
198 (choice (integer :tag
"integer (<= zero is strict)")
199 (const :tag
": (repeat prior)" :)
200 (const :tag
"* (completely expose)" *)
201 (const :tag
"+ (expose all offspring, headlines only)" +)
202 (const :tag
"- (expose topic body but not offspring)" -
)
203 (allout-layout-type :tag
"<Nested layout>"))))
205 ;;;_ = allout-show-bodies
206 (defcustom allout-show-bodies nil
207 "*If non-nil, show entire body when exposing a topic, rather than
211 (make-variable-buffer-local 'allout-show-bodies
)
213 (put 'allout-show-bodies
'safe-local-variable
214 (if (fboundp 'booleanp
) 'booleanp
'(lambda (x) (member x
'(t nil
)))))
216 ;;;_ = allout-beginning-of-line-cycles
217 (defcustom allout-beginning-of-line-cycles t
218 "*If non-nil, \\[allout-beginning-of-line] will cycle through smart-placement options.
220 Cycling only happens on when the command is repeated, not when it
221 follows a different command.
223 Smart-placement means that repeated calls to this function will
226 - if the cursor is on a non-headline body line and not on the first column:
227 then it goes to the first column
228 - if the cursor is on the first column of a non-headline body line:
229 then it goes to the start of the headline within the item body
230 - if the cursor is on the headline and not the start of the headline:
231 then it goes to the start of the headline
232 - if the cursor is on the start of the headline:
233 then it goes to the bullet character (for hotspot navigation)
234 - if the cursor is on the bullet character:
235 then it goes to the first column of that line (the headline)
236 - if the cursor is on the first column of the headline:
237 then it goes to the start of the headline within the item body.
239 In this fashion, you can use the beginning-of-line command to do
240 its normal job and then, when repeated, advance through the
241 entry, cycling back to start.
243 If this configuration variable is nil, then the cursor is just
244 advanced to the beginning of the line and remains there on
246 :type
'boolean
:group
'allout
)
247 ;;;_ = allout-end-of-line-cycles
248 (defcustom allout-end-of-line-cycles t
249 "*If non-nil, \\[allout-end-of-line] will cycle through smart-placement options.
251 Cycling only happens on when the command is repeated, not when it
252 follows a different command.
254 Smart-placement means that repeated calls to this function will
257 - if the cursor is not on the end-of-line,
258 then it goes to the end-of-line
259 - if the cursor is on the end-of-line but not the end-of-entry,
260 then it goes to the end-of-entry, exposing it if necessary
261 - if the cursor is on the end-of-entry,
262 then it goes to the end of the head line
264 In this fashion, you can use the end-of-line command to do its
265 normal job and then, when repeated, advance through the entry,
266 cycling back to start.
268 If this configuration variable is nil, then the cursor is just
269 advanced to the end of the line and remains there on repeated
271 :type
'boolean
:group
'allout
)
273 ;;;_ = allout-header-prefix
274 (defcustom allout-header-prefix
"."
275 ;; this string is treated as literal match. it will be `regexp-quote'd, so
276 ;; one cannot use regular expressions to match varying header prefixes.
277 "*Leading string which helps distinguish topic headers.
279 Outline topic header lines are identified by a leading topic
280 header prefix, which mostly have the value of this var at their front.
281 Level 1 topics are exceptions. They consist of only a single
282 character, which is typically set to the `allout-primary-bullet'."
285 (make-variable-buffer-local 'allout-header-prefix
)
287 (put 'allout-header-prefix
'safe-local-variable
'stringp
)
288 ;;;_ = allout-primary-bullet
289 (defcustom allout-primary-bullet
"*"
290 "Bullet used for top-level outline topics.
292 Outline topic header lines are identified by a leading topic header
293 prefix, which is concluded by bullets that includes the value of this
294 var and the respective allout-*-bullets-string vars.
296 The value of an asterisk (`*') provides for backwards compatibility
297 with the original Emacs outline mode. See `allout-plain-bullets-string'
298 and `allout-distinctive-bullets-string' for the range of available
302 (make-variable-buffer-local 'allout-primary-bullet
)
304 (put 'allout-primary-bullet
'safe-local-variable
'stringp
)
305 ;;;_ = allout-plain-bullets-string
306 (defcustom allout-plain-bullets-string
".,"
307 "*The bullets normally used in outline topic prefixes.
309 See `allout-distinctive-bullets-string' for the other kind of
312 DO NOT include the close-square-bracket, `]', as a bullet.
314 Outline mode has to be reactivated in order for changes to the value
315 of this var to take effect."
318 (make-variable-buffer-local 'allout-plain-bullets-string
)
320 (put 'allout-plain-bullets-string
'safe-local-variable
'stringp
)
321 ;;;_ = allout-distinctive-bullets-string
322 (defcustom allout-distinctive-bullets-string
"*+-=>()[{}&!?#%\"X@$~_\\:;^"
323 "*Persistent outline header bullets used to distinguish special topics.
325 These bullets are used to distinguish topics from the run-of-the-mill
326 ones. They are not used in the standard topic headers created by
327 the topic-opening, shifting, and rebulleting (eg, on topic shift,
328 topic paste, blanket rebulleting) routines, but are offered among the
329 choices for rebulleting. They are not altered by the above automatic
330 rebulleting, so they can be used to characterize topics, eg:
333 `(' parenthetic comment (with a matching close paren inside)
334 `[' meta-note (with a matching close ] inside)
340 ... for example. (`#' typically has a special meaning to the software,
341 according to the value of `allout-numbered-bullet'.)
343 See `allout-plain-bullets-string' for the selection of
346 You must run `set-allout-regexp' in order for outline mode to
347 reconcile to changes of this value.
349 DO NOT include the close-square-bracket, `]', on either of the bullet
353 (make-variable-buffer-local 'allout-distinctive-bullets-string
)
355 (put 'allout-distinctive-bullets-string
'safe-local-variable
'stringp
)
357 ;;;_ = allout-use-mode-specific-leader
358 (defcustom allout-use-mode-specific-leader t
359 "*When non-nil, use mode-specific topic-header prefixes.
361 Allout outline mode will use the mode-specific `allout-mode-leaders' or
362 comment-start string, if any, to lead the topic prefix string, so topic
363 headers look like comments in the programming language. It will also use
364 the comment-start string, with an '_' appended, for `allout-primary-bullet'.
366 String values are used as literals, not regular expressions, so
367 do not escape any regulare-expression characters.
369 Value t means to first check for assoc value in `allout-mode-leaders'
370 alist, then use comment-start string, if any, then use default (`.').
371 \(See note about use of comment-start strings, below.)
373 Set to the symbol for either of `allout-mode-leaders' or
374 `comment-start' to use only one of them, respectively.
376 Value nil means to always use the default (`.') and leave
377 `allout-primary-bullet' unaltered.
379 comment-start strings that do not end in spaces are tripled in
380 the header-prefix, and an `_' underscore is tacked on the end, to
381 distinguish them from regular comment strings. comment-start
382 strings that do end in spaces are not tripled, but an underscore
383 is substituted for the space. [This presumes that the space is
384 for appearance, not comment syntax. You can use
385 `allout-mode-leaders' to override this behavior, when
387 :type
'(choice (const t
) (const nil
) string
388 (const allout-mode-leaders
)
389 (const comment-start
))
392 (put 'allout-use-mode-specific-leader
'safe-local-variable
393 '(lambda (x) (or (memq x
'(t nil allout-mode-leaders comment-start
))
395 ;;;_ = allout-mode-leaders
396 (defvar allout-mode-leaders
'()
397 "Specific allout-prefix leading strings per major modes.
399 Use this if the mode's comment-start string isn't what you
400 prefer, or if the mode lacks a comment-start string. See
401 `allout-use-mode-specific-leader' for more details.
403 If you're constructing a string that will comment-out outline
404 structuring so it can be included in program code, append an extra
405 character, like an \"_\" underscore, to distinguish the lead string
406 from regular comments that start at the beginning-of-line.")
408 ;;;_ = allout-old-style-prefixes
409 (defcustom allout-old-style-prefixes nil
410 "*When non-nil, use only old-and-crusty `outline-mode' `*' topic prefixes.
412 Non-nil restricts the topic creation and modification
413 functions to asterix-padded prefixes, so they look exactly
414 like the original Emacs-outline style prefixes.
416 Whatever the setting of this variable, both old and new style prefixes
417 are always respected by the topic maneuvering functions."
420 (make-variable-buffer-local 'allout-old-style-prefixes
)
422 (put 'allout-old-style-prefixes
'safe-local-variable
423 (if (fboundp 'booleanp
) 'booleanp
'(lambda (x) (member x
'(t nil
)))))
424 ;;;_ = allout-stylish-prefixes - alternating bullets
425 (defcustom allout-stylish-prefixes t
426 "*Do fancy stuff with topic prefix bullets according to level, etc.
428 Non-nil enables topic creation, modification, and repositioning
429 functions to vary the topic bullet char (the char that marks the topic
430 depth) just preceding the start of the topic text) according to level.
431 Otherwise, only asterisks (`*') and distinctive bullets are used.
433 This is how an outline can look (but sans indentation) with stylish
438 . + One level 3 subtopic
439 . . One level 4 subtopic
440 . . A second 4 subtopic
441 . + Another level 3 subtopic
442 . #1 A numbered level 4 subtopic
444 . ! Another level 4 subtopic with a different distinctive bullet
445 . #4 And another numbered level 4 subtopic
447 This would be an outline with stylish prefixes inhibited (but the
448 numbered and other distinctive bullets retained):
452 . * One level 3 subtopic
453 . * One level 4 subtopic
454 . * A second 4 subtopic
455 . * Another level 3 subtopic
456 . #1 A numbered level 4 subtopic
458 . ! Another level 4 subtopic with a different distinctive bullet
459 . #4 And another numbered level 4 subtopic
461 Stylish and constant prefixes (as well as old-style prefixes) are
462 always respected by the topic maneuvering functions, regardless of
463 this variable setting.
465 The setting of this var is not relevant when `allout-old-style-prefixes'
469 (make-variable-buffer-local 'allout-stylish-prefixes
)
471 (put 'allout-stylish-prefixes
'safe-local-variable
472 (if (fboundp 'booleanp
) 'booleanp
'(lambda (x) (member x
'(t nil
)))))
474 ;;;_ = allout-numbered-bullet
475 (defcustom allout-numbered-bullet
"#"
476 "*String designating bullet of topics that have auto-numbering; nil for none.
478 Topics having this bullet have automatic maintenance of a sibling
479 sequence-number tacked on, just after the bullet. Conventionally set
480 to \"#\", you can set it to a bullet of your choice. A nil value
481 disables numbering maintenance."
482 :type
'(choice (const nil
) string
)
484 (make-variable-buffer-local 'allout-numbered-bullet
)
486 (put 'allout-numbered-bullet
'safe-local-variable
487 (if (fboundp 'string-or-null-p
)
489 '(lambda (x) (or (stringp x
) (null x
)))))
490 ;;;_ = allout-file-xref-bullet
491 (defcustom allout-file-xref-bullet
"@"
492 "*Bullet signifying file cross-references, for `allout-resolve-xref'.
494 Set this var to the bullet you want to use for file cross-references."
495 :type
'(choice (const nil
) string
)
498 (put 'allout-file-xref-bullet
'safe-local-variable
499 (if (fboundp 'string-or-null-p
)
501 '(lambda (x) (or (stringp x
) (null x
)))))
502 ;;;_ = allout-presentation-padding
503 (defcustom allout-presentation-padding
2
504 "*Presentation-format white-space padding factor, for greater indent."
508 (make-variable-buffer-local 'allout-presentation-padding
)
510 (put 'allout-presentation-padding
'safe-local-variable
'integerp
)
512 ;;;_ = allout-abbreviate-flattened-numbering
513 (defcustom allout-abbreviate-flattened-numbering nil
514 "*If non-nil, `allout-flatten-exposed-to-buffer' abbreviates topic
515 numbers to minimal amount with some context. Otherwise, entire
516 numbers are always used."
520 ;;;_ + LaTeX formatting
521 ;;;_ - allout-number-pages
522 (defcustom allout-number-pages nil
523 "*Non-nil turns on page numbering for LaTeX formatting of an outline."
526 ;;;_ - allout-label-style
527 (defcustom allout-label-style
"\\large\\bf"
528 "*Font and size of labels for LaTeX formatting of an outline."
531 ;;;_ - allout-head-line-style
532 (defcustom allout-head-line-style
"\\large\\sl "
533 "*Font and size of entries for LaTeX formatting of an outline."
536 ;;;_ - allout-body-line-style
537 (defcustom allout-body-line-style
" "
538 "*Font and size of entries for LaTeX formatting of an outline."
541 ;;;_ - allout-title-style
542 (defcustom allout-title-style
"\\Large\\bf"
543 "*Font and size of titles for LaTeX formatting of an outline."
547 (defcustom allout-title
'(or buffer-file-name
(buffer-name))
548 "*Expression to be evaluated to determine the title for LaTeX
552 ;;;_ - allout-line-skip
553 (defcustom allout-line-skip
".05cm"
554 "*Space between lines for LaTeX formatting of an outline."
558 (defcustom allout-indent
".3cm"
559 "*LaTeX formatted depth-indent spacing."
563 ;;;_ + Topic encryption
564 ;;;_ = allout-encryption group
565 (defgroup allout-encryption nil
566 "Settings for topic encryption features of allout outliner."
568 ;;;_ = allout-topic-encryption-bullet
569 (defcustom allout-topic-encryption-bullet
"~"
570 "*Bullet signifying encryption of the entry's body."
571 :type
'(choice (const nil
) string
)
573 :group
'allout-encryption
)
574 ;;;_ = allout-passphrase-verifier-handling
575 (defcustom allout-passphrase-verifier-handling t
576 "*Enable use of symmetric encryption passphrase verifier if non-nil.
578 See the docstring for the `allout-enable-file-variable-adjustment'
579 variable for details about allout ajustment of file variables."
582 :group
'allout-encryption
)
583 (make-variable-buffer-local 'allout-passphrase-verifier-handling
)
584 ;;;_ = allout-passphrase-hint-handling
585 (defcustom allout-passphrase-hint-handling
'always
586 "*Dictate outline encryption passphrase reminder handling:
588 always - always show reminder when prompting
589 needed - show reminder on passphrase entry failure
590 disabled - never present or adjust reminder
592 See the docstring for the `allout-enable-file-variable-adjustment'
593 variable for details about allout ajustment of file variables."
594 :type
'(choice (const always
)
598 :group
'allout-encryption
)
599 (make-variable-buffer-local 'allout-passphrase-hint-handling
)
600 ;;;_ = allout-encrypt-unencrypted-on-saves
601 (defcustom allout-encrypt-unencrypted-on-saves t
602 "*When saving, should topics pending encryption be encrypted?
604 The idea is to prevent file-system exposure of any un-encrypted stuff, and
605 mostly covers both deliberate file writes and auto-saves.
607 - Yes: encrypt all topics pending encryption, even if it's the one
608 currently being edited. (In that case, the currently edited topic
609 will be automatically decrypted before any user interaction, so they
610 can continue editing but the copy on the file system will be
612 Auto-saves will use the \"All except current topic\" mode if this
613 one is selected, to avoid practical difficulties - see below.
614 - All except current topic: skip the topic currently being edited, even if
615 it's pending encryption. This may expose the current topic on the
616 file sytem, but avoids the nuisance of prompts for the encryption
617 passphrase in the middle of editing for, eg, autosaves.
618 This mode is used for auto-saves for both this option and \"Yes\".
619 - No: leave it to the user to encrypt any unencrypted topics.
621 For practical reasons, auto-saves always use the 'except-current policy
622 when auto-encryption is enabled. (Otherwise, spurious passphrase prompts
623 and unavoidable timing collisions are too disruptive.) If security for a
624 file requires that even the current topic is never auto-saved in the clear,
625 disable auto-saves for that file."
627 :type
'(choice (const :tag
"Yes" t
)
628 (const :tag
"All except current topic" except-current
)
629 (const :tag
"No" nil
))
631 :group
'allout-encryption
)
632 (make-variable-buffer-local 'allout-encrypt-unencrypted-on-saves
)
635 ;;;_ = allout-developer group
636 (defgroup allout-developer nil
637 "Settings for topic encryption features of allout outliner."
639 ;;;_ = allout-run-unit-tests-on-load
640 (defcustom allout-run-unit-tests-on-load nil
641 "*When non-nil, unit tests will be run at end of loading the allout module.
643 Generally, allout code developers are the only ones who'll want to set this.
645 \(If set, this makes it an even better practice to exercise changes by
646 doing byte-compilation with a repeat count, so the file is loaded after
649 See `allout-run-unit-tests' to see what's run."
651 :group
'allout-developer
)
653 ;;;_ + Miscellaneous customization
655 ;;;_ = allout-command-prefix
656 (defcustom allout-command-prefix
"\C-c "
657 "*Key sequence to be used as prefix for outline mode command key bindings.
659 Default is '\C-c<space>'; just '\C-c' is more short-and-sweet, if you're
660 willing to let allout use a bunch of \C-c keybindings."
664 ;;;_ = allout-keybindings-list
665 ;;; You have to reactivate allout-mode - `(allout-mode t)' - to
666 ;;; institute changes to this var.
667 (defvar allout-keybindings-list
()
668 "*List of `allout-mode' key / function bindings, for `allout-mode-map'.
670 String or vector key will be prefaced with `allout-command-prefix',
671 unless optional third, non-nil element is present.")
672 (setq allout-keybindings-list
675 ("\C-n" allout-next-visible-heading
)
676 ("\C-p" allout-previous-visible-heading
)
677 ("\C-u" allout-up-current-level
)
678 ("\C-f" allout-forward-current-level
)
679 ("\C-b" allout-backward-current-level
)
680 ("\C-a" allout-beginning-of-current-entry
)
681 ("\C-e" allout-end-of-entry
)
683 ("\C-i" allout-show-children
)
684 ("\C-s" allout-show-current-subtree
)
685 ("\C-h" allout-hide-current-subtree
)
686 ("h" allout-hide-current-subtree
)
687 ("\C-o" allout-show-current-entry
)
688 ("!" allout-show-all
)
689 ("x" allout-toggle-current-subtree-encryption
)
690 ; Alteration commands:
691 (" " allout-open-sibtopic
)
692 ("." allout-open-subtopic
)
693 ("," allout-open-supertopic
)
694 ("'" allout-shift-in
)
695 (">" allout-shift-in
)
696 ("<" allout-shift-out
)
697 ("\C-m" allout-rebullet-topic
)
698 ("*" allout-rebullet-current-heading
)
699 ("#" allout-number-siblings
)
700 ("\C-k" allout-kill-line t
)
701 ("\M-k" allout-copy-line-as-kill t
)
702 ("\C-y" allout-yank t
)
703 ("\M-y" allout-yank-pop t
)
704 ("\C-k" allout-kill-topic
)
705 ("\M-k" allout-copy-topic-as-kill
)
706 ; Miscellaneous commands:
707 ;([?\C-\ ] allout-mark-topic)
708 ("@" allout-resolve-xref
)
709 ("=c" allout-copy-exposed-to-buffer
)
710 ("=i" allout-indented-exposed-to-buffer
)
711 ("=t" allout-latexify-exposed
)
712 ("=p" allout-flatten-exposed-to-buffer
)))
714 ;;;_ = allout-inhibit-auto-fill
715 (defcustom allout-inhibit-auto-fill nil
716 "*If non-nil, auto-fill will be inhibited in the allout buffers.
718 You can customize this setting to set it for all allout buffers, or set it
719 in individual buffers if you want to inhibit auto-fill only in particular
720 buffers. (You could use a function on `allout-mode-hook' to inhibit
721 auto-fill according, eg, to the major mode.)
723 If you don't set this and auto-fill-mode is enabled, allout will use the
724 value that `normal-auto-fill-function', if any, when allout mode starts, or
725 else allout's special hanging-indent maintaining auto-fill function,
729 (make-variable-buffer-local 'allout-inhibit-auto-fill
)
731 ;;;_ = allout-use-hanging-indents
732 (defcustom allout-use-hanging-indents t
733 "*If non-nil, topic body text auto-indent defaults to indent of the header.
734 Ie, it is indented to be just past the header prefix. This is
735 relevant mostly for use with indented-text-mode, or other situations
736 where auto-fill occurs."
739 (make-variable-buffer-local 'allout-use-hanging-indents
)
741 (put 'allout-use-hanging-indents
'safe-local-variable
742 (if (fboundp 'booleanp
) 'booleanp
'(lambda (x) (member x
'(t nil
)))))
744 ;;;_ = allout-reindent-bodies
745 (defcustom allout-reindent-bodies
(if allout-use-hanging-indents
747 "*Non-nil enables auto-adjust of topic body hanging indent with depth shifts.
749 When active, topic body lines that are indented even with or beyond
750 their topic header are reindented to correspond with depth shifts of
753 A value of t enables reindent in non-programming-code buffers, ie
754 those that do not have the variable `comment-start' set. A value of
755 `force' enables reindent whether or not `comment-start' is set."
756 :type
'(choice (const nil
) (const t
) (const text
) (const force
))
759 (make-variable-buffer-local 'allout-reindent-bodies
)
761 (put 'allout-reindent-bodies
'safe-local-variable
762 '(lambda (x) (memq x
'(nil t text force
))))
764 ;;;_ = allout-enable-file-variable-adjustment
765 (defcustom allout-enable-file-variable-adjustment t
766 "*If non-nil, some allout outline actions edit Emacs local file var text.
768 This can range from changes to existing entries, addition of new ones,
769 and creation of a new local variables section when necessary.
771 Emacs file variables adjustments are also inhibited if `enable-local-variables'
774 Operations potentially causing edits include allout encryption routines.
775 For details, see `allout-toggle-current-subtree-encryption's docstring."
778 (make-variable-buffer-local 'allout-enable-file-variable-adjustment
)
780 ;;;_* CODE - no user customizations below.
782 ;;;_ #1 Internal Outline Formatting and Configuration
784 ;;;_ = allout-version
785 (defvar allout-version
"2.2.1"
786 "Version of currently loaded outline package. (allout.el)")
787 ;;;_ > allout-version
788 (defun allout-version (&optional here
)
789 "Return string describing the loaded outline version."
791 (let ((msg (concat "Allout Outline Mode v " allout-version
)))
792 (if here
(insert msg
))
795 ;;;_ : Mode activation (defined here because it's referenced early)
797 (defvar allout-mode nil
"Allout outline mode minor-mode flag.")
798 (make-variable-buffer-local 'allout-mode
)
799 ;;;_ = allout-layout nil
800 (defvar allout-layout nil
; LEAVE GLOBAL VALUE NIL - see docstring.
801 "Buffer-specific setting for allout layout.
803 In buffers where this is non-nil (and if `allout-init' has been run, to
804 enable this behavior), `allout-mode' will be automatically activated. The
805 layout dictated by the value will be used to set the initial exposure when
806 `allout-mode' is activated.
808 \*You should not setq-default this variable non-nil unless you want every
809 visited file to be treated as an allout file.*
811 The value would typically be set by a file local variable. For
812 example, the following lines at the bottom of an Emacs Lisp file:
815 ;;;allout-layout: (0 : -1 -1 0)
818 dictate activation of `allout-mode' mode when the file is visited
819 \(presuming allout-init was already run), followed by the
820 equivalent of `(allout-expose-topic 0 : -1 -1 0)'. (This is
821 the layout used for the allout.el source file.)
823 `allout-default-layout' describes the specification format.
824 `allout-layout' can additionally have the value `t', in which
825 case the value of `allout-default-layout' is used.")
826 (make-variable-buffer-local 'allout-layout
)
828 (put 'allout-layout
'safe-local-variable
829 '(lambda (x) (or (numberp x
) (listp x
) (memq x
'(: * + -
)))))
831 ;;;_ : Topic header format
833 (defvar allout-regexp
""
834 "*Regular expression to match the beginning of a heading line.
836 Any line whose beginning matches this regexp is considered a
837 heading. This var is set according to the user configuration vars
838 by `set-allout-regexp'.")
839 (make-variable-buffer-local 'allout-regexp
)
840 ;;;_ = allout-bullets-string
841 (defvar allout-bullets-string
""
842 "A string dictating the valid set of outline topic bullets.
844 This var should *not* be set by the user - it is set by `set-allout-regexp',
845 and is produced from the elements of `allout-plain-bullets-string'
846 and `allout-distinctive-bullets-string'.")
847 (make-variable-buffer-local 'allout-bullets-string
)
848 ;;;_ = allout-bullets-string-len
849 (defvar allout-bullets-string-len
0
850 "Length of current buffers' `allout-plain-bullets-string'.")
851 (make-variable-buffer-local 'allout-bullets-string-len
)
852 ;;;_ = allout-depth-specific-regexp
853 (defvar allout-depth-specific-regexp
""
854 "*Regular expression to match a heading line prefix for a particular depth.
856 This expression is used to search for depth-specific topic
857 headers at depth 2 and greater. Use `allout-depth-one-regexp'
858 for to seek topics at depth one.
860 This var is set according to the user configuration vars by
861 `set-allout-regexp'. It is prepared with format strings for two
862 decimal numbers, which should each be one less than the depth of the
863 topic prefix to be matched.")
864 (make-variable-buffer-local 'allout-depth-specific-regexp
)
865 ;;;_ = allout-depth-one-regexp
866 (defvar allout-depth-one-regexp
""
867 "*Regular expression to match a heading line prefix for depth one.
869 This var is set according to the user configuration vars by
870 `set-allout-regexp'. It is prepared with format strings for two
871 decimal numbers, which should each be one less than the depth of the
872 topic prefix to be matched.")
873 (make-variable-buffer-local 'allout-depth-one-regexp
)
874 ;;;_ = allout-line-boundary-regexp
875 (defvar allout-line-boundary-regexp
()
876 "`allout-regexp' with outline style beginning-of-line anchor.
878 This is properly set by `set-allout-regexp'.")
879 (make-variable-buffer-local 'allout-line-boundary-regexp
)
880 ;;;_ = allout-bob-regexp
881 (defvar allout-bob-regexp
()
882 "Like `allout-line-boundary-regexp', for headers at beginning of buffer.")
883 (make-variable-buffer-local 'allout-bob-regexp
)
884 ;;;_ = allout-header-subtraction
885 (defvar allout-header-subtraction
(1- (length allout-header-prefix
))
886 "Allout-header prefix length to subtract when computing topic depth.")
887 (make-variable-buffer-local 'allout-header-subtraction
)
888 ;;;_ = allout-plain-bullets-string-len
889 (defvar allout-plain-bullets-string-len
(length allout-plain-bullets-string
)
890 "Length of `allout-plain-bullets-string', updated by `set-allout-regexp'.")
891 (make-variable-buffer-local 'allout-plain-bullets-string-len
)
893 ;;;_ = allout-doublecheck-at-and-shallower
894 (defconst allout-doublecheck-at-and-shallower
2
895 "Validate apparent topics of this depth and shallower as being non-aberrant.
897 Verified with `allout-aberrant-container-p'. This check's usefulness is
898 limited to shallow depths, because the determination of aberrance
899 is according to the mistaken item being followed by a legitimate item of
900 excessively greater depth.")
901 ;;;_ X allout-reset-header-lead (header-lead)
902 (defun allout-reset-header-lead (header-lead)
903 "*Reset the leading string used to identify topic headers."
904 (interactive "sNew lead string: ")
905 (setq allout-header-prefix header-lead
)
906 (setq allout-header-subtraction
(1- (length allout-header-prefix
)))
908 ;;;_ X allout-lead-with-comment-string (header-lead)
909 (defun allout-lead-with-comment-string (&optional header-lead
)
910 "*Set the topic-header leading string to specified string.
912 Useful when for encapsulating outline structure in programming
913 language comments. Returns the leading string."
916 (if (not (stringp header-lead
))
917 (setq header-lead
(read-string
918 "String prefix for topic headers: ")))
919 (setq allout-reindent-bodies nil
)
920 (allout-reset-header-lead header-lead
)
922 ;;;_ > allout-infer-header-lead-and-primary-bullet ()
923 (defun allout-infer-header-lead-and-primary-bullet ()
924 "Determine appropriate `allout-header-prefix' and `allout-primary-bullet'.
926 Works according to settings of:
929 `allout-header-prefix' (default)
930 `allout-use-mode-specific-leader'
931 and `allout-mode-leaders'.
933 Apply this via (re)activation of `allout-mode', rather than
934 invoking it directly."
935 (let* ((use-leader (and (boundp 'allout-use-mode-specific-leader
)
936 (if (or (stringp allout-use-mode-specific-leader
)
937 (memq allout-use-mode-specific-leader
938 '(allout-mode-leaders
941 allout-use-mode-specific-leader
942 ;; Oops - garbled value, equate with effect of 't:
946 ((not use-leader
) nil
)
947 ;; Use the explicitly designated leader:
948 ((stringp use-leader
) use-leader
)
949 (t (or (and (memq use-leader
'(t allout-mode-leaders
))
950 ;; Get it from outline mode leaders?
951 (cdr (assq major-mode allout-mode-leaders
)))
952 ;; ... didn't get from allout-mode-leaders...
953 (and (memq use-leader
'(t comment-start
))
955 ;; Use comment-start, maybe tripled, and with
959 (substring comment-start
960 (1- (length comment-start
))))
961 ;; Use comment-start, sans trailing space:
962 (substring comment-start
0 -
1)
963 (concat comment-start comment-start comment-start
))
964 ;; ... and append underscore, whichever:
968 (setq allout-header-prefix leader
)
969 (if (not allout-old-style-prefixes
)
970 ;; setting allout-primary-bullet makes the top level topics use -
971 ;; actually, be - the special prefix:
972 (setq allout-primary-bullet leader
))
973 allout-header-prefix
)))
974 (defalias 'allout-infer-header-lead
975 'allout-infer-header-lead-and-primary-bullet
)
976 ;;;_ > allout-infer-body-reindent ()
977 (defun allout-infer-body-reindent ()
978 "Determine proper setting for `allout-reindent-bodies'.
980 Depends on default setting of `allout-reindent-bodies' (which see)
981 and presence of setting for `comment-start', to tell whether the
982 file is programming code."
983 (if (and allout-reindent-bodies
985 (not (eq 'force allout-reindent-bodies
)))
986 (setq allout-reindent-bodies nil
)))
987 ;;;_ > set-allout-regexp ()
988 (defun set-allout-regexp ()
989 "Generate proper topic-header regexp form for outline functions.
991 Works with respect to `allout-plain-bullets-string' and
992 `allout-distinctive-bullets-string'.
994 Also refresh various data structures that hinge on the regexp."
997 ;; Derive allout-bullets-string from user configured components:
998 (setq allout-bullets-string
"")
999 (let ((strings (list 'allout-plain-bullets-string
1000 'allout-distinctive-bullets-string
1001 'allout-primary-bullet
))
1008 (setq cur-len
(length (setq cur-string
(symbol-value (car strings
)))))
1009 (while (< index cur-len
)
1010 (setq cur-char
(aref cur-string index
))
1011 (setq allout-bullets-string
1012 (concat allout-bullets-string
1014 ; Single dash would denote a
1015 ; sequence, repeated denotes
1017 ((eq cur-char ?-
) "--")
1018 ; literal close-square-bracket
1019 ; doesn't work right in the
1021 ((eq cur-char ?\
]) "")
1022 (t (regexp-quote (char-to-string cur-char
))))))
1023 (setq index
(1+ index
)))
1024 (setq strings
(cdr strings
)))
1026 ;; Derive next for repeated use in allout-pending-bullet:
1027 (setq allout-plain-bullets-string-len
(length allout-plain-bullets-string
))
1028 (setq allout-header-subtraction
(1- (length allout-header-prefix
)))
1030 (let (new-part old-part
)
1031 (setq new-part
(concat "\\("
1032 (regexp-quote allout-header-prefix
)
1034 ;; already regexp-quoted in a custom way:
1035 "[" allout-bullets-string
"]"
1037 old-part
(concat "\\("
1038 (regexp-quote allout-primary-bullet
)
1040 (regexp-quote allout-header-prefix
)
1043 " ?[^" allout-primary-bullet
"]")
1044 allout-regexp
(concat new-part
1049 allout-line-boundary-regexp
(concat "\n" new-part
1053 allout-bob-regexp
(concat "\\`" new-part
1057 (setq allout-depth-specific-regexp
1058 (concat "\\(^\\|\\`\\)"
1061 ;; new-style spacers-then-bullet string:
1063 (allout-format-quote (regexp-quote allout-header-prefix
))
1065 "[" (allout-format-quote allout-bullets-string
) "]"
1068 ;; old-style all-bullets string, if primary not multi-char:
1069 (if (< 0 allout-header-subtraction
)
1072 (allout-format-quote
1073 (regexp-quote allout-primary-bullet
))
1074 (allout-format-quote
1075 (regexp-quote allout-primary-bullet
))
1076 (allout-format-quote
1077 (regexp-quote allout-primary-bullet
))
1079 ;; disqualify greater depths:
1081 (allout-format-quote allout-primary-bullet
)
1086 (setq allout-depth-one-regexp
1087 (concat "\\(^\\|\\`\\)"
1091 (regexp-quote allout-header-prefix
)
1092 ;; disqualify any bullet char following any amount of
1093 ;; intervening whitespace:
1095 (concat "[^ " allout-bullets-string
"]")
1097 (if (< 0 allout-header-subtraction
)
1098 ;; Need not support anything like the old
1099 ;; bullet style if the prefix is multi-char.
1102 (regexp-quote allout-primary-bullet
)
1103 ;; disqualify deeper primary-bullet sequences:
1104 "[^" allout-primary-bullet
"]"))
1108 ;;;_ = allout-mode-map
1109 (defvar allout-mode-map nil
"Keybindings for (allout) outline minor mode.")
1110 ;;;_ > produce-allout-mode-map (keymap-alist &optional base-map)
1111 (defun produce-allout-mode-map (keymap-list &optional base-map
)
1112 "Produce keymap for use as allout-mode-map, from KEYMAP-LIST.
1114 Built on top of optional BASE-MAP, or empty sparse map if none specified.
1115 See doc string for allout-keybindings-list for format of binding list."
1116 (let ((map (or base-map
(make-sparse-keymap)))
1117 (pref (list allout-command-prefix
)))
1120 (let ((add-pref (null (cdr (cdr cell
))))
1121 (key-suff (list (car cell
))))
1124 (apply 'concat
(if add-pref
1125 (append pref key-suff
)
1127 (car (cdr cell
)))))))
1131 (defvar allout-mode-exposure-menu
)
1132 (defvar allout-mode-editing-menu
)
1133 (defvar allout-mode-navigation-menu
)
1134 (defvar allout-mode-misc-menu
)
1135 (defun produce-allout-mode-menubar-entries ()
1137 (easy-menu-define allout-mode-exposure-menu
1139 "Allout outline exposure menu."
1141 ["Show Entry" allout-show-current-entry t
]
1142 ["Show Children" allout-show-children t
]
1143 ["Show Subtree" allout-show-current-subtree t
]
1144 ["Hide Subtree" allout-hide-current-subtree t
]
1145 ["Hide Leaves" allout-hide-current-leaves t
]
1147 ["Show All" allout-show-all t
]))
1148 (easy-menu-define allout-mode-editing-menu
1150 "Allout outline editing menu."
1152 ["Open Sibling" allout-open-sibtopic t
]
1153 ["Open Subtopic" allout-open-subtopic t
]
1154 ["Open Supertopic" allout-open-supertopic t
]
1156 ["Shift Topic In" allout-shift-in t
]
1157 ["Shift Topic Out" allout-shift-out t
]
1158 ["Rebullet Topic" allout-rebullet-topic t
]
1159 ["Rebullet Heading" allout-rebullet-current-heading t
]
1160 ["Number Siblings" allout-number-siblings t
]
1162 ["Toggle Topic Encryption"
1163 allout-toggle-current-subtree-encryption
1164 (> (allout-current-depth) 1)]))
1165 (easy-menu-define allout-mode-navigation-menu
1167 "Allout outline navigation menu."
1169 ["Next Visible Heading" allout-next-visible-heading t
]
1170 ["Previous Visible Heading"
1171 allout-previous-visible-heading t
]
1173 ["Up Level" allout-up-current-level t
]
1174 ["Forward Current Level" allout-forward-current-level t
]
1175 ["Backward Current Level"
1176 allout-backward-current-level t
]
1178 ["Beginning of Entry"
1179 allout-beginning-of-current-entry t
]
1180 ["End of Entry" allout-end-of-entry t
]
1181 ["End of Subtree" allout-end-of-current-subtree t
]))
1182 (easy-menu-define allout-mode-misc-menu
1184 "Allout outlines miscellaneous bindings."
1186 ["Version" allout-version t
]
1188 ["Duplicate Exposed" allout-copy-exposed-to-buffer t
]
1189 ["Duplicate Exposed, numbered"
1190 allout-flatten-exposed-to-buffer t
]
1191 ["Duplicate Exposed, indented"
1192 allout-indented-exposed-to-buffer t
]
1194 ["Set Header Lead" allout-reset-header-lead t
]
1195 ["Set New Exposure" allout-expose-topic t
])))
1196 ;;;_ : Allout Modal-Variables Utilities
1197 ;;;_ = allout-mode-prior-settings
1198 (defvar allout-mode-prior-settings nil
1199 "Internal `allout-mode' use; settings to be resumed on mode deactivation.
1201 See `allout-add-resumptions' and `allout-do-resumptions'.")
1202 (make-variable-buffer-local 'allout-mode-prior-settings
)
1203 ;;;_ > allout-add-resumptions (&rest pairs)
1204 (defun allout-add-resumptions (&rest pairs
)
1205 "Set name/value PAIRS.
1207 Old settings are preserved for later resumption using `allout-do-resumptions'.
1209 The new values are set as a buffer local. On resumption, the prior buffer
1210 scope of the variable is restored along with its value. If it was a void
1211 buffer-local value, then it is left as nil on resumption.
1213 The pairs are lists whose car is the name of the variable and car of the
1214 cdr is the new value: '(some-var some-value)'. The pairs can actually be
1215 triples, where the third element qualifies the disposition of the setting,
1216 as described further below.
1218 If the optional third element is the symbol 'extend, then the new value
1219 created by `cons'ing the second element of the pair onto the front of the
1222 If the optional third element is the symbol 'append, then the new value is
1223 extended from the existing one by `append'ing a list containing the second
1224 element of the pair onto the end of the existing value.
1226 Extension, and resumptions in general, should not be used for hook
1227 functions - use the 'local mode of `add-hook' for that, instead.
1229 The settings are stored on `allout-mode-prior-settings'."
1231 (let* ((pair (pop pairs
))
1234 (qualifier (if (> (length pair
) 2)
1237 (if (not (symbolp name
))
1238 (error "Pair's name, %S, must be a symbol, not %s"
1239 name
(type-of name
)))
1240 (setq prior-value
(condition-case nil
1242 (void-variable nil
)))
1243 (when (not (assoc name allout-mode-prior-settings
))
1244 ;; Not already added as a resumption, create the prior setting entry.
1245 (if (local-variable-p name
)
1246 ;; is already local variable - preserve the prior value:
1247 (push (list name prior-value
) allout-mode-prior-settings
)
1248 ;; wasn't local variable, indicate so for resumption by killing
1249 ;; local value, and make it local:
1250 (push (list name
) allout-mode-prior-settings
)
1251 (make-local-variable name
)))
1253 (cond ((eq qualifier
'extend
)
1254 (if (not (listp prior-value
))
1255 (error "extension of non-list prior value attempted")
1256 (set name
(cons value prior-value
))))
1257 ((eq qualifier
'append
)
1258 (if (not (listp prior-value
))
1259 (error "appending of non-list prior value attempted")
1260 (set name
(append prior-value
(list value
)))))
1261 (t (error "unrecognized setting qualifier `%s' encountered"
1263 (set name value
)))))
1264 ;;;_ > allout-do-resumptions ()
1265 (defun allout-do-resumptions ()
1266 "Resume all name/value settings registered by `allout-add-resumptions'.
1268 This is used when concluding allout-mode, to resume selected variables to
1269 their settings before allout-mode was started."
1271 (while allout-mode-prior-settings
1272 (let* ((pair (pop allout-mode-prior-settings
))
1274 (value-cell (cdr pair
)))
1275 (if (not value-cell
)
1276 ;; Prior value was global:
1277 (kill-local-variable name
)
1278 ;; Prior value was explicit:
1279 (set name
(car value-cell
))))))
1280 ;;;_ : Mode-specific incidentals
1281 ;;;_ > allout-unprotected (expr)
1282 (defmacro allout-unprotected
(expr)
1283 "Enable internal outline operations to alter invisible text."
1284 `(let ((inhibit-read-only (if (not buffer-read-only
) t
))
1285 (inhibit-field-text-motion t
))
1287 ;;;_ = allout-mode-hook
1288 (defvar allout-mode-hook nil
1289 "*Hook that's run when allout mode starts.")
1290 ;;;_ = allout-mode-deactivate-hook
1291 (defvar allout-mode-deactivate-hook nil
1292 "*Hook that's run when allout mode ends.")
1293 ;;;_ = allout-exposure-category
1294 (defvar allout-exposure-category nil
1295 "Symbol for use as allout invisible-text overlay category.")
1296 ;;;_ x allout-view-change-hook
1297 (defvar allout-view-change-hook nil
1298 "*(Deprecated) A hook run after allout outline exposure changes.
1300 Switch to using `allout-exposure-change-hook' instead. Both hooks are
1301 currently respected, but the other conveys the details of the exposure
1302 change via explicit parameters, and this one will eventually be disabled in
1303 a subsequent allout version.")
1304 ;;;_ = allout-exposure-change-hook
1305 (defvar allout-exposure-change-hook nil
1306 "*Hook that's run after allout outline subtree exposure changes.
1308 It is run at the conclusion of `allout-flag-region'.
1310 Functions on the hook must take three arguments:
1312 - from - integer indicating the point at the start of the change.
1313 - to - integer indicating the point of the end of the change.
1314 - flag - change mode: nil for exposure, otherwise concealment.
1316 This hook might be invoked multiple times by a single command.
1318 This hook is replacing `allout-view-change-hook', which is being deprecated
1319 and eventually will not be invoked.")
1320 ;;;_ = allout-structure-added-hook
1321 (defvar allout-structure-added-hook nil
1322 "*Hook that's run after addition of items to the outline.
1324 Functions on the hook should take two arguments:
1326 - new-start - integer indicating the point at the start of the first new item.
1327 - new-end - integer indicating the point of the end of the last new item.
1329 Some edits that introduce new items may missed by this hook -
1330 specifically edits that native allout routines do not control.
1332 This hook might be invoked multiple times by a single command.")
1333 ;;;_ = allout-structure-deleted-hook
1334 (defvar allout-structure-deleted-hook nil
1335 "*Hook that's run after disciplined deletion of subtrees from the outline.
1337 Functions on the hook must take two arguments:
1339 - depth - integer indicating the depth of the subtree that was deleted.
1340 - removed-from - integer indicating the point where the subtree was removed.
1342 Some edits that remove or invalidate items may missed by this hook -
1343 specifically edits that native allout routines do not control.
1345 This hook might be invoked multiple times by a single command.")
1346 ;;;_ = allout-structure-shifted-hook
1347 (defvar allout-structure-shifted-hook nil
1348 "*Hook that's run after shifting of items in the outline.
1350 Functions on the hook should take two arguments:
1352 - depth-change - integer indicating depth increase, negative for decrease
1353 - start - integer indicating the start point of the shifted parent item.
1355 Some edits that shift items can be missed by this hook - specifically edits
1356 that native allout routines do not control.
1358 This hook might be invoked multiple times by a single command.")
1359 ;;;_ = allout-outside-normal-auto-fill-function
1360 (defvar allout-outside-normal-auto-fill-function nil
1361 "Value of normal-auto-fill-function outside of allout mode.
1363 Used by allout-auto-fill to do the mandated normal-auto-fill-function
1364 wrapped within allout's automatic fill-prefix setting.")
1365 (make-variable-buffer-local 'allout-outside-normal-auto-fill-function
)
1366 ;;;_ = file-var-bug hack
1367 (defvar allout-v18
/19-file-var-hack nil
1368 "Horrible hack used to prevent invalid multiple triggering of outline
1369 mode from prop-line file-var activation. Used by `allout-mode' function
1371 ;;;_ = allout-passphrase-verifier-string
1372 (defvar allout-passphrase-verifier-string nil
1373 "Setting used to test solicited encryption passphrases against the one
1374 already associated with a file.
1376 It consists of an encrypted random string useful only to verify that a
1377 passphrase entered by the user is effective for decryption. The passphrase
1378 itself is \*not* recorded in the file anywhere, and the encrypted contents
1379 are random binary characters to avoid exposing greater susceptibility to
1382 The verifier string is retained as an Emacs file variable, as well as in
1383 the Emacs buffer state, if file variable adjustments are enabled. See
1384 `allout-enable-file-variable-adjustment' for details about that.")
1385 (make-variable-buffer-local 'allout-passphrase-verifier-string
)
1387 (put 'allout-passphrase-verifier-string
'safe-local-variable
'stringp
)
1388 ;;;_ = allout-passphrase-hint-string
1389 (defvar allout-passphrase-hint-string
""
1390 "Variable used to retain reminder string for file's encryption passphrase.
1392 See the description of `allout-passphrase-hint-handling' for details about how
1393 the reminder is deployed.
1395 The hint is retained as an Emacs file variable, as well as in the Emacs buffer
1396 state, if file variable adjustments are enabled. See
1397 `allout-enable-file-variable-adjustment' for details about that.")
1398 (make-variable-buffer-local 'allout-passphrase-hint-string
)
1399 (setq-default allout-passphrase-hint-string
"")
1401 (put 'allout-passphrase-hint-string
'safe-local-variable
'stringp
)
1402 ;;;_ = allout-after-save-decrypt
1403 (defvar allout-after-save-decrypt nil
1404 "Internal variable, is nil or has the value of two points:
1406 - the location of a topic to be decrypted after saving is done
1407 - where to situate the cursor after the decryption is performed
1409 This is used to decrypt the topic that was currently being edited, if it
1410 was encrypted automatically as part of a file write or autosave.")
1411 (make-variable-buffer-local 'allout-after-save-decrypt
)
1412 ;;;_ = allout-encryption-plaintext-sanitization-regexps
1413 (defvar allout-encryption-plaintext-sanitization-regexps nil
1414 "List of regexps whose matches are removed from plaintext before encryption.
1416 This is for the sake of removing artifacts, like escapes, that are added on
1417 and not actually part of the original plaintext. The removal is done just
1418 prior to encryption.
1420 Entries must be symbols that are bound to the desired values.
1422 Each value can be a regexp or a list with a regexp followed by a
1423 substitution string. If it's just a regexp, all its matches are removed
1424 before the text is encrypted. If it's a regexp and a substitution, the
1425 substition is used against the regexp matches, a la `replace-match'.")
1426 (make-variable-buffer-local 'allout-encryption-text-removal-regexps
)
1427 ;;;_ = allout-encryption-ciphertext-rejection-regexps
1428 (defvar allout-encryption-ciphertext-rejection-regexps nil
1429 "Variable for regexps matching plaintext to remove before encryption.
1431 This is for the sake of redoing encryption in cases where the ciphertext
1432 incidentally contains strings that would disrupt mode operation -
1433 for example, a line that happens to look like an allout-mode topic prefix.
1435 Entries must be symbols that are bound to the desired regexp values.
1437 The encryption will be retried up to
1438 `allout-encryption-ciphertext-rejection-limit' times, after which an error
1441 (make-variable-buffer-local 'allout-encryption-ciphertext-rejection-regexps
)
1442 ;;;_ = allout-encryption-ciphertext-rejection-ceiling
1443 (defvar allout-encryption-ciphertext-rejection-ceiling
5
1444 "Limit on number of times encryption ciphertext is rejected.
1446 See `allout-encryption-ciphertext-rejection-regexps' for rejection reasons.")
1447 (make-variable-buffer-local 'allout-encryption-ciphertext-rejection-ceiling
)
1448 ;;;_ > allout-mode-p ()
1449 ;; Must define this macro above any uses, or byte compilation will lack
1450 ;; proper def, if file isn't loaded - eg, during emacs build!
1451 (defmacro allout-mode-p
()
1452 "Return t if `allout-mode' is active in current buffer."
1454 ;;;_ > allout-write-file-hook-handler ()
1455 (defun allout-write-file-hook-handler ()
1456 "Implement `allout-encrypt-unencrypted-on-saves' policy for file writes."
1458 (if (or (not (allout-mode-p))
1459 (not (boundp 'allout-encrypt-unencrypted-on-saves
))
1460 (not allout-encrypt-unencrypted-on-saves
))
1462 (let ((except-mark (and (equal allout-encrypt-unencrypted-on-saves
1465 (if (save-excursion (goto-char (point-min))
1466 (allout-next-topic-pending-encryption except-mark
))
1468 (message "auto-encrypting pending topics")
1470 (condition-case failure
1471 (setq allout-after-save-decrypt
1472 (allout-encrypt-decrypted except-mark
))
1475 "allout-write-file-hook-handler suppressing error %s"
1480 ;;;_ > allout-auto-save-hook-handler ()
1481 (defun allout-auto-save-hook-handler ()
1482 "Implement `allout-encrypt-unencrypted-on-saves' policy for auto save."
1484 (if (and (allout-mode-p) allout-encrypt-unencrypted-on-saves
)
1485 ;; Always implement 'except-current policy when enabled.
1486 (let ((allout-encrypt-unencrypted-on-saves 'except-current
))
1487 (allout-write-file-hook-handler))))
1488 ;;;_ > allout-after-saves-handler ()
1489 (defun allout-after-saves-handler ()
1490 "Decrypt topic encrypted for save, if it's currently being edited.
1492 Ie, if it was pending encryption and contained the point in its body before
1495 We use values stored in `allout-after-save-decrypt' to locate the topic
1496 and the place for the cursor after the decryption is done."
1497 (if (not (and (allout-mode-p)
1498 (boundp 'allout-after-save-decrypt
)
1499 allout-after-save-decrypt
))
1501 (goto-char (car allout-after-save-decrypt
))
1502 (let ((was-modified (buffer-modified-p)))
1503 (allout-toggle-subtree-encryption)
1504 (if (not was-modified
)
1505 (set-buffer-modified-p nil
)))
1506 (goto-char (cadr allout-after-save-decrypt
))
1507 (setq allout-after-save-decrypt nil
))
1509 ;;;_ = allout-inhibit-aberrance-doublecheck nil
1510 ;; In some exceptional moments, disparate topic depths need to be allowed
1511 ;; momentarily, eg when one topic is being yanked into another and they're
1512 ;; about to be reconciled. let-binding allout-inhibit-aberrance-doublecheck
1513 ;; prevents the aberrance doublecheck to allow, eg, the reconciliation
1514 ;; processing to happen in the presence of such discrepancies. It should
1515 ;; almost never be needed, however.
1516 (defvar allout-inhibit-aberrance-doublecheck nil
1517 "Internal state, for momentarily inhibits aberrance doublecheck.
1519 This should only be momentarily let-bound non-nil, not set
1520 non-nil in a lasting way.")
1522 ;;;_ #2 Mode activation
1523 ;;;_ = allout-explicitly-deactivated
1524 (defvar allout-explicitly-deactivated nil
1525 "If t, `allout-mode's last deactivation was deliberate.
1526 So `allout-post-command-business' should not reactivate it...")
1527 (make-variable-buffer-local 'allout-explicitly-deactivated
)
1528 ;;;_ > allout-init (&optional mode)
1529 (defun allout-init (&optional mode
)
1530 "Prime `allout-mode' to enable/disable auto-activation, wrt `allout-layout'.
1532 MODE is one of the following symbols:
1534 - nil (or no argument) deactivate auto-activation/layout;
1535 - `activate', enable auto-activation only;
1536 - `ask', enable auto-activation, and enable auto-layout but with
1537 confirmation for layout operation solicited from user each time;
1538 - `report', just report and return the current auto-activation state;
1539 - anything else (eg, t) for auto-activation and auto-layout, without
1540 any confirmation check.
1542 Use this function to setup your Emacs session for automatic activation
1543 of allout outline mode, contingent to the buffer-specific setting of
1544 the `allout-layout' variable. (See `allout-layout' and
1545 `allout-expose-topic' docstrings for more details on auto layout).
1547 `allout-init' works by setting up (or removing) the `allout-mode'
1548 find-file-hook, and giving `allout-auto-activation' a suitable
1551 To prime your Emacs session for full auto-outline operation, include
1552 the following two lines in your Emacs init file:
1562 (concat "Select outline auto setup mode "
1563 "(empty for report, ? for options) ")
1564 '(("nil")("full")("activate")("deactivate")
1565 ("ask") ("report") (""))
1568 (if (string= mode
"")
1570 (setq mode
(intern-soft mode
)))))
1572 ;; convenience aliases, for consistent ref to respective vars:
1573 ((hook 'allout-find-file-hook
)
1574 (find-file-hook-var-name (if (boundp 'find-file-hook
)
1577 (curr-mode 'allout-auto-activation
))
1580 (set find-file-hook-var-name
1581 (delq hook
(symbol-value find-file-hook-var-name
)))
1583 (message "Allout outline mode auto-activation inhibited.")))
1585 (if (not (memq hook
(symbol-value find-file-hook-var-name
)))
1587 ;; Just punt and use the reports from each of the modes:
1588 (allout-init (symbol-value curr-mode
))))
1589 (t (add-hook find-file-hook-var-name hook
)
1590 (set curr-mode
; `set', not `setq'!
1591 (cond ((eq mode
'activate
)
1593 "Outline mode auto-activation enabled.")
1596 ;; Return the current mode setting:
1600 (concat "Outline mode auto-activation and "
1601 "-layout (upon confirmation) enabled."))
1604 "Outline mode auto-activation and -layout enabled.")
1606 ;;;_ > allout-setup-menubar ()
1607 (defun allout-setup-menubar ()
1608 "Populate the current buffer's menubar with `allout-mode' stuff."
1609 (let ((menus (list allout-mode-exposure-menu
1610 allout-mode-editing-menu
1611 allout-mode-navigation-menu
1612 allout-mode-misc-menu
))
1615 (setq cur
(car menus
)
1617 (easy-menu-add cur
))))
1618 ;;;_ > allout-overlay-preparations
1619 (defun allout-overlay-preparations ()
1620 "Set the properties of the allout invisible-text overlay and others."
1621 (setplist 'allout-exposure-category nil
)
1622 (put 'allout-exposure-category
'invisible
'allout
)
1623 (put 'allout-exposure-category
'evaporate t
)
1624 ;; XXX We use isearch-open-invisible *and* isearch-mode-end-hook. The
1625 ;; latter would be sufficient, but it seems that a separate behavior -
1626 ;; the _transient_ opening of invisible text during isearch - is keyed to
1627 ;; presence of the isearch-open-invisible property - even though this
1628 ;; property controls the isearch _arrival_ behavior. This is the case at
1629 ;; least in emacs 21, 22.0, and xemacs 21.4.
1630 (put 'allout-exposure-category
'isearch-open-invisible
1631 'allout-isearch-end-handler
)
1632 (if (featurep 'xemacs
)
1633 (put 'allout-exposure-category
'start-open t
)
1634 (put 'allout-exposure-category
'insert-in-front-hooks
1635 '(allout-overlay-insert-in-front-handler)))
1636 (put 'allout-exposure-category
'modification-hooks
1637 '(allout-overlay-interior-modification-handler)))
1638 ;;;_ > allout-mode (&optional toggle)
1641 (defun allout-mode (&optional toggle
)
1643 "Toggle minor mode for controlling exposure and editing of text outlines.
1646 Optional arg forces mode to re-initialize iff arg is positive num or
1647 symbol. Allout outline mode always runs as a minor mode.
1649 Allout outline mode provides extensive outline oriented formatting and
1650 manipulation. It enables structural editing of outlines, as well as
1651 navigation and exposure. It also is specifically aimed at
1652 accommodating syntax-sensitive text like programming languages. (For
1653 an example, see the allout code itself, which is organized as an allout
1656 In addition to typical outline navigation and exposure, allout includes:
1658 - topic-oriented authoring, including keystroke-based topic creation,
1659 repositioning, promotion/demotion, cut, and paste
1660 - incremental search with dynamic exposure and reconcealment of hidden text
1661 - adjustable format, so programming code can be developed in outline-structure
1662 - easy topic encryption and decryption
1663 - \"Hot-spot\" operation, for single-keystroke maneuvering and exposure control
1664 - integral outline layout, for automatic initial exposure when visiting a file
1665 - independent extensibility, using comprehensive exposure and authoring hooks
1667 and many other features.
1669 Below is a description of the key bindings, and then explanation of
1670 special `allout-mode' features and terminology. See also the outline
1671 menubar additions for quick reference to many of the features, and see
1672 the docstring of the function `allout-init' for instructions on
1673 priming your emacs session for automatic activation of `allout-mode'.
1675 The bindings are dictated by the customizable `allout-keybindings-list'
1676 variable. We recommend customizing `allout-command-prefix' to use just
1677 `\\C-c' as the command prefix, if the allout bindings don't conflict with
1678 any personal bindings you have on \\C-c. In any case, outline structure
1679 navigation and authoring is simplified by positioning the cursor on an
1680 item's bullet character, the \"hot-spot\" - then you can invoke allout
1681 commands with just the un-prefixed, un-control-shifted command letters.
1682 This is described further in the HOT-SPOT Operation section.
1686 \\[allout-hide-current-subtree] `allout-hide-current-subtree'
1687 \\[allout-show-children] `allout-show-children'
1688 \\[allout-show-current-subtree] `allout-show-current-subtree'
1689 \\[allout-show-current-entry] `allout-show-current-entry'
1690 \\[allout-show-all] `allout-show-all'
1694 \\[allout-next-visible-heading] `allout-next-visible-heading'
1695 \\[allout-previous-visible-heading] `allout-previous-visible-heading'
1696 \\[allout-up-current-level] `allout-up-current-level'
1697 \\[allout-forward-current-level] `allout-forward-current-level'
1698 \\[allout-backward-current-level] `allout-backward-current-level'
1699 \\[allout-end-of-entry] `allout-end-of-entry'
1700 \\[allout-beginning-of-current-entry] `allout-beginning-of-current-entry' (alternately, goes to hot-spot)
1701 \\[allout-beginning-of-line] `allout-beginning-of-line' - like regular beginning-of-line, but
1702 if immediately repeated cycles to the beginning of the current item
1703 and then to the hot-spot (if `allout-beginning-of-line-cycles' is set).
1706 Topic Header Production:
1707 -----------------------
1708 \\[allout-open-sibtopic] `allout-open-sibtopic' Create a new sibling after current topic.
1709 \\[allout-open-subtopic] `allout-open-subtopic' ... an offspring of current topic.
1710 \\[allout-open-supertopic] `allout-open-supertopic' ... a sibling of the current topic's parent.
1712 Topic Level and Prefix Adjustment:
1713 ---------------------------------
1714 \\[allout-shift-in] `allout-shift-in' Shift current topic and all offspring deeper
1715 \\[allout-shift-out] `allout-shift-out' ... less deep
1716 \\[allout-rebullet-current-heading] `allout-rebullet-current-heading' Prompt for alternate bullet for
1718 \\[allout-rebullet-topic] `allout-rebullet-topic' Reconcile bullets of topic and
1719 its' offspring - distinctive bullets are not changed, others
1720 are alternated according to nesting depth.
1721 \\[allout-number-siblings] `allout-number-siblings' Number bullets of topic and siblings -
1722 the offspring are not affected.
1723 With repeat count, revoke numbering.
1725 Topic-oriented Killing and Yanking:
1726 ----------------------------------
1727 \\[allout-kill-topic] `allout-kill-topic' Kill current topic, including offspring.
1728 \\[allout-copy-topic-as-kill] `allout-copy-topic-as-kill' Copy current topic, including offspring.
1729 \\[allout-kill-line] `allout-kill-line' kill-line, attending to outline structure.
1730 \\[allout-copy-line-as-kill] `allout-copy-line-as-kill' Copy line but don't delete it.
1731 \\[allout-yank] `allout-yank' Yank, adjusting depth of yanked topic to
1732 depth of heading if yanking into bare topic
1733 heading (ie, prefix sans text).
1734 \\[allout-yank-pop] `allout-yank-pop' Is to allout-yank as yank-pop is to yank
1736 Topic-oriented Encryption:
1737 -------------------------
1738 \\[allout-toggle-current-subtree-encryption] `allout-toggle-current-subtree-encryption'
1739 Encrypt/Decrypt topic content
1743 M-x outlineify-sticky Activate outline mode for current buffer,
1744 and establish a default file-var setting
1745 for `allout-layout'.
1746 \\[allout-mark-topic] `allout-mark-topic'
1747 \\[allout-copy-exposed-to-buffer] `allout-copy-exposed-to-buffer'
1748 Duplicate outline, sans concealed text, to
1749 buffer with name derived from derived from that
1750 of current buffer - \"*BUFFERNAME exposed*\".
1751 \\[allout-flatten-exposed-to-buffer] `allout-flatten-exposed-to-buffer'
1752 Like above 'copy-exposed', but convert topic
1753 prefixes to section.subsection... numeric
1755 \\[eval-expression] (allout-init t) Setup Emacs session for outline mode
1760 Outline mode supports gpg encryption of topics, with support for
1761 symmetric and key-pair modes, passphrase timeout, passphrase
1762 consistency checking, user-provided hinting for symmetric key
1763 mode, and auto-encryption of topics pending encryption on save.
1765 Topics pending encryption are, by default, automatically
1766 encrypted during file saves. If the contents of the topic
1767 containing the cursor was encrypted for a save, it is
1768 automatically decrypted for continued editing.
1770 The aim of these measures is reliable topic privacy while
1771 preventing accidents like neglected encryption before saves,
1772 forgetting which passphrase was used, and other practical
1775 See `allout-toggle-current-subtree-encryption' function docstring
1776 and `allout-encrypt-unencrypted-on-saves' customization variable
1781 Hot-spot operation provides a means for easy, single-keystroke outline
1782 navigation and exposure control.
1784 When the text cursor is positioned directly on the bullet character of
1785 a topic, regular characters (a to z) invoke the commands of the
1786 corresponding allout-mode keymap control chars. For example, \"f\"
1787 would invoke the command typically bound to \"C-c<space>C-f\"
1788 \(\\[allout-forward-current-level] `allout-forward-current-level').
1790 Thus, by positioning the cursor on a topic bullet, you can
1791 execute the outline navigation and manipulation commands with a
1792 single keystroke. Regular navigation keys (eg, \\[forward-char], \\[next-line]) don't get
1793 this special translation, so you can use them to get out of the
1794 hot-spot and back to normal editing operation.
1796 In allout-mode, the normal beginning-of-line command (\\[allout-beginning-of-line]]) is
1797 replaced with one that makes it easy to get to the hot-spot. If you
1798 repeat it immediately it cycles (if `allout-beginning-of-line-cycles'
1799 is set) to the beginning of the item and then, if you hit it again
1800 immediately, to the hot-spot. Similarly, `allout-beginning-of-current-entry'
1801 \(\\[allout-beginning-of-current-entry]) moves to the hot-spot when the cursor is already located
1802 at the beginning of the current entry.
1806 Allout exposure and authoring activites all have associated
1807 hooks, by which independent code can cooperate with allout
1808 without changes to the allout core. Here are key ones:
1811 `allout-mode-deactivate-hook'
1812 `allout-exposure-change-hook'
1813 `allout-structure-added-hook'
1814 `allout-structure-deleted-hook'
1815 `allout-structure-shifted-hook'
1819 Topic hierarchy constituents - TOPICS and SUBTOPICS:
1821 ITEM: A unitary outline element, including the HEADER and ENTRY text.
1822 TOPIC: An ITEM and any ITEMs contained within it, ie having greater DEPTH
1823 and with no intervening items of lower DEPTH than the container.
1825 The visible ITEM most immediately containing the cursor.
1826 DEPTH: The degree of nesting of an ITEM; it increases with containment.
1827 The DEPTH is determined by the HEADER PREFIX. The DEPTH is also
1829 LEVEL: The same as DEPTH.
1832 Those ITEMs whose TOPICs contain an ITEM.
1833 PARENT: An ITEM's immediate ANCESTOR. It has a DEPTH one less than that
1836 The ITEMs contained within an ITEM's TOPIC.
1838 An OFFSPRING of its ANCESTOR TOPICs.
1840 An immediate SUBTOPIC of its PARENT.
1842 TOPICs having the same PARENT and DEPTH.
1844 Topic text constituents:
1846 HEADER: The first line of an ITEM, include the ITEM PREFIX and HEADER
1848 ENTRY: The text content of an ITEM, before any OFFSPRING, but including
1849 the HEADER text and distinct from the ITEM PREFIX.
1850 BODY: Same as ENTRY.
1851 PREFIX: The leading text of an ITEM which distinguishes it from normal
1852 ENTRY text. Allout recognizes the outline structure according
1853 to the strict PREFIX format. It consists of a PREFIX-LEAD string,
1854 PREFIX-PADDING, and a BULLET. The BULLET might be followed by a
1855 number, indicating the ordinal number of the topic among its
1856 siblings, or an asterisk indicating encryption, plus an optional
1857 space. After that is the ITEM HEADER text, which is not part of
1860 The relative length of the PREFIX determines the nesting DEPTH
1863 The string at the beginning of a HEADER PREFIX, by default a `.'.
1864 It can be customized by changing the setting of
1865 `allout-header-prefix' and then reinitializing `allout-mode'.
1867 When the PREFIX-LEAD is set to the comment-string of a
1868 programming language, outline structuring can be embedded in
1869 program code without interfering with processing of the text
1870 (by emacs or the language processor) as program code. This
1871 setting happens automatically when allout mode is used in
1872 programming-mode buffers. See `allout-use-mode-specific-leader'
1873 docstring for more detail.
1875 Spaces or asterisks which separate the PREFIX-LEAD and the
1876 bullet, determining the ITEM's DEPTH.
1877 BULLET: A character at the end of the ITEM PREFIX, it must be one of
1878 the characters listed on `allout-plain-bullets-string' or
1879 `allout-distinctive-bullets-string'. (See the documentation
1880 for these variables for more details.) The default choice of
1881 BULLET when generating ITEMs varies in a cycle with the DEPTH of
1885 The state of a TOPIC which determines the on-screen visibility
1886 of its OFFSPRING and contained ENTRY text.
1888 TOPICs and ENTRY text whose EXPOSURE is inhibited. Concealed
1889 text is represented by \"...\" ellipses.
1891 CONCEALED TOPICs are effectively collapsed within an ANCESTOR.
1892 CLOSED: A TOPIC whose immediate OFFSPRING and body-text is CONCEALED.
1893 OPEN: A TOPIC that is not CLOSED, though its OFFSPRING or BODY may be."
1897 (let* ((active (and (not (equal major-mode
'outline
))
1899 ; Massage universal-arg `toggle' val:
1901 (or (and (listp toggle
)(car toggle
))
1903 ; Activation specifically demanded?
1904 (explicit-activation (and toggle
1905 (or (symbolp toggle
)
1906 (and (wholenump toggle
)
1907 (not (zerop toggle
))))))
1908 ;; allout-mode already called once during this complex command?
1909 (same-complex-command (eq allout-v18
/19-file-var-hack
1910 (car command-history
)))
1911 (write-file-hook-var-name (cond ((boundp 'write-file-functions
)
1912 'write-file-functions
)
1913 ((boundp 'write-file-hooks
)
1915 (t 'local-write-file-hooks
)))
1919 ; See comments below re v19.18,.19 bug.
1920 (setq allout-v18
/19-file-var-hack
(car command-history
))
1924 ;; Provision for v19.18, 19.19 bug -
1925 ;; Emacs v 19.18, 19.19 file-var code invokes prop-line-designated
1926 ;; modes twice when file is visited. We have to avoid toggling mode
1927 ;; off on second invocation, so we detect it as best we can, and
1929 ((and same-complex-command
; Still in same complex command
1930 ; as last time `allout-mode' invoked.
1931 active
; Already activated.
1932 (not explicit-activation
) ; Prop-line file-vars don't have args.
1933 (string-match "^19.1[89]" ; Bug only known to be in v19.18 and
1934 emacs-version
)); 19.19.
1938 ((and (not explicit-activation
)
1940 ; Activation not explicitly
1941 ; requested, and either in
1942 ; active state or *de*activation
1943 ; specifically requested:
1944 (setq allout-explicitly-deactivated t
)
1946 (allout-do-resumptions)
1948 (remove-from-invisibility-spec '(allout . t
))
1949 (remove-hook 'pre-command-hook
'allout-pre-command-business t
)
1950 (remove-hook 'post-command-hook
'allout-post-command-business t
)
1951 (remove-hook 'before-change-functions
'allout-before-change-handler t
)
1952 (remove-hook 'isearch-mode-end-hook
'allout-isearch-end-handler t
)
1953 (remove-hook write-file-hook-var-name
'allout-write-file-hook-handler t
)
1954 (remove-hook 'auto-save-hook
'allout-auto-save-hook-handler t
)
1956 (remove-overlays (point-min) (point-max)
1957 'category
'allout-exposure-category
)
1959 (setq allout-mode nil
)
1960 (run-hooks 'allout-mode-deactivate-hook
))
1964 (setq allout-explicitly-deactivated nil
)
1965 (if allout-old-style-prefixes
1966 ;; Inhibit all the fancy formatting:
1967 (allout-add-resumptions '(allout-primary-bullet "*")))
1969 (allout-overlay-preparations) ; Doesn't hurt to redo this.
1971 (allout-infer-header-lead-and-primary-bullet)
1972 (allout-infer-body-reindent)
1975 (allout-add-resumptions
1976 '(allout-encryption-ciphertext-rejection-regexps
1977 allout-line-boundary-regexp
1979 '(allout-encryption-ciphertext-rejection-regexps
1983 ;; Produce map from current version of allout-keybindings-list:
1984 (allout-setup-mode-map)
1985 (produce-allout-mode-menubar-entries)
1987 ;; Include on minor-mode-map-alist, if not already there:
1988 (if (not (member '(allout-mode . allout-mode-map
)
1989 minor-mode-map-alist
))
1990 (setq minor-mode-map-alist
1991 (cons '(allout-mode . allout-mode-map
)
1992 minor-mode-map-alist
)))
1994 (add-to-invisibility-spec '(allout . t
))
1995 (allout-add-resumptions '(line-move-ignore-invisible t
))
1996 (add-hook 'pre-command-hook
'allout-pre-command-business nil t
)
1997 (add-hook 'post-command-hook
'allout-post-command-business nil t
)
1998 (add-hook 'before-change-functions
'allout-before-change-handler
2000 (add-hook 'isearch-mode-end-hook
'allout-isearch-end-handler nil t
)
2001 (add-hook write-file-hook-var-name
'allout-write-file-hook-handler
2003 (add-hook 'auto-save-hook
'allout-auto-save-hook-handler
2006 ;; Stash auto-fill settings and adjust so custom allout auto-fill
2007 ;; func will be used if auto-fill is active or activated. (The
2008 ;; custom func respects topic headline, maintains hanging-indents,
2010 (if (and auto-fill-function
(not allout-inhibit-auto-fill
))
2011 ;; allout-auto-fill will use the stashed values and so forth.
2012 (allout-add-resumptions '(auto-fill-function allout-auto-fill
)))
2013 (allout-add-resumptions (list 'allout-former-auto-filler
2015 ;; Register allout-auto-fill to be used if
2016 ;; filling is active:
2017 (list 'allout-outside-normal-auto-fill-function
2018 normal-auto-fill-function
)
2019 '(normal-auto-fill-function allout-auto-fill
)
2020 ;; Paragraphs are broken by topic headlines.
2021 (list 'paragraph-start
2022 (concat paragraph-start
"\\|^\\("
2023 allout-regexp
"\\)"))
2024 (list 'paragraph-separate
2025 (concat paragraph-separate
"\\|^\\("
2026 allout-regexp
"\\)")))
2027 (or (assq 'allout-mode minor-mode-alist
)
2028 (setq minor-mode-alist
2029 (cons '(allout-mode " Allout") minor-mode-alist
)))
2031 (allout-setup-menubar)
2036 (setq allout-mode t
)
2037 (run-hooks 'allout-mode-hook
))
2041 (allout-infer-body-reindent))
2042 ) ;; end of activation-mode cases.
2044 ;; Do auto layout if warranted:
2045 (let ((use-layout (if (listp allout-layout
)
2047 allout-default-layout
)))
2049 allout-auto-activation
2051 (and (not (eq allout-auto-activation
'activate
))
2052 (if (eq allout-auto-activation
'ask
)
2053 (if (y-or-n-p (format "Expose %s with layout '%s'? "
2057 (message "Skipped %s layout." (buffer-name))
2061 (message "Adjusting '%s' exposure..." (buffer-name))
2063 (allout-this-or-next-heading)
2066 (apply 'allout-expose-topic
(list use-layout
))
2067 (message "Adjusting '%s' exposure... done." (buffer-name)))
2068 ;; Problem applying exposure - notify user, but don't
2069 ;; interrupt, eg, file visit:
2070 (error (message "%s" (car (cdr err
)))
2076 (defun allout-setup-mode-map ()
2077 "Establish allout-mode bindings."
2078 (setq-default allout-mode-map
2079 (produce-allout-mode-map allout-keybindings-list
))
2080 (setq allout-mode-map
2081 (produce-allout-mode-map allout-keybindings-list
))
2082 (substitute-key-definition 'beginning-of-line
2083 'allout-beginning-of-line
2084 allout-mode-map global-map
)
2085 (substitute-key-definition 'move-beginning-of-line
2086 'allout-beginning-of-line
2087 allout-mode-map global-map
)
2088 (substitute-key-definition 'end-of-line
2090 allout-mode-map global-map
)
2091 (substitute-key-definition 'move-end-of-line
2093 allout-mode-map global-map
)
2094 (fset 'allout-mode-map allout-mode-map
))
2096 ;; ensure that allout-mode-map has some setting even if allout-mode hasn't
2098 (allout-setup-mode-map)
2100 ;;;_ > allout-minor-mode
2101 (defalias 'allout-minor-mode
'allout-mode
)
2103 ;;;_ - Position Assessment
2104 ;;;_ > allout-hidden-p (&optional pos)
2105 (defsubst allout-hidden-p
(&optional pos
)
2106 "Non-nil if the character after point is invisible."
2107 (eq (get-char-property (or pos
(point)) 'invisible
) 'allout
))
2109 ;;;_ > allout-overlay-insert-in-front-handler (ol after beg end
2110 ;;; &optional prelen)
2111 (defun allout-overlay-insert-in-front-handler (ol after beg end
2113 "Shift the overlay so stuff inserted in front of it are excluded."
2115 (move-overlay ol
(1+ beg
) (overlay-end ol
))))
2116 ;;;_ > allout-overlay-interior-modification-handler (ol after beg end
2117 ;;; &optional prelen)
2118 (defun allout-overlay-interior-modification-handler (ol after beg end
2120 "Get confirmation before making arbitrary changes to invisible text.
2122 We expose the invisible text and ask for confirmation. Refusal or
2123 keyboard-quit abandons the changes, with keyboard-quit additionally
2124 reclosing the opened text.
2126 No confirmation is necessary when inhibit-read-only is set - eg, allout
2127 internal functions use this feature cohesively bunch changes."
2129 (when (and (not inhibit-read-only
) (not after
))
2130 (let ((start (point))
2131 (ol-start (overlay-start ol
))
2132 (ol-end (overlay-end ol
))
2135 (while (< (point) end
)
2136 (when (allout-hidden-p)
2137 (allout-show-to-offshoot)
2138 (if (allout-hidden-p)
2139 (save-excursion (forward-char 1)
2140 (allout-show-to-offshoot)))
2142 (setq first
(point))))
2143 (goto-char (if (featurep 'xemacs
)
2144 (next-property-change (1+ (point)) nil end
)
2145 (next-char-property-change (1+ (point)) end
))))
2151 (substitute-command-keys
2152 (concat "Modify concealed text? (\"no\" just aborts,"
2153 " \\[keyboard-quit] also reconceals) "))))
2154 (progn (goto-char start
)
2155 (error "Concealed-text change refused.")))
2156 (quit (allout-flag-region ol-start ol-end nil
)
2157 (allout-flag-region ol-start ol-end t
)
2158 (error "Concealed-text change abandoned, text reconcealed."))))
2159 (goto-char start
))))
2160 ;;;_ > allout-before-change-handler (beg end)
2161 (defun allout-before-change-handler (beg end
)
2162 "Protect against changes to invisible text.
2164 See allout-overlay-interior-modification-handler for details."
2166 (if (and (allout-mode-p) undo-in-progress
(allout-hidden-p))
2167 (allout-show-to-offshoot))
2169 ;; allout-overlay-interior-modification-handler on an overlay handles
2170 ;; this in other emacs, via `allout-exposure-category's 'modification-hooks.
2171 (when (and (featurep 'xemacs
) (allout-mode-p))
2172 ;; process all of the pending overlays:
2175 (let ((overlay (allout-get-invisibility-overlay)))
2176 (allout-overlay-interior-modification-handler
2177 overlay nil beg end nil
)))))
2178 ;;;_ > allout-isearch-end-handler (&optional overlay)
2179 (defun allout-isearch-end-handler (&optional overlay
)
2180 "Reconcile allout outline exposure on arriving in hidden text after isearch.
2182 Optional OVERLAY parameter is for when this function is used by
2183 `isearch-open-invisible' overlay property. It is otherwise unused, so this
2184 function can also be used as an `isearch-mode-end-hook'."
2186 (if (and (allout-mode-p) (allout-hidden-p))
2187 (allout-show-to-offshoot)))
2189 ;;;_ #3 Internal Position State-Tracking - "allout-recent-*" funcs
2190 ;;; All the basic outline functions that directly do string matches to
2191 ;;; evaluate heading prefix location set the variables
2192 ;;; `allout-recent-prefix-beginning' and `allout-recent-prefix-end'
2193 ;;; when successful. Functions starting with `allout-recent-' all
2194 ;;; use this state, providing the means to avoid redundant searches
2195 ;;; for just-established data. This optimization can provide
2196 ;;; significant speed improvement, but it must be employed carefully.
2197 ;;;_ = allout-recent-prefix-beginning
2198 (defvar allout-recent-prefix-beginning
0
2199 "Buffer point of the start of the last topic prefix encountered.")
2200 (make-variable-buffer-local 'allout-recent-prefix-beginning
)
2201 ;;;_ = allout-recent-prefix-end
2202 (defvar allout-recent-prefix-end
0
2203 "Buffer point of the end of the last topic prefix encountered.")
2204 (make-variable-buffer-local 'allout-recent-prefix-end
)
2205 ;;;_ = allout-recent-depth
2206 (defvar allout-recent-depth
0
2207 "Depth of the last topic prefix encountered.")
2208 (make-variable-buffer-local 'allout-recent-depth
)
2209 ;;;_ = allout-recent-end-of-subtree
2210 (defvar allout-recent-end-of-subtree
0
2211 "Buffer point last returned by `allout-end-of-current-subtree'.")
2212 (make-variable-buffer-local 'allout-recent-end-of-subtree
)
2213 ;;;_ > allout-prefix-data ()
2214 (defsubst allout-prefix-data
()
2215 "Register allout-prefix state data.
2217 For reference by `allout-recent' funcs. Returns BEGINNING."
2218 (setq allout-recent-prefix-end
(or (match-end 1) (match-end 2))
2219 allout-recent-prefix-beginning
(or (match-beginning 1)
2220 (match-beginning 2))
2221 allout-recent-depth
(max 1 (- allout-recent-prefix-end
2222 allout-recent-prefix-beginning
2223 allout-header-subtraction
)))
2224 allout-recent-prefix-beginning
)
2225 ;;;_ > nullify-allout-prefix-data ()
2226 (defsubst nullify-allout-prefix-data
()
2227 "Mark allout prefix data as being uninformative."
2228 (setq allout-recent-prefix-end
(point)
2229 allout-recent-prefix-beginning
(point)
2230 allout-recent-depth
0)
2231 allout-recent-prefix-beginning
)
2232 ;;;_ > allout-recent-depth ()
2233 (defsubst allout-recent-depth
()
2234 "Return depth of last heading encountered by an outline maneuvering function.
2236 All outline functions which directly do string matches to assess
2237 headings set the variables `allout-recent-prefix-beginning' and
2238 `allout-recent-prefix-end' if successful. This function uses those settings
2239 to return the current depth."
2241 allout-recent-depth
)
2242 ;;;_ > allout-recent-prefix ()
2243 (defsubst allout-recent-prefix
()
2244 "Like `allout-recent-depth', but returns text of last encountered prefix.
2246 All outline functions which directly do string matches to assess
2247 headings set the variables `allout-recent-prefix-beginning' and
2248 `allout-recent-prefix-end' if successful. This function uses those settings
2249 to return the current prefix."
2250 (buffer-substring-no-properties allout-recent-prefix-beginning
2251 allout-recent-prefix-end
))
2252 ;;;_ > allout-recent-bullet ()
2253 (defmacro allout-recent-bullet
()
2254 "Like allout-recent-prefix, but returns bullet of last encountered prefix.
2256 All outline functions which directly do string matches to assess
2257 headings set the variables `allout-recent-prefix-beginning' and
2258 `allout-recent-prefix-end' if successful. This function uses those settings
2259 to return the current depth of the most recently matched topic."
2260 '(buffer-substring-no-properties (1- allout-recent-prefix-end
)
2261 allout-recent-prefix-end
))
2265 ;;;_ - Position Assessment
2266 ;;;_ : Location Predicates
2267 ;;;_ > allout-do-doublecheck ()
2268 (defsubst allout-do-doublecheck
()
2269 "True if current item conditions qualify for checking on topic aberrance."
2271 ;; presume integrity of outline and yanked content during yank - necessary,
2272 ;; to allow for level disparity of yank location and yanked text:
2273 (not allout-inhibit-aberrance-doublecheck
)
2274 ;; allout-doublecheck-at-and-shallower is ceiling for doublecheck:
2275 (<= allout-recent-depth allout-doublecheck-at-and-shallower
)))
2276 ;;;_ > allout-aberrant-container-p ()
2277 (defun allout-aberrant-container-p ()
2278 "True if topic, or next sibling with children, contains them discontinuously.
2280 Discontinuous means an immediate offspring that is nested more
2281 than one level deeper than the topic.
2283 If topic has no offspring, then the next sibling with offspring will
2284 determine whether or not this one is determined to be aberrant.
2286 If true, then the allout-recent-* settings are calibrated on the
2287 offspring that qaulifies it as aberrant, ie with depth that
2288 exceeds the topic by more than one."
2290 ;; This is most clearly understood when considering standard-prefix-leader
2291 ;; low-level topics, which can all too easily match text not intended as
2292 ;; headers. For example, any line with a leading '.' or '*' and lacking a
2293 ;; following bullet qualifies without this protection. (A sequence of
2294 ;; them can occur naturally, eg a typical textual bullet list.) We
2295 ;; disqualify such low-level sequences when they are followed by a
2296 ;; discontinuously contained child, inferring that the sequences are not
2297 ;; actually connected with their prospective context.
2299 (let ((depth (allout-depth))
2300 (start-point (point))
2303 (while (and (not done
)
2304 (re-search-forward allout-line-boundary-regexp nil
0))
2305 (allout-prefix-data)
2306 (goto-char allout-recent-prefix-beginning
)
2308 ;; sibling - continue:
2309 ((eq allout-recent-depth depth
))
2310 ;; first offspring is excessive - aberrant:
2311 ((> allout-recent-depth
(1+ depth
))
2312 (setq done t aberrant t
))
2313 ;; next non-sibling is lower-depth - not aberrant:
2314 (t (setq done t
)))))
2317 (goto-char start-point
)
2318 ;; recalibrate allout-recent-*
2321 ;;;_ > allout-on-current-heading-p ()
2322 (defun allout-on-current-heading-p ()
2323 "Return non-nil if point is on current visible topics' header line.
2325 Actually, returns prefix beginning point."
2327 (allout-beginning-of-current-line)
2328 (and (looking-at allout-regexp
)
2329 (allout-prefix-data)
2330 (or (not (allout-do-doublecheck))
2331 (not (allout-aberrant-container-p))))))
2332 ;;;_ > allout-on-heading-p ()
2333 (defalias 'allout-on-heading-p
'allout-on-current-heading-p
)
2334 ;;;_ > allout-e-o-prefix-p ()
2335 (defun allout-e-o-prefix-p ()
2336 "True if point is located where current topic prefix ends, heading begins."
2337 (and (save-excursion (let ((inhibit-field-text-motion t
))
2338 (beginning-of-line))
2339 (looking-at allout-regexp
))
2340 (= (point)(save-excursion (allout-end-of-prefix)(point)))))
2341 ;;;_ : Location attributes
2342 ;;;_ > allout-depth ()
2343 (defun allout-depth ()
2344 "Return depth of topic most immediately containing point.
2346 Return zero if point is not within any topic.
2348 Like `allout-current-depth', but respects hidden as well as visible topics."
2350 (let ((start-point (point)))
2351 (if (and (allout-goto-prefix)
2352 (not (< start-point
(point))))
2355 ;; Oops, no prefix, nullify it:
2356 (nullify-allout-prefix-data)
2357 ;; ... and return 0:
2359 ;;;_ > allout-current-depth ()
2360 (defun allout-current-depth ()
2361 "Return depth of visible topic most immediately containing point.
2363 Return zero if point is not within any topic."
2365 (if (allout-back-to-current-heading)
2367 (- allout-recent-prefix-end
2368 allout-recent-prefix-beginning
2369 allout-header-subtraction
))
2371 ;;;_ > allout-get-current-prefix ()
2372 (defun allout-get-current-prefix ()
2373 "Topic prefix of the current topic."
2375 (if (allout-goto-prefix)
2376 (allout-recent-prefix))))
2377 ;;;_ > allout-get-bullet ()
2378 (defun allout-get-bullet ()
2379 "Return bullet of containing topic (visible or not)."
2381 (and (allout-goto-prefix)
2382 (allout-recent-bullet))))
2383 ;;;_ > allout-current-bullet ()
2384 (defun allout-current-bullet ()
2385 "Return bullet of current (visible) topic heading, or none if none found."
2388 (allout-back-to-current-heading)
2389 (buffer-substring-no-properties (- allout-recent-prefix-end
1)
2390 allout-recent-prefix-end
))
2391 ;; Quick and dirty provision, ostensibly for missing bullet:
2392 (args-out-of-range nil
))
2394 ;;;_ > allout-get-prefix-bullet (prefix)
2395 (defun allout-get-prefix-bullet (prefix)
2396 "Return the bullet of the header prefix string PREFIX."
2397 ;; Doesn't make sense if we're old-style prefixes, but this just
2398 ;; oughtn't be called then, so forget about it...
2399 (if (string-match allout-regexp prefix
)
2400 (substring prefix
(1- (match-end 2)) (match-end 2))))
2401 ;;;_ > allout-sibling-index (&optional depth)
2402 (defun allout-sibling-index (&optional depth
)
2403 "Item number of this prospective topic among its siblings.
2405 If optional arg DEPTH is greater than current depth, then we're
2406 opening a new level, and return 0.
2408 If less than this depth, ascend to that depth and count..."
2411 (cond ((and depth
(<= depth
0) 0))
2412 ((or (null depth
) (= depth
(allout-depth)))
2414 (while (allout-previous-sibling allout-recent-depth nil
)
2415 (setq index
(1+ index
)))
2417 ((< depth allout-recent-depth
)
2418 (allout-ascend-to-depth depth
)
2419 (allout-sibling-index))
2421 ;;;_ > allout-topic-flat-index ()
2422 (defun allout-topic-flat-index ()
2423 "Return a list indicating point's numeric section.subsect.subsubsect...
2424 Outermost is first."
2425 (let* ((depth (allout-depth))
2426 (next-index (allout-sibling-index depth
))
2428 (while (> next-index
0)
2429 (setq rev-sibls
(cons next-index rev-sibls
))
2430 (setq depth
(1- depth
))
2431 (setq next-index
(allout-sibling-index depth
)))
2435 ;;;_ - Navigation routines
2436 ;;;_ > allout-beginning-of-current-line ()
2437 (defun allout-beginning-of-current-line ()
2438 "Like beginning of line, but to visible text."
2440 ;; This combination of move-beginning-of-line and beginning-of-line is
2441 ;; deliberate, but the (beginning-of-line) may now be superfluous.
2442 (let ((inhibit-field-text-motion t
))
2443 (move-beginning-of-line 1)
2445 (while (and (not (bobp)) (or (not (bolp)) (allout-hidden-p)))
2447 (if (or (allout-hidden-p) (not (bolp)))
2448 (forward-char -
1)))))
2449 ;;;_ > allout-end-of-current-line ()
2450 (defun allout-end-of-current-line ()
2451 "Move to the end of line, past concealed text if any."
2452 ;; XXX This is for symmetry with `allout-beginning-of-current-line' -
2453 ;; `move-end-of-line' doesn't suffer the same problem as
2454 ;; `move-beginning-of-line'.
2455 (let ((inhibit-field-text-motion t
))
2457 (while (allout-hidden-p)
2459 (if (allout-hidden-p) (forward-char 1)))))
2460 ;;;_ > allout-beginning-of-line ()
2461 (defun allout-beginning-of-line ()
2462 "Beginning-of-line with `allout-beginning-of-line-cycles' behavior, if set."
2466 (if (or (not allout-beginning-of-line-cycles
)
2467 (not (equal last-command this-command
)))
2468 (move-beginning-of-line 1)
2470 (let ((beginning-of-body
2472 (while (and (allout-do-doublecheck)
2473 (allout-aberrant-container-p)
2474 (allout-previous-visible-heading 1)))
2475 (allout-beginning-of-current-entry)
2477 (cond ((= (current-column) 0)
2478 (goto-char beginning-of-body
))
2479 ((< (point) beginning-of-body
)
2480 (allout-beginning-of-current-line))
2481 ((= (point) beginning-of-body
)
2482 (goto-char (allout-current-bullet-pos)))
2483 (t (allout-beginning-of-current-line)
2484 (if (< (point) beginning-of-body
)
2485 ;; we were on the headline after its start:
2486 (goto-char beginning-of-body
)))))))
2487 ;;;_ > allout-end-of-line ()
2488 (defun allout-end-of-line ()
2489 "End-of-line with `allout-end-of-line-cycles' behavior, if set."
2493 (if (or (not allout-end-of-line-cycles
)
2494 (not (equal last-command this-command
)))
2495 (allout-end-of-current-line)
2496 (let ((end-of-entry (save-excursion
2497 (allout-end-of-entry)
2500 (allout-end-of-current-line))
2501 ((or (allout-hidden-p) (save-excursion
2504 (allout-back-to-current-heading)
2505 (allout-show-current-entry)
2506 (allout-show-children)
2507 (allout-end-of-entry))
2508 ((>= (point) end-of-entry
)
2509 (allout-back-to-current-heading)
2510 (allout-end-of-current-line))
2511 (t (allout-end-of-entry))))))
2512 ;;;_ > allout-next-heading ()
2513 (defsubst allout-next-heading
()
2514 "Move to the heading for the topic (possibly invisible) after this one.
2516 Returns the location of the heading, or nil if none found.
2518 We skip anomolous low-level topics, a la `allout-aberrant-container-p'."
2519 (if (looking-at allout-regexp
)
2522 (when (re-search-forward allout-line-boundary-regexp nil
0)
2523 (allout-prefix-data)
2524 (and (allout-do-doublecheck)
2525 ;; this will set allout-recent-* on the first non-aberrant topic,
2526 ;; whether it's the current one or one that disqualifies it:
2527 (allout-aberrant-container-p))
2528 (goto-char allout-recent-prefix-beginning
)))
2529 ;;;_ > allout-this-or-next-heading
2530 (defun allout-this-or-next-heading ()
2531 "Position cursor on current or next heading."
2532 ;; A throwaway non-macro that is defined after allout-next-heading
2533 ;; and usable by allout-mode.
2534 (if (not (allout-goto-prefix-doublechecked)) (allout-next-heading)))
2535 ;;;_ > allout-previous-heading ()
2536 (defun allout-previous-heading ()
2537 "Move to the prior (possibly invisible) heading line.
2539 Return the location of the beginning of the heading, or nil if not found.
2541 We skip anomolous low-level topics, a la `allout-aberrant-container-p'."
2545 (let ((start-point (point)))
2546 ;; allout-goto-prefix-doublechecked calls us, so we can't use it here.
2547 (allout-goto-prefix)
2548 (when (or (re-search-backward allout-line-boundary-regexp nil
0)
2549 (looking-at allout-bob-regexp
))
2550 (goto-char (allout-prefix-data))
2551 (if (and (allout-do-doublecheck)
2552 (allout-aberrant-container-p))
2553 (or (allout-previous-heading)
2554 (and (goto-char start-point
)
2555 ;; recalibrate allout-recent-*:
2559 ;;;_ > allout-get-invisibility-overlay ()
2560 (defun allout-get-invisibility-overlay ()
2561 "Return the overlay at point that dictates allout invisibility."
2562 (let ((overlays (overlays-at (point)))
2564 (while (and overlays
(not got
))
2565 (if (equal (overlay-get (car overlays
) 'invisible
) 'allout
)
2566 (setq got
(car overlays
))
2569 ;;;_ > allout-back-to-visible-text ()
2570 (defun allout-back-to-visible-text ()
2571 "Move to most recent prior character that is visible, and return point."
2572 (if (allout-hidden-p)
2573 (goto-char (overlay-start (allout-get-invisibility-overlay))))
2576 ;;;_ - Subtree Charting
2577 ;;;_ " These routines either produce or assess charts, which are
2578 ;;; nested lists of the locations of topics within a subtree.
2580 ;;; Charts enable efficient subtree navigation by providing a reusable basis
2581 ;;; for elaborate, compound assessment and adjustment of a subtree.
2583 ;;;_ > allout-chart-subtree (&optional levels visible orig-depth prev-depth)
2584 (defun allout-chart-subtree (&optional levels visible orig-depth prev-depth
)
2585 "Produce a location \"chart\" of subtopics of the containing topic.
2587 Optional argument LEVELS specifies a depth limit (relative to start
2588 depth) for the chart. Null LEVELS means no limit.
2590 When optional argument VISIBLE is non-nil, the chart includes
2591 only the visible subelements of the charted subjects.
2593 The remaining optional args are for internal use by the function.
2595 Point is left at the end of the subtree.
2597 Charts are used to capture outline structure, so that outline-altering
2598 routines need assess the structure only once, and then use the chart
2599 for their elaborate manipulations.
2601 The chart entries for the topics are in reverse order, so the
2602 last topic is listed first. The entry for each topic consists of
2603 an integer indicating the point at the beginning of the topic
2604 prefix. Charts for offspring consists of a list containing,
2605 recursively, the charts for the respective subtopics. The chart
2606 for a topics' offspring precedes the entry for the topic itself.
2608 The other function parameters are for internal recursion, and should
2609 not be specified by external callers. ORIG-DEPTH is depth of topic at
2610 starting point, and PREV-DEPTH is depth of prior topic."
2612 (let ((original (not orig-depth
)) ; `orig-depth' set only in recursion.
2615 (if original
; Just starting?
2616 ; Register initial settings and
2617 ; position to first offspring:
2618 (progn (setq orig-depth
(allout-depth))
2619 (or prev-depth
(setq prev-depth
(1+ orig-depth
)))
2621 (allout-next-visible-heading 1)
2622 (allout-next-heading))))
2624 ;; Loop over the current levels' siblings. Besides being more
2625 ;; efficient than tail-recursing over a level, it avoids exceeding
2626 ;; the typically quite constrained Emacs max-lisp-eval-depth.
2628 ;; Probably would speed things up to implement loop-based stack
2629 ;; operation rather than recursing for lower levels. Bah.
2631 (while (and (not (eobp))
2632 ; Still within original topic?
2633 (< orig-depth
(setq curr-depth allout-recent-depth
))
2634 (cond ((= prev-depth curr-depth
)
2635 ;; Register this one and move on:
2636 (setq chart
(cons allout-recent-prefix-beginning chart
))
2637 (if (and levels
(<= levels
1))
2638 ;; At depth limit - skip sublevels:
2639 (or (allout-next-sibling curr-depth
)
2640 ;; or no more siblings - proceed to
2641 ;; next heading at lesser depth:
2642 (while (and (<= curr-depth
2643 allout-recent-depth
)
2645 (allout-next-visible-heading 1)
2646 (allout-next-heading)))))
2648 (allout-next-visible-heading 1)
2649 (allout-next-heading))))
2651 ((and (< prev-depth curr-depth
)
2654 ;; Recurse on deeper level of curr topic:
2656 (cons (allout-chart-subtree (and levels
2662 ;; ... then continue with this one.
2665 ;; ... else nil if we've ascended back to prev-depth.
2669 (if original
; We're at the last sibling on
2670 ; the original level. Position
2672 (progn (and (not (eobp)) (forward-char -
1))
2673 (and (= (preceding-char) ?
\n)
2674 (= (aref (buffer-substring (max 1 (- (point) 3))
2679 (setq allout-recent-end-of-subtree
(point))))
2681 chart
; (nreverse chart) not necessary,
2682 ; and maybe not preferable.
2684 ;;;_ > allout-chart-siblings (&optional start end)
2685 (defun allout-chart-siblings (&optional start end
)
2686 "Produce a list of locations of this and succeeding sibling topics.
2687 Effectively a top-level chart of siblings. See `allout-chart-subtree'
2688 for an explanation of charts."
2690 (when (allout-goto-prefix-doublechecked)
2691 (let ((chart (list (point))))
2692 (while (allout-next-sibling)
2693 (setq chart
(cons (point) chart
)))
2694 (if chart
(setq chart
(nreverse chart
)))))))
2695 ;;;_ > allout-chart-to-reveal (chart depth)
2696 (defun allout-chart-to-reveal (chart depth
)
2698 "Return a flat list of hidden points in subtree CHART, up to DEPTH.
2700 If DEPTH is nil, include hidden points at any depth.
2702 Note that point can be left at any of the points on chart, or at the
2706 (while (and (or (null depth
) (> depth
0))
2708 (setq here
(car chart
))
2710 (let ((further (allout-chart-to-reveal here
(if (null depth
)
2713 ;; We're on the start of a subtree - recurse with it, if there's
2714 ;; more depth to go:
2715 (if further
(setq result
(append further result
)))
2716 (setq chart
(cdr chart
)))
2718 (if (allout-hidden-p)
2719 (setq result
(cons here result
)))
2720 (setq chart
(cdr chart
))))
2722 ;;;_ X allout-chart-spec (chart spec &optional exposing)
2723 ;; (defun allout-chart-spec (chart spec &optional exposing)
2724 ;; "Not yet (if ever) implemented.
2726 ;; Produce exposure directives given topic/subtree CHART and an exposure SPEC.
2728 ;; Exposure spec indicates the locations to be exposed and the prescribed
2729 ;; exposure status. Optional arg EXPOSING is an integer, with 0
2730 ;; indicating pending concealment, anything higher indicating depth to
2731 ;; which subtopic headers should be exposed, and negative numbers
2732 ;; indicating (negative of) the depth to which subtopic headers and
2733 ;; bodies should be exposed.
2735 ;; The produced list can have two types of entries. Bare numbers
2736 ;; indicate points in the buffer where topic headers that should be
2739 ;; - bare negative numbers indicates that the topic starting at the
2740 ;; point which is the negative of the number should be opened,
2741 ;; including their entries.
2742 ;; - bare positive values indicate that this topic header should be
2744 ;; - Lists signify the beginning and end points of regions that should
2745 ;; be flagged, and the flag to employ. (For concealment: `(\?r)', and
2748 ;; (cond ((listp spec)
2751 ;; (setq spec (cdr spec)))
2755 ;;;_ > allout-goto-prefix ()
2756 (defun allout-goto-prefix ()
2757 "Put point at beginning of immediately containing outline topic.
2759 Goes to most immediate subsequent topic if none immediately containing.
2761 Not sensitive to topic visibility.
2763 Returns the point at the beginning of the prefix, or nil if none."
2766 (while (and (not done
)
2767 (search-backward "\n" nil
1))
2769 (if (looking-at allout-regexp
)
2770 (setq done
(allout-prefix-data))
2773 (cond ((looking-at allout-regexp
)
2774 (allout-prefix-data))
2775 ((allout-next-heading))
2778 ;;;_ > allout-goto-prefix-doublechecked ()
2779 (defun allout-goto-prefix-doublechecked ()
2780 "Put point at beginning of immediately containing outline topic.
2782 Like `allout-goto-prefix', but shallow topics (according to
2783 `allout-doublecheck-at-and-shallower') are checked and
2784 disqualified for child containment discontinuity, according to
2785 `allout-aberrant-container-p'."
2786 (if (allout-goto-prefix)
2787 (if (and (allout-do-doublecheck)
2788 (allout-aberrant-container-p))
2789 (allout-previous-heading)
2792 ;;;_ > allout-end-of-prefix ()
2793 (defun allout-end-of-prefix (&optional ignore-decorations
)
2794 "Position cursor at beginning of header text.
2796 If optional IGNORE-DECORATIONS is non-nil, put just after bullet,
2797 otherwise skip white space between bullet and ensuing text."
2799 (if (not (allout-goto-prefix-doublechecked))
2801 (goto-char allout-recent-prefix-end
)
2802 (if ignore-decorations
2804 (while (looking-at "[0-9]") (forward-char 1))
2805 (if (and (not (eolp)) (looking-at "\\s-")) (forward-char 1)))
2806 ;; Reestablish where we are:
2807 (allout-current-depth)))
2808 ;;;_ > allout-current-bullet-pos ()
2809 (defun allout-current-bullet-pos ()
2810 "Return position of current (visible) topic's bullet."
2812 (if (not (allout-current-depth))
2814 (1- allout-recent-prefix-end
)))
2815 ;;;_ > allout-back-to-current-heading ()
2816 (defun allout-back-to-current-heading ()
2817 "Move to heading line of current topic, or beginning if not in a topic.
2819 If interactive, we position at the end of the prefix.
2821 Return value of resulting point, unless we started outside
2822 of (before any) topics, in which case we return nil."
2824 (allout-beginning-of-current-line)
2825 (let ((bol-point (point)))
2826 (if (allout-goto-prefix-doublechecked)
2827 (if (<= (point) bol-point
)
2829 (allout-end-of-prefix)
2831 (goto-char (point-min))
2833 ;;;_ > allout-back-to-heading ()
2834 (defalias 'allout-back-to-heading
'allout-back-to-current-heading
)
2835 ;;;_ > allout-pre-next-prefix ()
2836 (defun allout-pre-next-prefix ()
2837 "Skip forward to just before the next heading line.
2839 Returns that character position."
2841 (if (allout-next-heading)
2842 (goto-char (1- allout-recent-prefix-beginning
))))
2843 ;;;_ > allout-end-of-subtree (&optional current include-trailing-blank)
2844 (defun allout-end-of-subtree (&optional current include-trailing-blank
)
2845 "Put point at the end of the last leaf in the containing topic.
2847 Optional CURRENT means put point at the end of the containing
2850 Optional INCLUDE-TRAILING-BLANK means include a trailing blank line, if
2851 any, as part of the subtree. Otherwise, that trailing blank will be
2852 excluded as delimiting whitespace between topics.
2854 Returns the value of point."
2857 (allout-back-to-current-heading)
2858 (allout-goto-prefix-doublechecked))
2859 (let ((level allout-recent-depth
))
2860 (allout-next-heading)
2861 (while (and (not (eobp))
2862 (> allout-recent-depth level
))
2863 (allout-next-heading))
2865 (allout-end-of-entry)
2867 (if (and (not include-trailing-blank
) (= ?
\n (preceding-char)))
2869 (setq allout-recent-end-of-subtree
(point))))
2870 ;;;_ > allout-end-of-current-subtree (&optional include-trailing-blank)
2871 (defun allout-end-of-current-subtree (&optional include-trailing-blank
)
2873 "Put point at end of last leaf in currently visible containing topic.
2875 Optional INCLUDE-TRAILING-BLANK means include a trailing blank line, if
2876 any, as part of the subtree. Otherwise, that trailing blank will be
2877 excluded as delimiting whitespace between topics.
2879 Returns the value of point."
2881 (allout-end-of-subtree t include-trailing-blank
))
2882 ;;;_ > allout-beginning-of-current-entry ()
2883 (defun allout-beginning-of-current-entry ()
2884 "When not already there, position point at beginning of current topic header.
2886 If already there, move cursor to bullet for hot-spot operation.
2887 \(See `allout-mode' doc string for details of hot-spot operation.)"
2889 (let ((start-point (point)))
2890 (move-beginning-of-line 1)
2891 (if (< 0 (allout-current-depth))
2892 (goto-char allout-recent-prefix-end
)
2893 (goto-char (point-min)))
2894 (allout-end-of-prefix)
2895 (if (and (interactive-p)
2896 (= (point) start-point
))
2897 (goto-char (allout-current-bullet-pos)))))
2898 ;;;_ > allout-end-of-entry (&optional inclusive)
2899 (defun allout-end-of-entry (&optional inclusive
)
2900 "Position the point at the end of the current topics' entry.
2902 Optional INCLUSIVE means also include trailing empty line, if any. When
2903 unset, whitespace between items separates them even when the items are
2906 (allout-pre-next-prefix)
2907 (if (and (not inclusive
) (not (bobp)) (= ?
\n (preceding-char)))
2910 ;;;_ > allout-end-of-current-heading ()
2911 (defun allout-end-of-current-heading ()
2913 (allout-beginning-of-current-entry)
2914 (search-forward "\n" nil t
)
2916 (defalias 'allout-end-of-heading
'allout-end-of-current-heading
)
2917 ;;;_ > allout-get-body-text ()
2918 (defun allout-get-body-text ()
2919 "Return the unmangled body text of the topic immediately containing point."
2921 (allout-end-of-prefix)
2922 (if (not (search-forward "\n" nil t
))
2925 (let ((pre-body (point)))
2928 (allout-end-of-entry t
)
2929 (if (not (= pre-body
(point)))
2930 (buffer-substring-no-properties (1+ pre-body
) (point))))
2937 ;;;_ > allout-ascend-to-depth (depth)
2938 (defun allout-ascend-to-depth (depth)
2939 "Ascend to depth DEPTH, returning depth if successful, nil if not."
2940 (if (and (> depth
0)(<= depth
(allout-depth)))
2941 (let (last-ascended)
2942 (while (and (< depth allout-recent-depth
)
2943 (setq last-ascended
(allout-ascend))))
2944 (goto-char allout-recent-prefix-beginning
)
2945 (if (interactive-p) (allout-end-of-prefix))
2946 (and last-ascended allout-recent-depth
))))
2947 ;;;_ > allout-ascend ()
2948 (defun allout-ascend (&optional dont-move-if-unsuccessful
)
2949 "Ascend one level, returning resulting depth if successful, nil if not.
2951 Point is left at the beginning of the level whether or not
2952 successful, unless optional DONT-MOVE-IF-UNSUCCESSFUL is set, in
2953 which case point is returned to its original starting location."
2954 (if dont-move-if-unsuccessful
2955 (setq dont-move-if-unsuccessful
(point)))
2957 (if (allout-beginning-of-level)
2958 (let ((bolevel (point))
2959 (bolevel-depth allout-recent-depth
))
2960 (allout-previous-heading)
2961 (cond ((< allout-recent-depth bolevel-depth
)
2962 allout-recent-depth
)
2963 ((= allout-recent-depth bolevel-depth
)
2964 (if dont-move-if-unsuccessful
2965 (goto-char dont-move-if-unsuccessful
))
2969 ;; some topic after very first is lower depth than first:
2973 (if (interactive-p) (allout-end-of-prefix))))
2974 ;;;_ > allout-descend-to-depth (depth)
2975 (defun allout-descend-to-depth (depth)
2976 "Descend to depth DEPTH within current topic.
2978 Returning depth if successful, nil if not."
2979 (let ((start-point (point))
2980 (start-depth (allout-depth)))
2982 (and (> (allout-depth) 0)
2983 (not (= depth allout-recent-depth
)) ; ... not there yet
2984 (allout-next-heading) ; ... go further
2985 (< start-depth allout-recent-depth
))) ; ... still in topic
2986 (if (and (> (allout-depth) 0)
2987 (= allout-recent-depth depth
))
2989 (goto-char start-point
)
2992 ;;;_ > allout-up-current-level (arg)
2993 (defun allout-up-current-level (arg)
2994 "Move out ARG levels from current visible topic."
2996 (let ((start-point (point)))
2997 (allout-back-to-current-heading)
2998 (if (not (allout-ascend))
2999 (progn (goto-char start-point
)
3000 (error "Can't ascend past outermost level"))
3001 (if (interactive-p) (allout-end-of-prefix))
3002 allout-recent-prefix-beginning
)))
3005 ;;;_ > allout-next-sibling (&optional depth backward)
3006 (defun allout-next-sibling (&optional depth backward
)
3007 "Like `allout-forward-current-level', but respects invisible topics.
3009 Traverse at optional DEPTH, or current depth if none specified.
3011 Go backward if optional arg BACKWARD is non-nil.
3013 Return the start point of the new topic if successful, nil otherwise."
3015 (if (if backward
(bobp) (eobp))
3017 (let ((target-depth (or depth
(allout-depth)))
3018 (start-point (point))
3019 (start-prefix-beginning allout-recent-prefix-beginning
)
3024 ;; done too few single steps to resort to the leap routine:
3027 (not (if backward
(bobp) (eobp)))
3028 ;; still traversable:
3029 (if backward
(allout-previous-heading) (allout-next-heading))
3030 ;; we're below the target depth
3031 (> (setq last-depth allout-recent-depth
) target-depth
))
3032 (setq count
(1+ count
))
3033 (if (> count
7) ; lists are commonly 7 +- 2, right?-)
3036 (or (allout-next-sibling-leap target-depth backward
)
3038 (goto-char start-point
)
3039 (if depth
(allout-depth) target-depth
)
3042 (and (> (or last-depth
(allout-depth)) 0)
3043 (= allout-recent-depth target-depth
))
3044 (not (= start-prefix-beginning
3045 allout-recent-prefix-beginning
)))
3046 allout-recent-prefix-beginning
)
3048 (goto-char start-point
)
3049 (if depth
(allout-depth) target-depth
)
3051 ;;;_ > allout-next-sibling-leap (&optional depth backward)
3052 (defun allout-next-sibling-leap (&optional depth backward
)
3053 "Like `allout-next-sibling', but by direct search for topic at depth.
3055 Traverse at optional DEPTH, or current depth if none specified.
3057 Go backward if optional arg BACKWARD is non-nil.
3059 Return the start point of the new topic if successful, nil otherwise.
3061 Costs more than regular `allout-next-sibling' for short traversals:
3063 - we have to check the prior (next, if travelling backwards)
3064 item to confirm connectivity with the prior topic, and
3065 - if confirmed, we have to reestablish the allout-recent-* settings with
3066 some extra navigation
3067 - if confirmation fails, we have to do more work to recover
3069 It is an increasingly big win when there are many intervening
3070 offspring before the next sibling, however, so
3071 `allout-next-sibling' resorts to this if it finds itself in that
3074 (if (if backward
(bobp) (eobp))
3076 (let* ((start-point (point))
3077 (target-depth (or depth
(allout-depth)))
3078 (search-whitespace-regexp nil
)
3079 (depth-biased (- target-depth
2))
3080 (expression (if (<= target-depth
1)
3081 allout-depth-one-regexp
3082 (format allout-depth-specific-regexp
3083 depth-biased depth-biased
)))
3087 (setq found
(if backward
3088 (re-search-backward expression nil
'to-limit
)
3090 (re-search-forward expression nil
'to-limit
)))
3091 (if (and found
(allout-aberrant-container-p))
3093 (setq done
(or found
(if backward
(bobp) (eobp)))))
3095 (progn (goto-char start-point
)
3097 ;; rationale: if any intervening items were at a lower depth, we
3098 ;; would now be on the first offspring at the target depth - ie,
3099 ;; the preceeding item (per the search direction) must be at a
3100 ;; lesser depth. that's all we need to check.
3101 (if backward
(allout-next-heading) (allout-previous-heading))
3102 (if (< allout-recent-depth target-depth
)
3103 ;; return to start and reestablish allout-recent-*:
3105 (goto-char start-point
)
3109 ;; locate cursor and set allout-recent-*:
3110 (allout-goto-prefix))))))
3111 ;;;_ > allout-previous-sibling (&optional depth backward)
3112 (defun allout-previous-sibling (&optional depth backward
)
3113 "Like `allout-forward-current-level' backwards, respecting invisible topics.
3115 Optional DEPTH specifies depth to traverse, default current depth.
3117 Optional BACKWARD reverses direction.
3119 Return depth if successful, nil otherwise."
3120 (allout-next-sibling depth
(not backward
))
3122 ;;;_ > allout-snug-back ()
3123 (defun allout-snug-back ()
3124 "Position cursor at end of previous topic.
3126 Presumes point is at the start of a topic prefix."
3127 (if (or (bobp) (eobp))
3130 (if (or (bobp) (not (= ?
\n (preceding-char))))
3134 ;;;_ > allout-beginning-of-level ()
3135 (defun allout-beginning-of-level ()
3136 "Go back to the first sibling at this level, visible or not."
3137 (allout-end-of-level 'backward
))
3138 ;;;_ > allout-end-of-level (&optional backward)
3139 (defun allout-end-of-level (&optional backward
)
3140 "Go to the last sibling at this level, visible or not."
3142 (let ((depth (allout-depth)))
3143 (while (allout-previous-sibling depth nil
))
3144 (prog1 allout-recent-depth
3145 (if (interactive-p) (allout-end-of-prefix)))))
3146 ;;;_ > allout-next-visible-heading (arg)
3147 (defun allout-next-visible-heading (arg)
3148 "Move to the next ARG'th visible heading line, backward if arg is negative.
3150 Move to buffer limit in indicated direction if headings are exhausted."
3153 (let* ((inhibit-field-text-motion t
)
3154 (backward (if (< arg
0) (setq arg
(* -
1 arg
))))
3155 (step (if backward -
1 1))
3160 ;; Boundary condition:
3161 (not (if backward
(bobp)(eobp)))
3162 ;; Move, skipping over all concealed lines in one fell swoop:
3163 (prog1 (condition-case nil
(or (line-move step
) t
)
3165 (allout-beginning-of-current-line))
3166 ;; Deal with apparent header line:
3167 (if (not (looking-at allout-regexp
))
3168 ;; not a header line, keep looking:
3170 (allout-prefix-data)
3171 (if (and (allout-do-doublecheck)
3172 (allout-aberrant-container-p))
3173 ;; skip this aberrant prospective header line:
3175 ;; this prospective headerline qualifies - register:
3176 (setq got allout-recent-prefix-beginning
)
3177 ;; and break the loop:
3179 ;; Register this got, it may be the last:
3180 (if got
(setq prev got
))
3181 (setq arg
(1- arg
)))
3182 (cond (got ; Last move was to a prefix:
3183 (allout-end-of-prefix))
3184 (prev ; Last move wasn't, but prev was:
3186 (allout-end-of-prefix))
3187 ((not backward
) (end-of-line) nil
))))
3188 ;;;_ > allout-previous-visible-heading (arg)
3189 (defun allout-previous-visible-heading (arg)
3190 "Move to the previous heading line.
3192 With argument, repeats or can move forward if negative.
3193 A heading line is one that starts with a `*' (or that `allout-regexp'
3196 (prog1 (allout-next-visible-heading (- arg
))
3197 (if (interactive-p) (allout-end-of-prefix))))
3198 ;;;_ > allout-forward-current-level (arg)
3199 (defun allout-forward-current-level (arg)
3200 "Position point at the next heading of the same level.
3202 Takes optional repeat-count, goes backward if count is negative.
3204 Returns resulting position, else nil if none found."
3206 (let ((start-depth (allout-current-depth))
3208 (backward (> 0 arg
)))
3209 (if (= 0 start-depth
)
3210 (error "No siblings, not in a topic..."))
3211 (if backward
(setq arg
(* -
1 arg
)))
3212 (allout-back-to-current-heading)
3213 (while (and (not (zerop arg
))
3215 (allout-previous-sibling)
3216 (allout-next-sibling)))
3217 (setq arg
(1- arg
)))
3218 (if (not (interactive-p))
3220 (allout-end-of-prefix)
3221 (if (not (zerop arg
))
3222 (error "Hit %s level %d topic, traversed %d of %d requested"
3223 (if backward
"first" "last")
3225 (- (abs start-arg
) arg
)
3226 (abs start-arg
))))))
3227 ;;;_ > allout-backward-current-level (arg)
3228 (defun allout-backward-current-level (arg)
3229 "Inverse of `allout-forward-current-level'."
3232 (let ((current-prefix-arg (* -
1 arg
)))
3233 (call-interactively 'allout-forward-current-level
))
3234 (allout-forward-current-level (* -
1 arg
))))
3239 ;;;_ = allout-post-goto-bullet
3240 (defvar allout-post-goto-bullet nil
3241 "Outline internal var, for `allout-pre-command-business' hot-spot operation.
3243 When set, tells post-processing to reposition on topic bullet, and
3244 then unset it. Set by `allout-pre-command-business' when implementing
3245 hot-spot operation, where literal characters typed over a topic bullet
3246 are mapped to the command of the corresponding control-key on the
3247 `allout-mode-map'.")
3248 (make-variable-buffer-local 'allout-post-goto-bullet
)
3249 ;;;_ = allout-command-counter
3250 (defvar allout-command-counter
0
3251 "Counter that monotonically increases in allout-mode buffers.
3253 Set by `allout-pre-command-business', to support allout addons in
3254 coordinating with allout activity.")
3255 (make-variable-buffer-local 'allout-command-counter
)
3256 ;;;_ > allout-post-command-business ()
3257 (defun allout-post-command-business ()
3258 "Outline `post-command-hook' function.
3260 - Implement (and clear) `allout-post-goto-bullet', for hot-spot
3263 - Decrypt topic currently being edited if it was encrypted for a save."
3265 ; Apply any external change func:
3266 (if (not (allout-mode-p)) ; In allout-mode.
3269 (if (and (boundp 'allout-after-save-decrypt
)
3270 allout-after-save-decrypt
)
3271 (allout-after-saves-handler))
3273 ;; Implement allout-post-goto-bullet, if set:
3274 (if (and allout-post-goto-bullet
3275 (allout-current-bullet-pos))
3276 (progn (goto-char (allout-current-bullet-pos))
3277 (setq allout-post-goto-bullet nil
)))
3279 ;;;_ > allout-pre-command-business ()
3280 (defun allout-pre-command-business ()
3281 "Outline `pre-command-hook' function for outline buffers.
3283 Among other things, implements special behavior when the cursor is on the
3284 topic bullet character.
3286 When the cursor is on the bullet character, self-insert characters are
3287 reinterpreted as the corresponding control-character in the
3288 `allout-mode-map'. The `allout-mode' `post-command-hook' insures that
3289 the cursor which has moved as a result of such reinterpretation is
3290 positioned on the bullet character of the destination topic.
3292 The upshot is that you can get easy, single (ie, unmodified) key
3293 outline maneuvering operations by positioning the cursor on the bullet
3294 char. When in this mode you can use regular cursor-positioning
3295 command/keystrokes to relocate the cursor off of a bullet character to
3296 return to regular interpretation of self-insert characters."
3298 (if (not (allout-mode-p))
3300 ;; Increment allout-command-counter
3301 (setq allout-command-counter
(1+ allout-command-counter
))
3302 ;; Do hot-spot navigation.
3303 (if (and (eq this-command
'self-insert-command
)
3304 (eq (point)(allout-current-bullet-pos)))
3305 (allout-hotspot-key-handler))))
3306 ;;;_ > allout-hotspot-key-handler ()
3307 (defun allout-hotspot-key-handler ()
3308 "Catchall handling of key bindings in hot-spots.
3310 Translates unmodified keystrokes to corresponding allout commands, when
3311 they would qualify if prefixed with the allout-command-prefix, and sets
3312 this-command accordingly.
3314 Returns the qualifying command, if any, else nil."
3316 (let* ((key-string (if (numberp last-command-char
)
3317 (char-to-string last-command-char
)))
3318 (key-num (cond ((numberp last-command-char
) last-command-char
)
3319 ;; for XEmacs character type:
3320 ((and (fboundp 'characterp
)
3321 (apply 'characterp
(list last-command-char
)))
3322 (apply 'char-to-int
(list last-command-char
)))
3330 ;; exclude control chars and escape:
3332 (setq mapped-binding
3333 (or (and (assoc key-string allout-keybindings-list
)
3334 ;; translate literal membership on list:
3335 (cadr (assoc key-string allout-keybindings-list
)))
3336 ;; translate as a keybinding:
3337 (key-binding (concat allout-command-prefix
3339 (if (and (<= 97 key-num
) ; "a"
3340 (>= 122 key-num
)) ; "z"
3341 (- key-num
96) key-num
)))
3343 ;; Qualified as an allout command - do hot-spot operation.
3344 (setq allout-post-goto-bullet t
)
3345 ;; accept-defaults nil, or else we'll get allout-item-icon-key-handler.
3346 (setq mapped-binding
(key-binding (char-to-string key-num
))))
3348 (while (keymapp mapped-binding
)
3349 (setq mapped-binding
3350 (lookup-key mapped-binding
(vector (read-char)))))
3353 (setq this-command mapped-binding
)))))
3355 ;;;_ > allout-find-file-hook ()
3356 (defun allout-find-file-hook ()
3357 "Activate `allout-mode' on non-nil `allout-auto-activation', `allout-layout'.
3359 See `allout-init' for setup instructions."
3360 (if (and allout-auto-activation
3361 (not (allout-mode-p))
3365 ;;;_ - Topic Format Assessment
3366 ;;;_ > allout-solicit-alternate-bullet (depth &optional current-bullet)
3367 (defun allout-solicit-alternate-bullet (depth &optional current-bullet
)
3369 "Prompt for and return a bullet char as an alternative to the current one.
3371 Offer one suitable for current depth DEPTH as default."
3373 (let* ((default-bullet (or (and (stringp current-bullet
) current-bullet
)
3374 (allout-bullet-for-depth depth
)))
3375 (sans-escapes (regexp-sans-escapes allout-bullets-string
))
3378 (goto-char (allout-current-bullet-pos))
3379 (setq choice
(solicit-char-in-string
3380 (format "Select bullet: %s ('%s' default): "
3382 (substring-no-properties default-bullet
))
3386 (if (string= choice
"") default-bullet choice
))
3388 ;;;_ > allout-distinctive-bullet (bullet)
3389 (defun allout-distinctive-bullet (bullet)
3390 "True if BULLET is one of those on `allout-distinctive-bullets-string'."
3391 (string-match (regexp-quote bullet
) allout-distinctive-bullets-string
))
3392 ;;;_ > allout-numbered-type-prefix (&optional prefix)
3393 (defun allout-numbered-type-prefix (&optional prefix
)
3394 "True if current header prefix bullet is numbered bullet."
3395 (and allout-numbered-bullet
3396 (string= allout-numbered-bullet
3398 (allout-get-prefix-bullet prefix
)
3399 (allout-get-bullet)))))
3400 ;;;_ > allout-encrypted-type-prefix (&optional prefix)
3401 (defun allout-encrypted-type-prefix (&optional prefix
)
3402 "True if current header prefix bullet is for an encrypted entry (body)."
3403 (and allout-topic-encryption-bullet
3404 (string= allout-topic-encryption-bullet
3406 (allout-get-prefix-bullet prefix
)
3407 (allout-get-bullet)))))
3408 ;;;_ > allout-bullet-for-depth (&optional depth)
3409 (defun allout-bullet-for-depth (&optional depth
)
3410 "Return outline topic bullet suited to optional DEPTH, or current depth."
3411 ;; Find bullet in plain-bullets-string modulo DEPTH.
3412 (if allout-stylish-prefixes
3413 (char-to-string (aref allout-plain-bullets-string
3414 (%
(max 0 (- depth
2))
3415 allout-plain-bullets-string-len
)))
3416 allout-primary-bullet
)
3419 ;;;_ - Topic Production
3420 ;;;_ > allout-make-topic-prefix (&optional prior-bullet
3421 (defun allout-make-topic-prefix (&optional prior-bullet
3427 ;; Depth null means use current depth, non-null means we're either
3428 ;; opening a new topic after current topic, lower or higher, or we're
3429 ;; changing level of current topic.
3430 ;; Solicit dominates specified bullet-char.
3432 "Generate a topic prefix suitable for optional arg DEPTH, or current depth.
3434 All the arguments are optional.
3436 PRIOR-BULLET indicates the bullet of the prefix being changed, or
3437 nil if none. This bullet may be preserved (other options
3438 notwithstanding) if it is on the `allout-distinctive-bullets-string',
3441 Second arg NEW indicates that a new topic is being opened after the
3442 topic at point, if non-nil. Default bullet for new topics, eg, may
3443 be set (contingent to other args) to numbered bullets if previous
3444 sibling is one. The implication otherwise is that the current topic
3445 is being adjusted - shifted or rebulleted - and we don't consider
3446 bullet or previous sibling.
3448 Third arg DEPTH forces the topic prefix to that depth, regardless of
3449 the current topics' depth.
3451 If SOLICIT is non-nil, then the choice of bullet is solicited from
3452 user. If it's a character, then that character is offered as the
3453 default, otherwise the one suited to the context (according to
3454 distinction or depth) is offered. (This overrides other options,
3455 including, eg, a distinctive PRIOR-BULLET.) If non-nil, then the
3456 context-specific bullet is used.
3458 Fifth arg, NUMBER-CONTROL, matters only if `allout-numbered-bullet'
3459 is non-nil *and* soliciting was not explicitly invoked. Then
3460 NUMBER-CONTROL non-nil forces prefix to either numbered or
3461 denumbered format, depending on the value of the sixth arg, INDEX.
3463 \(Note that NUMBER-CONTROL does *not* apply to level 1 topics. Sorry...)
3465 If NUMBER-CONTROL is non-nil and sixth arg INDEX is non-nil then
3466 the prefix of the topic is forced to be numbered. Non-nil
3467 NUMBER-CONTROL and nil INDEX forces non-numbered format on the
3468 bullet. Non-nil NUMBER-CONTROL and non-nil, non-number INDEX means
3469 that the index for the numbered prefix will be derived, by counting
3470 siblings back to start of level. If INDEX is a number, then that
3471 number is used as the index for the numbered prefix (allowing, eg,
3472 sequential renumbering to not require this function counting back the
3473 index for each successive sibling)."
3475 ;; The options are ordered in likely frequence of use, most common
3476 ;; highest, least lowest. Ie, more likely to be doing prefix
3477 ;; adjustments than soliciting, and yet more than numbering.
3478 ;; Current prefix is least dominant, but most likely to be commonly
3484 (depth (or depth
(allout-depth)))
3485 (header-lead allout-header-prefix
)
3488 ;; Getting value for bullet char is practically the whole job:
3491 ; Simplest situation - level 1:
3492 ((<= depth
1) (setq header-lead
"") allout-primary-bullet
)
3493 ; Simple, too: all asterisks:
3494 (allout-old-style-prefixes
3495 ;; Cheat - make body the whole thing, null out header-lead and
3497 (setq body
(make-string depth
3498 (string-to-char allout-primary-bullet
)))
3499 (setq header-lead
"")
3502 ;; (Neither level 1 nor old-style, so we're space padding.
3503 ;; Sneak it in the condition of the next case, whatever it is.)
3505 ;; Solicitation overrides numbering and other cases:
3506 ((progn (setq body
(make-string (- depth
2) ?\
))
3507 ;; The actual condition:
3509 (let* ((got (allout-solicit-alternate-bullet depth solicit
)))
3510 ;; Gotta check whether we're numbering and got a numbered bullet:
3511 (setq numbering
(and allout-numbered-bullet
3512 (not (and number-control
(not index
)))
3513 (string= got allout-numbered-bullet
)))
3514 ;; Now return what we got, regardless:
3517 ;; Numbering invoked through args:
3518 ((and allout-numbered-bullet number-control
)
3519 (if (setq numbering
(not (setq denumbering
(not index
))))
3520 allout-numbered-bullet
3521 (if (and prior-bullet
3522 (not (string= allout-numbered-bullet
3525 (allout-bullet-for-depth depth
))))
3527 ;;; Neither soliciting nor controlled numbering ;;;
3528 ;;; (may be controlled denumbering, tho) ;;;
3530 ;; Check wrt previous sibling:
3531 ((and new
; only check for new prefixes
3532 (<= depth
(allout-depth))
3533 allout-numbered-bullet
; ... & numbering enabled
3535 (let ((sibling-bullet
3537 ;; Locate correct sibling:
3538 (or (>= depth
(allout-depth))
3539 (allout-ascend-to-depth depth
))
3540 (allout-get-bullet))))
3541 (if (and sibling-bullet
3542 (string= allout-numbered-bullet sibling-bullet
))
3543 (setq numbering sibling-bullet
)))))
3545 ;; Distinctive prior bullet?
3547 (allout-distinctive-bullet prior-bullet
)
3548 ;; Either non-numbered:
3549 (or (not (and allout-numbered-bullet
3550 (string= prior-bullet allout-numbered-bullet
)))
3551 ;; or numbered, and not denumbering:
3552 (setq numbering
(not denumbering
)))
3556 ;; Else, standard bullet per depth:
3557 ((allout-bullet-for-depth depth
)))))
3563 (format "%d" (cond ((and index
(numberp index
)) index
)
3564 (new (1+ (allout-sibling-index depth
)))
3565 ((allout-sibling-index))))))
3568 ;;;_ > allout-open-topic (relative-depth &optional before offer-recent-bullet)
3569 (defun allout-open-topic (relative-depth &optional before offer-recent-bullet
)
3570 "Open a new topic at depth DEPTH.
3572 New topic is situated after current one, unless optional flag BEFORE
3573 is non-nil, or unless current line is completely empty - lacking even
3574 whitespace - in which case open is done on the current line.
3576 When adding an offspring, it will be added immediately after the parent if
3577 the other offspring are exposed, or after the last child if the offspring
3578 are hidden. (The intervening offspring will be exposed in the latter
3581 If OFFER-RECENT-BULLET is true, offer to use the bullet of the prior sibling.
3585 - Creation of new topics is with respect to the visible topic
3586 containing the cursor, regardless of intervening concealed ones.
3588 - New headers are generally created after/before the body of a
3589 topic. However, they are created right at cursor location if the
3590 cursor is on a blank line, even if that breaks the current topic
3591 body. This is intentional, to provide a simple means for
3592 deliberately dividing topic bodies.
3594 - Double spacing of topic lists is preserved. Also, the first
3595 level two topic is created double-spaced (and so would be
3596 subsequent siblings, if that's left intact). Otherwise,
3597 single-spacing is used.
3599 - Creation of sibling or nested topics is with respect to the topic
3600 you're starting from, even when creating backwards. This way you
3601 can easily create a sibling in front of the current topic without
3602 having to go to its preceding sibling, and then open forward
3605 (allout-beginning-of-current-line)
3606 (let* ((inhibit-field-text-motion t
)
3607 (depth (+ (allout-current-depth) relative-depth
))
3608 (opening-on-blank (if (looking-at "^\$")
3609 (not (setq before nil
))))
3610 ;; bunch o vars set while computing ref-topic
3614 (ref-topic (save-excursion
3615 (cond ((< relative-depth
0)
3616 (allout-ascend-to-depth depth
))
3617 ((>= relative-depth
1) nil
)
3618 (t (allout-back-to-current-heading)))
3619 (setq ref-depth allout-recent-depth
)
3621 (if (> allout-recent-prefix-end
1)
3622 (allout-recent-bullet)
3624 (setq opening-numbered
3626 (and allout-numbered-bullet
3627 (or (<= relative-depth
0)
3628 (allout-descend-to-depth depth
))
3629 (if (allout-numbered-type-prefix)
3630 allout-numbered-bullet
))))
3636 (if (not opening-on-blank
)
3637 ; Positioning and vertical
3638 ; padding - only if not
3641 (goto-char ref-topic
)
3642 (setq dbl-space
; Determine double space action:
3643 (or (and (<= relative-depth
0) ; not descending;
3645 ;; at b-o-b or preceded by a blank line?
3646 (or (> 0 (forward-line -
1))
3647 (looking-at "^\\s-*$")
3650 ;; succeeded by a blank line?
3651 (allout-end-of-current-subtree)
3652 (looking-at "\n\n")))
3653 (and (= ref-depth
1)
3657 ;; Don't already have following
3658 ;; vertical padding:
3659 (not (allout-pre-next-prefix)))))))
3661 ;; Position to prior heading, if inserting backwards, and not
3663 (if (and before
(>= relative-depth
0))
3664 (progn (allout-back-to-current-heading)
3665 (setq doing-beginning
(bobp))
3667 (allout-previous-heading)))
3668 (if (and before
(bobp))
3671 (if (<= relative-depth
0)
3672 ;; Not going inwards, don't snug up:
3678 (progn (end-of-line)
3679 (allout-pre-next-prefix)
3680 (while (and (= ?
\n (following-char))
3685 (if (not (looking-at "^$"))
3687 (allout-end-of-current-subtree)
3688 (if (looking-at "\n\n") (forward-char 1))))
3689 ;; Going inwards - double-space if first offspring is
3690 ;; double-spaced, otherwise snug up.
3691 (allout-end-of-entry)
3695 (allout-beginning-of-current-line)
3698 ;; Blank lines between current header body and next
3699 ;; header - get to last substantive (non-white-space)
3701 (progn (setq dbl-space t
)
3702 (re-search-backward "[^ \t\n]" nil t
)))
3703 (if (looking-at "\n\n")
3706 (allout-next-heading)
3707 (when (> allout-recent-depth ref-depth
)
3708 ;; This is an offspring.
3710 (looking-at "^\\s-*$")))
3711 (progn (forward-line 1)
3714 (allout-end-of-current-line))
3716 ;;(if doing-beginning (goto-char doing-beginning))
3718 ;; We insert a newline char rather than using open-line to
3719 ;; avoid rear-stickiness inheritence of read-only property.
3720 (progn (if (and (not (> depth ref-depth
))
3723 (if (and (not dbl-space
) (> depth ref-depth
))
3729 (if (and dbl-space
(not (> relative-depth
0)))
3731 (if (and (not (eobp))
3734 ;; bolp doesnt detect concealed
3735 ;; trailing newlines, compensate:
3738 (allout-hidden-p)))))
3741 (setq start
(point))
3742 (insert (concat (allout-make-topic-prefix opening-numbered t depth
)
3744 (setq end
(1+ (point)))
3746 (allout-rebullet-heading (and offer-recent-bullet ref-bullet
)
3748 (if (> relative-depth
0)
3749 (save-excursion (goto-char ref-topic
)
3750 (allout-show-children)))
3753 (run-hook-with-args 'allout-structure-added-hook start end
)
3756 ;;;_ > allout-open-subtopic (arg)
3757 (defun allout-open-subtopic (arg)
3758 "Open new topic header at deeper level than the current one.
3760 Negative universal arg means to open deeper, but place the new topic
3761 prior to the current one."
3763 (allout-open-topic 1 (> 0 arg
) (< 1 arg
)))
3764 ;;;_ > allout-open-sibtopic (arg)
3765 (defun allout-open-sibtopic (arg)
3766 "Open new topic header at same level as the current one.
3768 Positive universal arg means to use the bullet of the prior sibling.
3770 Negative universal arg means to place the new topic prior to the current
3773 (allout-open-topic 0 (> 0 arg
) (not (= 1 arg
))))
3774 ;;;_ > allout-open-supertopic (arg)
3775 (defun allout-open-supertopic (arg)
3776 "Open new topic header at shallower level than the current one.
3778 Negative universal arg means to open shallower, but place the new
3779 topic prior to the current one."
3782 (allout-open-topic -
1 (> 0 arg
) (< 1 arg
)))
3784 ;;;_ - Outline Alteration
3785 ;;;_ : Topic Modification
3786 ;;;_ = allout-former-auto-filler
3787 (defvar allout-former-auto-filler nil
3788 "Name of modal fill function being wrapped by `allout-auto-fill'.")
3789 ;;;_ > allout-auto-fill ()
3790 (defun allout-auto-fill ()
3791 "`allout-mode' autofill function.
3793 Maintains outline hanging topic indentation if
3794 `allout-use-hanging-indents' is set."
3796 (when (not allout-inhibit-auto-fill
)
3797 (let ((fill-prefix (if allout-use-hanging-indents
3798 ;; Check for topic header indentation:
3801 (if (looking-at allout-regexp
)
3802 ;; ... construct indentation to account for
3803 ;; length of topic prefix:
3804 (make-string (progn (allout-end-of-prefix)
3807 (use-auto-fill-function (or allout-outside-normal-auto-fill-function
3810 (if (or allout-former-auto-filler allout-use-hanging-indents
)
3811 (funcall use-auto-fill-function
)))))
3812 ;;;_ > allout-reindent-body (old-depth new-depth &optional number)
3813 (defun allout-reindent-body (old-depth new-depth
&optional number
)
3814 "Reindent body lines which were indented at OLD-DEPTH to NEW-DEPTH.
3816 Optional arg NUMBER indicates numbering is being added, and it must
3819 Note that refill of indented paragraphs is not done."
3822 (allout-end-of-prefix)
3823 (let* ((new-margin (current-column))
3824 excess old-indent-begin old-indent-end
3825 ;; We want the column where the header-prefix text started
3826 ;; *before* the prefix was changed, so we infer it relative
3827 ;; to the new margin and the shift in depth:
3828 (old-margin (+ old-depth
(- new-margin new-depth
))))
3830 ;; Process lines up to (but excluding) next topic header:
3834 (and (re-search-forward "\n\\(\\s-*\\)"
3837 ;; Register the indent data, before we reset the
3838 ;; match data with a subsequent `looking-at':
3839 (setq old-indent-begin
(match-beginning 1)
3840 old-indent-end
(match-end 1))
3841 (not (looking-at allout-regexp
)))
3842 (if (> 0 (setq excess
(- (- old-indent-end old-indent-begin
)
3844 ;; Text starts left of old margin - don't adjust:
3846 ;; Text was hanging at or right of old left margin -
3847 ;; reindent it, preserving its existing indentation
3848 ;; beyond the old margin:
3849 (delete-region old-indent-begin old-indent-end
)
3850 (indent-to (+ new-margin excess
(current-column))))))))))
3851 ;;;_ > allout-rebullet-current-heading (arg)
3852 (defun allout-rebullet-current-heading (arg)
3853 "Solicit new bullet for current visible heading."
3855 (let ((initial-col (current-column))
3856 (on-bullet (eq (point)(allout-current-bullet-pos)))
3858 (backwards (if (< arg
0)
3859 (setq arg
(* arg -
1)))))
3861 (save-excursion (allout-back-to-current-heading)
3862 (allout-end-of-prefix)
3863 (setq from allout-recent-prefix-beginning
3864 to allout-recent-prefix-end
)
3865 (allout-rebullet-heading t
;;; solicit
3867 nil
;;; number-control
3869 t
) ;;; do-successors
3870 (run-hook-with-args 'allout-exposure-change-hook
3875 (setq initial-col nil
) ; Override positioning back to init col
3877 (allout-next-visible-heading 1)
3878 (allout-goto-prefix-doublechecked)
3879 (allout-next-visible-heading -
1))))
3881 (cond (on-bullet (goto-char (allout-current-bullet-pos)))
3882 (initial-col (move-to-column initial-col
)))))
3883 ;;;_ > allout-rebullet-heading (&optional solicit ...)
3884 (defun allout-rebullet-heading (&optional solicit
3890 "Adjust bullet of current topic prefix.
3892 All args are optional.
3894 If SOLICIT is non-nil, then the choice of bullet is solicited from
3895 user. If it's a character, then that character is offered as the
3896 default, otherwise the one suited to the context (according to
3897 distinction or depth) is offered. If non-nil, then the
3898 context-specific bullet is just used.
3900 Second arg DEPTH forces the topic prefix to that depth, regardless
3901 of the topic's current depth.
3903 Third arg NUMBER-CONTROL can force the prefix to or away from
3904 numbered form. It has effect only if `allout-numbered-bullet' is
3905 non-nil and soliciting was not explicitly invoked (via first arg).
3906 Its effect, numbering or denumbering, then depends on the setting
3907 of the forth arg, INDEX.
3909 If NUMBER-CONTROL is non-nil and forth arg INDEX is nil, then the
3910 prefix of the topic is forced to be non-numbered. Null index and
3911 non-nil NUMBER-CONTROL forces denumbering. Non-nil INDEX (and
3912 non-nil NUMBER-CONTROL) forces a numbered-prefix form. If non-nil
3913 INDEX is a number, then that number is used for the numbered
3914 prefix. Non-nil and non-number means that the index for the
3915 numbered prefix will be derived by allout-make-topic-prefix.
3917 Fifth arg DO-SUCCESSORS t means re-resolve count on succeeding
3920 Cf vars `allout-stylish-prefixes', `allout-old-style-prefixes',
3921 and `allout-numbered-bullet', which all affect the behavior of
3924 (let* ((current-depth (allout-depth))
3925 (new-depth (or new-depth current-depth
))
3926 (mb allout-recent-prefix-beginning
)
3927 (me allout-recent-prefix-end
)
3928 (current-bullet (buffer-substring-no-properties (- me
1) me
))
3929 (has-annotation (get-text-property mb
'allout-was-hidden
))
3930 (new-prefix (allout-make-topic-prefix current-bullet
3937 ;; Is new one is identical to old?
3938 (if (and (= current-depth new-depth
)
3939 (string= current-bullet
3940 (substring new-prefix
(1- (length new-prefix
)))))
3944 ;; New prefix probably different from old:
3945 ; get rid of old one:
3946 (allout-unprotected (delete-region mb me
))
3948 ; Dispense with number if
3949 ; numbered-bullet prefix:
3950 (if (and allout-numbered-bullet
3951 (string= allout-numbered-bullet current-bullet
)
3952 (looking-at "[0-9]+"))
3954 (delete-region (match-beginning 0)(match-end 0))))
3956 ;; convey 'allout-was-hidden annotation, if original had it:
3958 (put-text-property 0 (length new-prefix
) 'allout-was-hidden t
3961 ; Put in new prefix:
3962 (allout-unprotected (insert new-prefix
))
3964 ;; Reindent the body if elected, margin changed, and not encrypted body:
3965 (if (and allout-reindent-bodies
3966 (not (= new-depth current-depth
))
3967 (not (allout-encrypted-topic-p)))
3968 (allout-reindent-body current-depth new-depth
))
3970 ;; Recursively rectify successive siblings of orig topic if
3971 ;; caller elected for it:
3974 (while (allout-next-sibling new-depth nil
)
3976 (cond ((numberp index
) (1+ index
))
3977 ((not number-control
) (allout-sibling-index))))
3978 (if (allout-numbered-type-prefix)
3979 (allout-rebullet-heading nil
;;; solicit
3980 new-depth
;;; new-depth
3981 number-control
;;; number-control
3983 nil
))))) ;;;(dont!)do-successors
3984 ) ; (if (and (= current-depth new-depth)...))
3985 ) ; let* ((current-depth (allout-depth))...)
3987 ;;;_ > allout-rebullet-topic (arg)
3988 (defun allout-rebullet-topic (arg &optional sans-offspring
)
3989 "Rebullet the visible topic containing point and all contained subtopics.
3991 Descends into invisible as well as visible topics, however.
3993 When optional sans-offspring is non-nil, subtopics are not
3994 shifted. (Shifting a topic outwards without shifting its
3995 offspring is disallowed, since this would create a \"containment
3996 discontinuity\", where the depth difference between a topic and
3997 its immediate offspring is greater than one.)
3999 With repeat count, shift topic depth by that amount."
4001 (let ((start-col (current-column)))
4004 (cond ((null arg
) (setq arg
0))
4005 ((listp arg
) (setq arg
(car arg
))))
4006 ;; Fill the user in, in case we're shifting a big topic:
4007 (if (not (zerop arg
)) (message "Shifting..."))
4008 (allout-back-to-current-heading)
4009 (if (<= (+ allout-recent-depth arg
) 0)
4010 (error "Attempt to shift topic below level 1"))
4011 (allout-rebullet-topic-grunt arg nil nil nil nil sans-offspring
)
4012 (if (not (zerop arg
)) (message "Shifting... done.")))
4013 (move-to-column (max 0 (+ start-col arg
)))))
4014 ;;;_ > allout-rebullet-topic-grunt (&optional relative-depth ...)
4015 (defun allout-rebullet-topic-grunt (&optional relative-depth
4021 "Like `allout-rebullet-topic', but on nearest containing topic
4024 See `allout-rebullet-heading' for rebulleting behavior.
4026 All arguments are optional.
4028 First arg RELATIVE-DEPTH means to shift the depth of the entire
4031 Several subsequent args are for internal recursive use by the function
4032 itself: STARTING-DEPTH, STARTING-POINT, and INDEX.
4034 Finally, if optional SANS-OFFSPRING is non-nil then the offspring
4035 are not shifted. (Shifting a topic outwards without shifting
4036 its offspring is disallowed, since this would create a
4037 \"containment discontinuity\", where the depth difference between
4038 a topic and its immediate offspring is greater than one..)"
4040 ;; XXX the recursion here is peculiar, and in general the routine may
4041 ;; need simplification with refactoring.
4043 (if (and sans-offspring
4045 (< relative-depth
0))
4046 (error (concat "Attempt to shift topic outwards without offspring,"
4047 " would cause containment discontinuity.")))
4049 (let* ((relative-depth (or relative-depth
0))
4050 (new-depth (allout-depth))
4051 (starting-depth (or starting-depth new-depth
))
4052 (on-starting-call (null starting-point
))
4054 ;; Leave index null on starting call, so rebullet-heading
4055 ;; calculates it at what might be new depth:
4056 (and (or (zerop relative-depth
)
4057 (not on-starting-call
))
4058 (allout-sibling-index))))
4059 (starting-index index
)
4060 (moving-outwards (< 0 relative-depth
))
4061 (starting-point (or starting-point
(point)))
4062 (local-point (point)))
4064 ;; Sanity check for excessive promotion done only on starting call:
4065 (and on-starting-call
4067 (> 0 (+ starting-depth relative-depth
))
4068 (error "Attempt to shift topic out beyond level 1"))
4070 (cond ((= starting-depth new-depth
)
4071 ;; We're at depth to work on this one.
4073 ;; When shifting out we work on the children before working on
4074 ;; the parent to avoid interim `allout-aberrant-container-p'
4075 ;; aberrancy, and vice-versa when shifting in:
4076 (if (>= relative-depth
0)
4077 (allout-rebullet-heading nil
4078 (+ starting-depth relative-depth
)
4081 nil
)) ;;; do-successors
4082 (when (not sans-offspring
)
4083 ;; ... and work on subsequent ones which are at greater depth:
4085 (allout-next-heading)
4086 (while (and (not (eobp))
4087 (< starting-depth
(allout-depth)))
4088 (setq index
(1+ index
))
4089 (allout-rebullet-topic-grunt relative-depth
4093 (when (< relative-depth
0)
4095 (goto-char local-point
)
4096 (allout-rebullet-heading nil
;;; solicit
4097 (+ starting-depth relative-depth
)
4100 nil
)))) ;;; do-successors
4102 ((< starting-depth new-depth
)
4103 ;; Rare case - subtopic more than one level deeper than parent.
4104 ;; Treat this one at an even deeper level:
4105 (allout-rebullet-topic-grunt relative-depth
4111 (if on-starting-call
4113 ;; Rectify numbering of former siblings of the adjusted topic,
4114 ;; if topic has changed depth
4115 (if (or do-successors
4116 (and (not (zerop relative-depth
))
4117 (or (= allout-recent-depth starting-depth
)
4118 (= allout-recent-depth
(+ starting-depth
4120 (allout-rebullet-heading nil nil nil nil t
))
4121 ;; Now rectify numbering of new siblings of the adjusted topic,
4122 ;; if depth has been changed:
4123 (progn (goto-char starting-point
)
4124 (if (not (zerop relative-depth
))
4125 (allout-rebullet-heading nil nil nil nil t
)))))
4128 ;;;_ > allout-renumber-to-depth (&optional depth)
4129 (defun allout-renumber-to-depth (&optional depth
)
4130 "Renumber siblings at current depth.
4132 Affects superior topics if optional arg DEPTH is less than current depth.
4134 Returns final depth."
4136 ;; Proceed by level, processing subsequent siblings on each,
4137 ;; ascending until we get shallower than the start depth:
4139 (let ((ascender (allout-depth))
4141 (while (and (not (eobp))
4143 (>= allout-recent-depth depth
)
4144 (>= ascender depth
))
4145 ; Skip over all topics at
4146 ; lesser depths, which can not
4147 ; have been disturbed:
4148 (while (and (not (setq was-eobp
(eobp)))
4149 (> allout-recent-depth ascender
))
4150 (allout-next-heading))
4151 ; Prime ascender for ascension:
4152 (setq ascender
(1- allout-recent-depth
))
4153 (if (>= allout-recent-depth depth
)
4154 (allout-rebullet-heading nil
;;; solicit
4156 nil
;;; number-control
4158 t
)) ;;; do-successors
4159 (if was-eobp
(goto-char (point-max)))))
4160 allout-recent-depth
)
4161 ;;;_ > allout-number-siblings (&optional denumber)
4162 (defun allout-number-siblings (&optional denumber
)
4163 "Assign numbered topic prefix to this topic and its siblings.
4165 With universal argument, denumber - assign default bullet to this
4166 topic and its siblings.
4168 With repeated universal argument (`^U^U'), solicit bullet for each
4169 rebulleting each topic at this level."
4174 (allout-back-to-current-heading)
4175 (allout-beginning-of-level)
4176 (let ((depth allout-recent-depth
)
4177 (index (if (not denumber
) 1))
4178 (use-bullet (equal '(16) denumber
))
4181 (allout-rebullet-heading use-bullet
;;; solicit
4183 t
;;; number-control
4185 nil
) ;;; do-successors
4186 (if index
(setq index
(1+ index
)))
4187 (setq more
(allout-next-sibling depth nil
))))))
4188 ;;;_ > allout-shift-in (arg)
4189 (defun allout-shift-in (arg)
4190 "Increase depth of current heading and any items collapsed within it.
4192 With a negative argument, the item is shifted out using
4193 `allout-shift-out', instead.
4195 With an argument greater than one, shift-in the item but not its
4196 offspring, making the item into a sibling of its former children,
4197 and a child of sibling that formerly preceeded it.
4199 You are not allowed to shift the first offspring of a topic
4200 inwards, because that would yield a \"containment
4201 discontinuity\", where the depth difference between a topic and
4202 its immediate offspring is greater than one. The first topic in
4203 the file can be adjusted to any positive depth, however."
4207 (allout-shift-out (* arg -
1))
4208 ;; refuse to create a containment discontinuity:
4210 (allout-back-to-current-heading)
4212 (let* ((current-depth allout-recent-depth
)
4213 (start-point (point))
4214 (predecessor-depth (progn
4216 (allout-goto-prefix-doublechecked)
4217 (if (< (point) start-point
)
4220 (if (and (> predecessor-depth
0)
4221 (> (1+ current-depth
)
4222 (1+ predecessor-depth
)))
4223 (error (concat "Disallowed shift deeper than"
4224 " containing topic's children."))
4225 (allout-back-to-current-heading)
4226 (if (< allout-recent-depth
(1+ current-depth
))
4227 (allout-show-children))))))
4228 (let ((where (point)))
4229 (allout-rebullet-topic 1 (and (> arg
1) 'sans-offspring
))
4230 (run-hook-with-args 'allout-structure-shifted-hook arg where
))))
4231 ;;;_ > allout-shift-out (arg)
4232 (defun allout-shift-out (arg)
4233 "Decrease depth of current heading and any topics collapsed within it.
4234 This will make the item a sibling of its former container.
4236 With a negative argument, the item is shifted in using
4237 `allout-shift-in', instead.
4239 With an argument greater than one, shift-out the item's offspring
4240 but not the item itself, making the former children siblings of
4243 With an argument greater than 1, the item's offspring are shifted
4244 out without shifting the item. This will make the immediate
4245 subtopics into siblings of the item."
4248 (allout-shift-in (* arg -
1))
4249 ;; Get proper exposure in this area:
4250 (save-excursion (if (allout-ascend)
4251 (allout-show-children)))
4252 ;; Show collapsed children if there's a successor which will become
4254 (if (and (allout-current-topic-collapsed-p)
4255 (save-excursion (allout-next-sibling)))
4256 (allout-show-children))
4257 (let ((where (and (allout-depth) allout-recent-prefix-beginning
)))
4260 ;; Shift the offspring but not the topic:
4261 (let ((children-chart (allout-chart-subtree 1)))
4262 (if (listp (car children-chart
))
4264 (setq children-chart
(allout-flatten children-chart
)))
4266 (dolist (child-point children-chart
)
4267 (goto-char child-point
)
4268 (allout-shift-out 1))))
4269 (allout-rebullet-topic (* arg -
1))))
4270 (run-hook-with-args 'allout-structure-shifted-hook
(* arg -
1) where
))))
4271 ;;;_ : Surgery (kill-ring) functions with special provisions for outlines:
4272 ;;;_ > allout-kill-line (&optional arg)
4273 (defun allout-kill-line (&optional arg
)
4274 "Kill line, adjusting subsequent lines suitably for outline mode."
4278 (if (or (not (allout-mode-p))
4280 (not (looking-at allout-regexp
)))
4281 ;; Just do a regular kill:
4283 ;; Ah, have to watch out for adjustments:
4284 (let* ((beg (point))
4286 (beg-hidden (allout-hidden-p))
4287 (end-hidden (save-excursion (allout-end-of-current-line)
4290 (depth (allout-depth)))
4292 (allout-annotate-hidden beg end
)
4293 (if (and (not beg-hidden
) (not end-hidden
))
4294 (allout-unprotected (kill-line arg
))
4296 (allout-deannotate-hidden beg end
)
4298 (if allout-numbered-bullet
4299 (save-excursion ; Renumber subsequent topics if needed:
4300 (if (not (looking-at allout-regexp
))
4301 (allout-next-heading))
4302 (allout-renumber-to-depth depth
)))
4303 (run-hook-with-args 'allout-structure-deleted-hook depth
(point)))))
4304 ;;;_ > allout-copy-line-as-kill ()
4305 (defun allout-copy-line-as-kill ()
4306 "Like allout-kill-topic, but save to kill ring instead of deleting."
4308 (let ((buffer-read-only t
))
4311 (buffer-read-only nil
))))
4312 ;;;_ > allout-kill-topic ()
4313 (defun allout-kill-topic ()
4314 "Kill topic together with subtopics.
4316 Trailing whitespace is killed with a topic if that whitespace:
4318 - would separate the topic from a subsequent sibling
4319 - would separate the topic from the end of buffer
4320 - would not be added to whitespace already separating the topic from the
4323 Topic exposure is marked with text-properties, to be used by
4324 allout-yank-processing for exposure recovery."
4327 (let* ((inhibit-field-text-motion t
)
4328 (beg (prog1 (allout-back-to-current-heading) (beginning-of-line)))
4330 (depth allout-recent-depth
))
4331 (allout-end-of-current-subtree)
4332 (if (and (/= (current-column) 0) (not (eobp)))
4335 (if (and (looking-at "\n")
4337 (or (not (allout-next-heading))
4338 (= depth allout-recent-depth
)))
4339 (and (> (- beg
(point-min)) 3)
4340 (string= (buffer-substring (- beg
2) beg
) "\n\n"))))
4343 (allout-annotate-hidden beg
(setq end
(point)))
4345 (allout-unprotected (kill-region beg end
))
4346 (if buffer-read-only
4347 ;; eg, during copy-as-kill.
4348 (allout-deannotate-hidden beg end
)))
4351 (allout-renumber-to-depth depth
))
4352 (run-hook-with-args 'allout-structure-deleted-hook depth
(point))))
4353 ;;;_ > allout-copy-topic-as-kill ()
4354 (defun allout-copy-topic-as-kill ()
4355 "Like allout-kill-topic, but save to kill ring instead of deleting."
4357 (let ((buffer-read-only t
))
4360 (buffer-read-only (message "Topic copied...")))))
4361 ;;;_ > allout-annotate-hidden (begin end)
4362 (defun allout-annotate-hidden (begin end
)
4363 "Qualify text with properties to indicate exposure status."
4365 (let ((was-modified (buffer-modified-p))
4366 (buffer-read-only nil
))
4367 (allout-deannotate-hidden begin end
)
4370 (let (done next prev overlay
)
4372 ;; at or advance to start of next hidden region:
4373 (if (not (allout-hidden-p))
4376 (next-single-char-property-change (point)
4379 (if (or (not next
) (eq prev next
))
4380 ;; still not at start of hidden area - must not be any left.
4384 (if (not (allout-hidden-p))
4385 ;; still not at start of hidden area.
4387 (setq overlay
(allout-get-invisibility-overlay))
4388 (setq next
(overlay-end overlay
)
4390 ;; advance to end of this hidden area:
4394 (let ((buffer-undo-list t
))
4395 (put-text-property (overlay-start overlay
) next
4396 'allout-was-hidden t
)))))))))
4397 (set-buffer-modified-p was-modified
)))
4398 ;;;_ > allout-deannotate-hidden (begin end)
4399 (defun allout-deannotate-hidden (begin end
)
4400 "Remove allout hidden-text annotation between BEGIN and END."
4403 (let ((inhibit-read-only t
)
4404 (buffer-undo-list t
))
4405 ;(remove-text-properties begin end '(allout-was-hidden t))
4407 ;;;_ > allout-hide-by-annotation (begin end)
4408 (defun allout-hide-by-annotation (begin end
)
4409 "Translate text properties indicating exposure status into actual exposure."
4412 (let ((was-modified (buffer-modified-p))
4415 ;; at or advance to start of next annotation:
4416 (if (not (get-text-property (point) 'allout-was-hidden
))
4417 (setq next
(next-single-char-property-change (point)
4420 (if (or (not next
) (eq prev next
))
4421 ;; no more or not advancing - must not be any left.
4425 (if (not (get-text-property (point) 'allout-was-hidden
))
4426 ;; still not at start of annotation.
4428 ;; advance to just after end of this annotation:
4429 (setq next
(next-single-char-property-change (point)
4432 (overlay-put (make-overlay prev next
)
4433 'category
'allout-exposure-category
)
4434 (allout-deannotate-hidden prev next
)
4436 (if next
(goto-char next
)))))
4437 (set-buffer-modified-p was-modified
))))
4438 ;;;_ > allout-yank-processing ()
4439 (defun allout-yank-processing (&optional arg
)
4441 "Incidental allout-specific business to be done just after text yanks.
4443 Does depth adjustment of yanked topics, when:
4445 1 the stuff being yanked starts with a valid outline header prefix, and
4446 2 it is being yanked at the end of a line which consists of only a valid
4449 Also, adjusts numbering of subsequent siblings when appropriate.
4451 Depth adjustment alters the depth of all the topics being yanked
4452 the amount it takes to make the first topic have the depth of the
4453 header into which it's being yanked.
4455 The point is left in front of yanked, adjusted topics, rather than
4456 at the end (and vice-versa with the mark). Non-adjusted yanks,
4457 however, are left exactly like normal, non-allout-specific yanks."
4460 ; Get to beginning, leaving
4461 ; region around subject:
4462 (if (< (allout-mark-marker t
) (point))
4463 (exchange-point-and-mark))
4464 (let* ((subj-beg (point))
4466 (subj-end (allout-mark-marker t
))
4467 ;; 'resituate' if yanking an entire topic into topic header:
4468 (resituate (and (let ((allout-inhibit-aberrance-doublecheck t
))
4469 (allout-e-o-prefix-p))
4470 (looking-at allout-regexp
)
4471 (allout-prefix-data)))
4472 ;; `rectify-numbering' if resituating (where several topics may
4473 ;; be resituating) or yanking a topic into a topic slot (bol):
4474 (rectify-numbering (or resituate
4475 (and into-bol
(looking-at allout-regexp
)))))
4477 ;; Yanking a topic into the start of a topic - reconcile to fit:
4478 (let* ((inhibit-field-text-motion t
)
4479 (prefix-len (if (not (match-end 1))
4481 (- (match-end 1) subj-beg
)))
4482 (subj-depth allout-recent-depth
)
4483 (prefix-bullet (allout-recent-bullet))
4485 ;; Nil if adjustment unnecessary, otherwise depth to which
4486 ;; adjustment should be made:
4488 (and (goto-char subj-end
)
4490 (goto-char subj-beg
)
4491 (and (looking-at allout-regexp
)
4494 (not (= (point) subj-beg
)))
4495 (looking-at allout-regexp
)
4496 (allout-prefix-data))
4497 allout-recent-depth
)))
4499 (setq rectify-numbering allout-numbered-bullet
)
4501 ; Do the adjustment:
4504 (narrow-to-region subj-beg subj-end
)
4505 ; Trim off excessive blank
4506 ; line at end, if any:
4507 (goto-char (point-max))
4508 (if (looking-at "^$")
4509 (allout-unprotected (delete-char -
1)))
4510 ; Work backwards, with each
4512 ; successively excluding the
4513 ; last processed topic from
4514 ; the narrow region:
4516 (allout-back-to-current-heading)
4517 ; go as high as we can in each bunch:
4518 (while (allout-ascend t
))
4521 (allout-rebullet-topic-grunt (- adjust-to-depth
4524 (if (setq more
(not (bobp)))
4527 (narrow-to-region subj-beg
(point))))))
4528 ;; Preserve new bullet if it's a distinctive one, otherwise
4530 (if (string-match (regexp-quote prefix-bullet
)
4531 allout-distinctive-bullets-string
)
4532 ; Delete from bullet of old to
4533 ; before bullet of new:
4537 (delete-region (point) subj-beg
))
4538 (set-marker (allout-mark-marker t
) subj-end
)
4539 (goto-char subj-beg
)
4540 (allout-end-of-prefix))
4541 ; Delete base subj prefix,
4545 (delete-region (point) (+ (point)
4549 ; and delete residual subj
4550 ; prefix digits and space:
4551 (while (looking-at "[0-9]") (delete-char 1))
4552 (if (looking-at " ") (delete-char 1))))))
4553 (exchange-point-and-mark))))
4554 (if rectify-numbering
4557 ; Give some preliminary feedback:
4558 (message "... reconciling numbers")
4559 ; ... and renumber, in case necessary:
4560 (goto-char subj-beg
)
4561 (if (allout-goto-prefix-doublechecked)
4563 (allout-rebullet-heading nil
;;; solicit
4564 (allout-depth) ;;; depth
4565 nil
;;; number-control
4569 (if (or into-bol resituate
)
4570 (allout-hide-by-annotation (point) (allout-mark-marker t
))
4571 (allout-deannotate-hidden (allout-mark-marker t
) (point)))
4573 (exchange-point-and-mark))
4574 (run-hook-with-args 'allout-structure-added-hook subj-beg subj-end
)))
4575 ;;;_ > allout-yank (&optional arg)
4576 (defun allout-yank (&optional arg
)
4577 "`allout-mode' yank, with depth and numbering adjustment of yanked topics.
4579 Non-topic yanks work no differently than normal yanks.
4581 If a topic is being yanked into a bare topic prefix, the depth of the
4582 yanked topic is adjusted to the depth of the topic prefix.
4584 1 we're yanking in an `allout-mode' buffer
4585 2 the stuff being yanked starts with a valid outline header prefix, and
4586 3 it is being yanked at the end of a line which consists of only a valid
4589 If these conditions hold then the depth of the yanked topics are all
4590 adjusted the amount it takes to make the first one at the depth of the
4591 header into which it's being yanked.
4593 The point is left in front of yanked, adjusted topics, rather than
4594 at the end (and vice-versa with the mark). Non-adjusted yanks,
4595 however, (ones that don't qualify for adjustment) are handled
4596 exactly like normal yanks.
4598 Numbering of yanked topics, and the successive siblings at the depth
4599 into which they're being yanked, is adjusted.
4601 `allout-yank-pop' works with `allout-yank' just like normal `yank-pop'
4602 works with normal `yank' in non-outline buffers."
4605 (setq this-command
'yank
)
4609 (allout-yank-processing)))
4610 ;;;_ > allout-yank-pop (&optional arg)
4611 (defun allout-yank-pop (&optional arg
)
4612 "Yank-pop like `allout-yank' when popping to bare outline prefixes.
4614 Adapts level of popped topics to level of fresh prefix.
4616 Note - prefix changes to distinctive bullets will stick, if followed
4617 by pops to non-distinctive yanks. Bug..."
4620 (setq this-command
'yank
)
4623 (allout-yank-processing)))
4625 ;;;_ - Specialty bullet functions
4626 ;;;_ : File Cross references
4627 ;;;_ > allout-resolve-xref ()
4628 (defun allout-resolve-xref ()
4629 "Pop to file associated with current heading, if it has an xref bullet.
4631 \(Works according to setting of `allout-file-xref-bullet')."
4633 (if (not allout-file-xref-bullet
)
4635 "Outline cross references disabled - no `allout-file-xref-bullet'")
4636 (if (not (string= (allout-current-bullet) allout-file-xref-bullet
))
4637 (error "Current heading lacks cross-reference bullet `%s'"
4638 allout-file-xref-bullet
)
4639 (let ((inhibit-field-text-motion t
)
4642 (let* ((text-start allout-recent-prefix-end
)
4643 (heading-end (progn (end-of-line) (point))))
4644 (goto-char text-start
)
4646 (if (re-search-forward "\\s-\\(\\S-*\\)" heading-end t
)
4647 (buffer-substring (match-beginning 1) (match-end 1))))))
4648 (setq file-name
(expand-file-name file-name
))
4649 (if (or (file-exists-p file-name
)
4650 (if (file-writable-p file-name
)
4651 (y-or-n-p (format "%s not there, create one? "
4653 (error "%s not found and can't be created" file-name
)))
4654 (condition-case failure
4655 (find-file-other-window file-name
)
4657 (error "%s not found" file-name
))
4663 ;;;_ #6 Exposure Control
4666 ;;;_ > allout-flag-region (from to flag)
4667 (defun allout-flag-region (from to flag
)
4668 "Conceal text between FROM and TO if FLAG is non-nil, else reveal it.
4670 Exposure-change hook `allout-exposure-change-hook' is run with the same
4671 arguments as this function, after the exposure changes are made. (The old
4672 `allout-view-change-hook' is being deprecated, and eventually will not be
4675 ;; We use outline invisibility spec.
4676 (remove-overlays from to
'category
'allout-exposure-category
)
4678 (let ((o (make-overlay from to
)))
4679 (overlay-put o
'category
'allout-exposure-category
)
4680 (when (featurep 'xemacs
)
4681 (let ((props (symbol-plist 'allout-exposure-category
)))
4683 (overlay-put o
(pop props
) (pop props
)))))))
4684 (run-hooks 'allout-view-change-hook
)
4685 (run-hook-with-args 'allout-exposure-change-hook from to flag
))
4686 ;;;_ > allout-flag-current-subtree (flag)
4687 (defun allout-flag-current-subtree (flag)
4688 "Conceal currently-visible topic's subtree if FLAG non-nil, else reveal it."
4691 (allout-back-to-current-heading)
4692 (let ((inhibit-field-text-motion t
))
4694 (allout-flag-region (point)
4695 ;; Exposing must not leave trailing blanks hidden,
4696 ;; but can leave them exposed when hiding, so we
4697 ;; can use flag's inverse as the
4698 ;; include-trailing-blank cue:
4699 (allout-end-of-current-subtree (not flag
))
4702 ;;;_ - Topic-specific
4703 ;;;_ > allout-show-entry ()
4704 (defun allout-show-entry ()
4705 "Like `allout-show-current-entry', but reveals entries in hidden topics.
4707 This is a way to give restricted peek at a concealed locality without the
4708 expense of exposing its context, but can leave the outline with aberrant
4709 exposure. `allout-show-offshoot' should be used after the peek to rectify
4715 (allout-goto-prefix-doublechecked)
4716 (setq beg
(if (allout-hidden-p) (1- (point)) (point)))
4717 (setq end
(allout-pre-next-prefix))
4718 (allout-flag-region beg end nil
)
4720 ;;;_ > allout-show-children (&optional level strict)
4721 (defun allout-show-children (&optional level strict
)
4723 "If point is visible, show all direct subheadings of this heading.
4725 Otherwise, do `allout-show-to-offshoot', and then show subheadings.
4727 Optional LEVEL specifies how many levels below the current level
4728 should be shown, or all levels if t. Default is 1.
4730 Optional STRICT means don't resort to -show-to-offshoot, no matter
4731 what. This is basically so -show-to-offshoot, which is called by
4732 this function, can employ the pure offspring-revealing capabilities of
4735 Returns point at end of subtree that was opened, if any. (May get a
4736 point of non-opened subtree?)"
4739 (let ((start-point (point)))
4740 (if (and (not strict
)
4743 (progn (allout-show-to-offshoot) ; Point's concealed, open to
4745 ;; Then recurse, but with "strict" set so we don't
4746 ;; infinite regress:
4747 (allout-show-children level t
))
4750 (allout-beginning-of-current-line)
4753 ;; translate the level spec for this routine to the ones
4754 ;; used by -chart-subtree and -chart-to-reveal:
4755 (chart-level (cond ((not level
) 1)
4758 (chart (allout-chart-subtree chart-level
))
4759 (to-reveal (or (allout-chart-to-reveal chart chart-level
)
4760 ;; interactive, show discontinuous children:
4764 (allout-back-to-current-heading)
4765 (setq depth
(allout-current-depth))
4766 (and (allout-next-heading)
4767 (> allout-recent-depth
4770 "Discontinuous offspring; use `%s %s'%s."
4771 (substitute-command-keys
4772 "\\[universal-argument]")
4773 (substitute-command-keys
4774 "\\[allout-shift-out]")
4775 " to elevate them.")
4776 (allout-chart-to-reveal
4777 chart
(- allout-recent-depth depth
))))))
4778 (goto-char start-point
)
4779 (when (and strict
(allout-hidden-p))
4780 ;; Concealed root would already have been taken care of,
4781 ;; unless strict was set.
4782 (allout-flag-region (point) (allout-snug-back) nil
)
4783 (when allout-show-bodies
4784 (goto-char (car to-reveal
))
4785 (allout-show-current-entry)))
4787 (goto-char (car to-reveal
))
4788 (allout-flag-region (save-excursion (allout-snug-back) (point))
4789 (progn (search-forward "\n" nil t
)
4792 (when allout-show-bodies
4793 (goto-char (car to-reveal
))
4794 (allout-show-current-entry))
4795 (setq to-reveal
(cdr to-reveal
)))))))
4796 ;; Compensate for `save-excursion's maintenance of point
4797 ;; within invisible text:
4798 (goto-char start-point
)))
4799 ;;;_ > allout-show-to-offshoot ()
4800 (defun allout-show-to-offshoot ()
4801 "Like `allout-show-entry', but reveals all concealed ancestors, as well.
4803 Useful for coherently exposing to a random point in a hidden region."
4806 (let ((inhibit-field-text-motion t
)
4808 (orig-pref (allout-goto-prefix-doublechecked))
4811 (while (or (> bag-it
1) (allout-hidden-p))
4812 (while (allout-hidden-p)
4813 (move-beginning-of-line 1)
4814 (if (allout-hidden-p) (forward-char -
1)))
4815 (if (= last-at
(setq last-at
(point)))
4816 ;; Oops, we're not making any progress! Show the current topic
4817 ;; completely, and try one more time here, if we haven't already.
4818 (progn (beginning-of-line)
4819 (allout-show-current-subtree)
4821 (setq bag-it
(1+ bag-it
))
4823 (error "allout-show-to-offshoot: %s"
4824 "Stumped by aberrant nesting.")))
4825 (if (> bag-it
0) (setq bag-it
0))
4826 (allout-show-children)
4827 (goto-char orig-pref
)))
4828 (goto-char orig-pt
)))
4829 (if (allout-hidden-p)
4830 (allout-show-entry)))
4831 ;;;_ > allout-hide-current-entry ()
4832 (defun allout-hide-current-entry ()
4833 "Hide the body directly following this heading."
4835 (allout-back-to-current-heading)
4837 (let ((inhibit-field-text-motion t
))
4839 (allout-flag-region (point)
4840 (progn (allout-end-of-entry) (point))
4842 ;;;_ > allout-show-current-entry (&optional arg)
4843 (defun allout-show-current-entry (&optional arg
)
4844 "Show body following current heading, or hide entry with universal argument."
4848 (allout-hide-current-entry)
4849 (save-excursion (allout-show-to-offshoot))
4851 (allout-flag-region (point)
4852 (progn (allout-end-of-entry t
) (point))
4855 ;;;_ > allout-show-current-subtree (&optional arg)
4856 (defun allout-show-current-subtree (&optional arg
)
4857 "Show everything within the current topic. With a repeat-count,
4858 expose this topic and its siblings."
4861 (if (<= (allout-current-depth) 0)
4862 ;; Outside any topics - try to get to the first:
4863 (if (not (allout-next-heading))
4865 ;; got to first, outermost topic - set to expose it and siblings:
4866 (message "Above outermost topic - exposing all.")
4867 (allout-flag-region (point-min)(point-max) nil
))
4868 (allout-beginning-of-current-line)
4870 (allout-flag-current-subtree nil
)
4871 (allout-beginning-of-level)
4872 (allout-expose-topic '(* :))))))
4873 ;;;_ > allout-current-topic-collapsed-p (&optional include-single-liners)
4874 (defun allout-current-topic-collapsed-p (&optional include-single-liners
)
4875 "True if the currently visible containing topic is already collapsed.
4877 Single line topics intrinsically can be considered as being both
4878 collapsed and uncollapsed. If optional INCLUDE-SINGLE-LINERS is
4879 true, then single-line topics are considered to be collapsed. By
4880 default, they are treated as being uncollapsed."
4883 ;; Is the topic all on one line (allowing for trailing blank line)?
4884 (>= (progn (allout-back-to-current-heading)
4885 (move-end-of-line 1)
4887 (allout-end-of-current-subtree (not (looking-at "\n\n"))))
4889 (or include-single-liners
4890 (progn (backward-char 1) (allout-hidden-p))))))
4891 ;;;_ > allout-hide-current-subtree (&optional just-close)
4892 (defun allout-hide-current-subtree (&optional just-close
)
4893 "Close the current topic, or containing topic if this one is already closed.
4895 If this topic is closed and it's a top level topic, close this topic
4898 If optional arg JUST-CLOSE is non-nil, do not close the parent or
4899 siblings, even if the target topic is already closed."
4902 (let* ((from (point))
4903 (sibs-msg "Top-level topic already closed - closing siblings...")
4904 (current-exposed (not (allout-current-topic-collapsed-p t
))))
4905 (cond (current-exposed (allout-flag-current-subtree t
))
4907 ((allout-ascend) (allout-hide-current-subtree))
4910 (allout-goto-prefix-doublechecked)
4911 (allout-expose-topic '(0 :))
4912 (message (concat sibs-msg
" Done."))))
4914 ;;;_ > allout-show-current-branches ()
4915 (defun allout-show-current-branches ()
4916 "Show all subheadings of this heading, but not their bodies."
4918 (let ((inhibit-field-text-motion t
))
4919 (beginning-of-line))
4920 (allout-show-children t
))
4921 ;;;_ > allout-hide-current-leaves ()
4922 (defun allout-hide-current-leaves ()
4923 "Hide the bodies of the current topic and all its offspring."
4925 (allout-back-to-current-heading)
4926 (allout-hide-region-body (point) (progn (allout-end-of-current-subtree)
4929 ;;;_ - Region and beyond
4930 ;;;_ > allout-show-all ()
4931 (defun allout-show-all ()
4932 "Show all of the text in the buffer."
4934 (message "Exposing entire buffer...")
4935 (allout-flag-region (point-min) (point-max) nil
)
4936 (message "Exposing entire buffer... Done."))
4937 ;;;_ > allout-hide-bodies ()
4938 (defun allout-hide-bodies ()
4939 "Hide all of buffer except headings."
4941 (allout-hide-region-body (point-min) (point-max)))
4942 ;;;_ > allout-hide-region-body (start end)
4943 (defun allout-hide-region-body (start end
)
4944 "Hide all body lines in the region, but not headings."
4947 (narrow-to-region start end
)
4948 (goto-char (point-min))
4949 (let ((inhibit-field-text-motion t
))
4952 (allout-flag-region (point) (allout-end-of-entry) t
)
4955 (if (looking-at "\n\n")
4958 ;;;_ > allout-expose-topic (spec)
4959 (defun allout-expose-topic (spec)
4960 "Apply exposure specs to successive outline topic items.
4962 Use the more convenient frontend, `allout-new-exposure', if you don't
4963 need evaluation of the arguments, or even better, the `allout-layout'
4964 variable-keyed mode-activation/auto-exposure feature of allout outline
4965 mode. See the respective documentation strings for more details.
4967 Cursor is left at start position.
4969 SPEC is either a number or a list.
4971 Successive specs on a list are applied to successive sibling topics.
4973 A simple spec (either a number, one of a few symbols, or the null
4974 list) dictates the exposure for the corresponding topic.
4976 Non-null lists recursively designate exposure specs for respective
4977 subtopics of the current topic.
4979 The `:' repeat spec is used to specify exposure for any number of
4980 successive siblings, up to the trailing ones for which there are
4981 explicit specs following the `:'.
4983 Simple (numeric and null-list) specs are interpreted as follows:
4985 Numbers indicate the relative depth to open the corresponding topic.
4986 - negative numbers force the topic to be closed before opening to the
4987 absolute value of the number, so all siblings are open only to
4989 - positive numbers open to the relative depth indicated by the
4990 number, but do not force already opened subtopics to be closed.
4991 - 0 means to close topic - hide all offspring.
4993 apply prior element to all siblings at current level, *up to*
4994 those siblings that would be covered by specs following the `:'
4995 on the list. Ie, apply to all topics at level but the last
4996 ones. (Only first of multiple colons at same level is
4997 respected - subsequent ones are discarded.)
4998 * - completely opens the topic, including bodies.
4999 + - shows all the sub headers, but not the bodies
5000 - - exposes the body of the corresponding topic.
5003 \(allout-expose-topic '(-1 : 0))
5004 Close this and all following topics at current level, exposing
5005 only their immediate children, but close down the last topic
5006 at this current level completely.
5007 \(allout-expose-topic '(-1 () : 1 0))
5008 Close current topic so only the immediate subtopics are shown;
5009 show the children in the second to last topic, and completely
5011 \(allout-expose-topic '(-2 : -1 *))
5012 Expose children and grandchildren of all topics at current
5013 level except the last two; expose children of the second to
5014 last and completely open the last one."
5016 (interactive "xExposure spec: ")
5017 (if (not (listp spec
))
5019 (let ((depth (allout-depth))
5024 (setq prev-elem curr-elem
5025 curr-elem
(car spec
)
5027 (cond ; Do current element:
5028 ((null curr-elem
) nil
)
5029 ((symbolp curr-elem
)
5030 (cond ((eq curr-elem
'*) (allout-show-current-subtree)
5031 (if (> allout-recent-end-of-subtree max-pos
)
5032 (setq max-pos allout-recent-end-of-subtree
)))
5034 (if (not (allout-hidden-p))
5035 (save-excursion (allout-hide-current-subtree t
)))
5036 (allout-show-current-branches)
5037 (if (> allout-recent-end-of-subtree max-pos
)
5038 (setq max-pos allout-recent-end-of-subtree
)))
5039 ((eq curr-elem
'-
) (allout-show-current-entry))
5042 ;; Expand the `repeat' spec to an explicit version,
5043 ;; w.r.t. remaining siblings:
5044 (let ((residue ; = # of sibs not covered by remaining spec
5045 ;; Dang - could be nice to make use of the chart, sigh:
5046 (- (length (allout-chart-siblings))
5049 ;; Some residue - cover it with prev-elem:
5050 (setq spec
(append (make-list residue prev-elem
)
5052 ((numberp curr-elem
)
5053 (if (and (>= 0 curr-elem
) (not (allout-hidden-p)))
5054 (save-excursion (allout-hide-current-subtree t
)
5057 (if (> allout-recent-end-of-subtree max-pos
)
5059 allout-recent-end-of-subtree
)))))
5060 (if (> (abs curr-elem
) 0)
5061 (progn (allout-show-children (abs curr-elem
))
5062 (if (> allout-recent-end-of-subtree max-pos
)
5063 (setq max-pos allout-recent-end-of-subtree
)))))
5065 (if (allout-descend-to-depth (1+ depth
))
5066 (let ((got (allout-expose-topic curr-elem
)))
5067 (if (and got
(> got max-pos
)) (setq max-pos got
))))))
5068 (cond (stay (setq stay nil
))
5069 ((listp (car spec
)) nil
)
5070 ((> max-pos
(point))
5071 ;; Capitalize on max-pos state to get us nearer next sibling:
5072 (progn (goto-char (min (point-max) max-pos
))
5073 (allout-next-heading)))
5074 ((allout-next-sibling depth
))))
5076 ;;;_ > allout-old-expose-topic (spec &rest followers)
5077 (defun allout-old-expose-topic (spec &rest followers
)
5079 "Deprecated. Use `allout-expose-topic' (with different schema
5082 Dictate wholesale exposure scheme for current topic, according to SPEC.
5084 SPEC is either a number or a list. Optional successive args
5085 dictate exposure for subsequent siblings of current topic.
5087 A simple spec (either a number, a special symbol, or the null list)
5088 dictates the overall exposure for a topic. Non null lists are
5089 composite specs whose first element dictates the overall exposure for
5090 a topic, with the subsequent elements in the list interpreted as specs
5091 that dictate the exposure for the successive offspring of the topic.
5093 Simple (numeric and null-list) specs are interpreted as follows:
5095 - Numbers indicate the relative depth to open the corresponding topic:
5096 - negative numbers force the topic to be close before opening to the
5097 absolute value of the number.
5098 - positive numbers just open to the relative depth indicated by the number.
5100 - `*' completely opens the topic, including bodies.
5101 - `+' shows all the sub headers, but not the bodies
5102 - `-' exposes the body and immediate offspring of the corresponding topic.
5104 If the spec is a list, the first element must be a number, which
5105 dictates the exposure depth of the topic as a whole. Subsequent
5106 elements of the list are nested SPECs, dictating the specific exposure
5107 for the corresponding offspring of the topic.
5109 Optional FOLLOWERS arguments dictate exposure for succeeding siblings."
5111 (interactive "xExposure spec: ")
5112 (let ((inhibit-field-text-motion t
)
5113 (depth (allout-current-depth))
5115 (cond ((null spec
) nil
)
5117 (if (eq spec
'*) (allout-show-current-subtree))
5118 (if (eq spec
'+) (allout-show-current-branches))
5119 (if (eq spec
'-
) (allout-show-current-entry)))
5122 (save-excursion (allout-hide-current-subtree t
)
5124 (if (or (not max-pos
)
5125 (> (point) max-pos
))
5126 (setq max-pos
(point)))
5128 (setq spec
(* -
1 spec
)))))
5130 (allout-show-children spec
)))
5132 ;(let ((got (allout-old-expose-topic (car spec))))
5133 ; (if (and got (or (not max-pos) (> got max-pos)))
5134 ; (setq max-pos got)))
5135 (let ((new-depth (+ (allout-current-depth) 1))
5137 (setq max-pos
(allout-old-expose-topic (car spec
)))
5138 (setq spec
(cdr spec
))
5140 (allout-descend-to-depth new-depth
)
5141 (not (allout-hidden-p)))
5142 (progn (setq got
(apply 'allout-old-expose-topic spec
))
5143 (if (and got
(or (not max-pos
) (> got max-pos
)))
5144 (setq max-pos got
)))))))
5145 (while (and followers
5146 (progn (if (and max-pos
(< (point) max-pos
))
5147 (progn (goto-char max-pos
)
5148 (setq max-pos nil
)))
5150 (allout-next-sibling depth
)))
5151 (allout-old-expose-topic (car followers
))
5152 (setq followers
(cdr followers
)))
5154 ;;;_ > allout-new-exposure '()
5155 (defmacro allout-new-exposure
(&rest spec
)
5156 "Literal frontend for `allout-expose-topic', doesn't evaluate arguments.
5157 Some arguments that would need to be quoted in `allout-expose-topic'
5158 need not be quoted in `allout-new-exposure'.
5160 Cursor is left at start position.
5162 Use this instead of obsolete `allout-exposure'.
5165 \(allout-new-exposure (-1 () () () 1) 0)
5166 Close current topic at current level so only the immediate
5167 subtopics are shown, except also show the children of the
5168 third subtopic; and close the next topic at the current level.
5169 \(allout-new-exposure : -1 0)
5170 Close all topics at current level to expose only their
5171 immediate children, except for the last topic at the current
5172 level, in which even its immediate children are hidden.
5173 \(allout-new-exposure -2 : -1 *)
5174 Expose children and grandchildren of first topic at current
5175 level, and expose children of subsequent topics at current
5176 level *except* for the last, which should be opened completely."
5177 (list 'save-excursion
5178 '(if (not (or (allout-goto-prefix-doublechecked)
5179 (allout-next-heading)))
5180 (error "allout-new-exposure: Can't find any outline topics"))
5181 (list 'allout-expose-topic
(list 'quote spec
))))
5183 ;;;_ #7 Systematic outline presentation - copying, printing, flattening
5185 ;;;_ - Mapping and processing of topics
5186 ;;;_ ( See also Subtree Charting, in Navigation code.)
5187 ;;;_ > allout-stringify-flat-index (flat-index)
5188 (defun allout-stringify-flat-index (flat-index &optional context
)
5189 "Convert list representing section/subsection/... to document string.
5191 Optional arg CONTEXT indicates interior levels to include."
5195 (context-depth (or (and context
2) 1)))
5196 ;; Take care of the explicit context:
5197 (while (> context-depth
0)
5198 (setq numstr
(int-to-string (car flat-index
))
5199 flat-index
(cdr flat-index
)
5200 result
(if flat-index
5201 (cons delim
(cons numstr result
))
5202 (cons numstr result
))
5203 context-depth
(if flat-index
(1- context-depth
) 0)))
5205 ;; Take care of the indentation:
5212 (1+ (truncate (if (zerop (car flat-index
))
5214 (log10 (car flat-index
)))))
5217 (setq flat-index
(cdr flat-index
)))
5218 ;; Dispose of single extra delim:
5219 (setq result
(cdr result
))))
5220 (apply 'concat result
)))
5221 ;;;_ > allout-stringify-flat-index-plain (flat-index)
5222 (defun allout-stringify-flat-index-plain (flat-index)
5223 "Convert list representing section/subsection/... to document string."
5227 (setq result
(cons (int-to-string (car flat-index
))
5229 (cons delim result
))))
5230 (setq flat-index
(cdr flat-index
)))
5231 (apply 'concat result
)))
5232 ;;;_ > allout-stringify-flat-index-indented (flat-index)
5233 (defun allout-stringify-flat-index-indented (flat-index)
5234 "Convert list representing section/subsection/... to document string."
5238 ;; Take care of the explicit context:
5239 (setq numstr
(int-to-string (car flat-index
))
5240 flat-index
(cdr flat-index
)
5241 result
(if flat-index
5242 (cons delim
(cons numstr result
))
5243 (cons numstr result
)))
5245 ;; Take care of the indentation:
5252 (1+ (truncate (if (zerop (car flat-index
))
5254 (log10 (car flat-index
)))))
5257 (setq flat-index
(cdr flat-index
)))
5258 ;; Dispose of single extra delim:
5259 (setq result
(cdr result
))))
5260 (apply 'concat result
)))
5261 ;;;_ > allout-listify-exposed (&optional start end format)
5262 (defun allout-listify-exposed (&optional start end format
)
5264 "Produce a list representing exposed topics in current region.
5266 This list can then be used by `allout-process-exposed' to manipulate
5269 Optional START and END indicate bounds of region.
5271 optional arg, FORMAT, designates an alternate presentation form for
5274 list - Present prefix as numeric section.subsection..., starting with
5275 section indicated by the list, innermost nesting first.
5276 `indent' (symbol) - Convert header prefixes to all white space,
5277 except for distinctive bullets.
5279 The elements of the list produced are lists that represents a topic
5280 header and body. The elements of that list are:
5282 - a number representing the depth of the topic,
5283 - a string representing the header-prefix, including trailing whitespace and
5285 - a string representing the bullet character,
5286 - and a series of strings, each containing one line of the exposed
5287 portion of the topic entry."
5292 ((inhibit-field-text-motion t
)
5294 strings prefix result depth new-depth out gone-out bullet beg
5299 ;; Goto initial topic, and register preceeding stuff, if any:
5300 (if (> (allout-goto-prefix-doublechecked) start
)
5301 ;; First topic follows beginning point - register preliminary stuff:
5302 (setq result
(list (list 0 "" nil
5303 (buffer-substring start
(1- (point)))))))
5304 (while (and (not done
)
5305 (not (eobp)) ; Loop until we've covered the region.
5306 (not (> (point) end
)))
5307 (setq depth allout-recent-depth
; Current topics depth,
5308 bullet
(allout-recent-bullet) ; ... bullet,
5309 prefix
(allout-recent-prefix)
5310 beg
(progn (allout-end-of-prefix t
) (point))) ; and beginning.
5311 (setq done
; The boundary for the current topic:
5312 (not (allout-next-visible-heading 1)))
5313 (setq new-depth allout-recent-depth
)
5315 out
(< new-depth depth
))
5320 (while (> next
(point)) ; Get all the exposed text in
5322 (cons (buffer-substring
5324 ;To hidden text or end of line:
5327 (allout-back-to-visible-text)))
5329 (when (< (point) next
) ; Resume from after hid text, if any.
5331 (beginning-of-line))
5333 ;; Accumulate list for this topic:
5334 (setq strings
(nreverse strings
))
5338 (let ((special (if (string-match
5339 (regexp-quote bullet
)
5340 allout-distinctive-bullets-string
)
5342 (cond ((listp format
)
5344 (if allout-abbreviate-flattened-numbering
5345 (allout-stringify-flat-index format
5347 (allout-stringify-flat-index-plain
5351 ((eq format
'indent
)
5354 (concat (make-string (1+ depth
) ?
)
5355 (substring prefix -
1))
5358 (make-string depth ?
)
5360 (t (error "allout-listify-exposed: %s %s"
5361 "invalid format" format
))))
5362 (list depth prefix strings
))
5364 ;; Reasses format, if any:
5365 (if (and format
(listp format
))
5366 (cond ((= new-depth depth
)
5367 (setq format
(cons (1+ (car format
))
5369 ((> new-depth depth
) ; descending - assume by 1:
5370 (setq format
(cons 1 format
)))
5373 (while (< new-depth depth
)
5374 (setq format
(cdr format
))
5375 (setq depth
(1- depth
)))
5376 ; And increment the current one:
5378 (cons (1+ (or (car format
)
5381 ;; Put the list with first at front, to last at back:
5382 (nreverse result
))))
5383 ;;;_ > my-region-active-p ()
5384 (defmacro my-region-active-p
()
5385 (if (fboundp 'region-active-p
)
5388 ;;;_ > allout-process-exposed (&optional func from to frombuf
5390 (defun allout-process-exposed (&optional func from to frombuf tobuf
5392 "Map function on exposed parts of current topic; results to another buffer.
5394 All args are options; default values itemized below.
5396 Apply FUNCTION to exposed portions FROM position TO position in buffer
5397 FROMBUF to buffer TOBUF. Sixth optional arg, FORMAT, designates an
5398 alternate presentation form:
5400 `flat' - Present prefix as numeric section.subsection..., starting with
5401 section indicated by the start-num, innermost nesting first.
5402 X`flat-indented' - Prefix is like `flat' for first topic at each
5403 X level, but subsequent topics have only leaf topic
5404 X number, padded with blanks to line up with first.
5405 `indent' (symbol) - Convert header prefixes to all white space,
5406 except for distinctive bullets.
5409 FUNCTION: `allout-insert-listified'
5410 FROM: region start, if region active, else start of buffer
5411 TO: region end, if region active, else end of buffer
5412 FROMBUF: current buffer
5413 TOBUF: buffer name derived: \"*current-buffer-name exposed*\"
5416 ; Resolve arguments,
5417 ; defaulting if necessary:
5418 (if (not func
) (setq func
'allout-insert-listified
))
5419 (if (not (and from to
))
5420 (if (my-region-active-p)
5421 (setq from
(region-beginning) to
(region-end))
5422 (setq from
(point-min) to
(point-max))))
5424 (if (not (bufferp frombuf
))
5425 ;; Specified but not a buffer - get it:
5426 (let ((got (get-buffer frombuf
)))
5428 (error (concat "allout-process-exposed: source buffer "
5431 (setq frombuf got
))))
5432 ;; not specified - default it:
5433 (setq frombuf
(current-buffer)))
5435 (if (not (bufferp tobuf
))
5436 (setq tobuf
(get-buffer-create tobuf
)))
5437 ;; not specified - default it:
5438 (setq tobuf
(concat "*" (buffer-name frombuf
) " exposed*")))
5443 (progn (set-buffer frombuf
)
5444 (allout-listify-exposed from to format
))))
5446 (mapcar func listified
)
5447 (pop-to-buffer tobuf
)))
5450 ;;;_ > allout-insert-listified (listified)
5451 (defun allout-insert-listified (listified)
5452 "Insert contents of listified outline portion in current buffer.
5454 LISTIFIED is a list representing each topic header and body:
5456 \`(depth prefix text)'
5458 or \`(depth prefix text bullet-plus)'
5460 If `bullet-plus' is specified, it is inserted just after the entire prefix."
5461 (setq listified
(cdr listified
))
5462 (let ((prefix (prog1
5464 (setq listified
(cdr listified
))))
5467 (setq listified
(cdr listified
))))
5468 (bullet-plus (car listified
)))
5470 (if bullet-plus
(insert (concat " " bullet-plus
)))
5473 (if (setq text
(cdr text
))
5476 ;;;_ > allout-copy-exposed-to-buffer (&optional arg tobuf format)
5477 (defun allout-copy-exposed-to-buffer (&optional arg tobuf format
)
5478 "Duplicate exposed portions of current outline to another buffer.
5480 Other buffer has current buffers name with \" exposed\" appended to it.
5482 With repeat count, copy the exposed parts of only the current topic.
5484 Optional second arg TOBUF is target buffer name.
5486 Optional third arg FORMAT, if non-nil, symbolically designates an
5487 alternate presentation format for the outline:
5489 `flat' - Convert topic header prefixes to numeric
5490 section.subsection... identifiers.
5491 `indent' - Convert header prefixes to all white space, except for
5492 distinctive bullets.
5493 `indent-flat' - The best of both - only the first of each level has
5494 the full path, the rest have only the section number
5495 of the leaf, preceded by the right amount of indentation."
5499 (setq tobuf
(get-buffer-create (concat "*" (buffer-name) " exposed*"))))
5500 (let* ((start-pt (point))
5501 (beg (if arg
(allout-back-to-current-heading) (point-min)))
5502 (end (if arg
(allout-end-of-current-subtree) (point-max)))
5503 (buf (current-buffer))
5505 (if (eq format
'flat
)
5506 (setq format
(if arg
(save-excursion
5508 (allout-topic-flat-index))
5510 (save-excursion (set-buffer tobuf
)(erase-buffer))
5511 (allout-process-exposed 'allout-insert-listified
5517 (goto-char (point-min))
5519 (goto-char start-pt
)))
5520 ;;;_ > allout-flatten-exposed-to-buffer (&optional arg tobuf)
5521 (defun allout-flatten-exposed-to-buffer (&optional arg tobuf
)
5522 "Present numeric outline of outline's exposed portions in another buffer.
5524 The resulting outline is not compatible with outline mode - use
5525 `allout-copy-exposed-to-buffer' if you want that.
5527 Use `allout-indented-exposed-to-buffer' for indented presentation.
5529 With repeat count, copy the exposed portions of only current topic.
5531 Other buffer has current buffer's name with \" exposed\" appended to
5532 it, unless optional second arg TOBUF is specified, in which case it is
5535 (allout-copy-exposed-to-buffer arg tobuf
'flat
))
5536 ;;;_ > allout-indented-exposed-to-buffer (&optional arg tobuf)
5537 (defun allout-indented-exposed-to-buffer (&optional arg tobuf
)
5538 "Present indented outline of outline's exposed portions in another buffer.
5540 The resulting outline is not compatible with outline mode - use
5541 `allout-copy-exposed-to-buffer' if you want that.
5543 Use `allout-flatten-exposed-to-buffer' for numeric sectional presentation.
5545 With repeat count, copy the exposed portions of only current topic.
5547 Other buffer has current buffer's name with \" exposed\" appended to
5548 it, unless optional second arg TOBUF is specified, in which case it is
5551 (allout-copy-exposed-to-buffer arg tobuf
'indent
))
5553 ;;;_ - LaTeX formatting
5554 ;;;_ > allout-latex-verb-quote (string &optional flow)
5555 (defun allout-latex-verb-quote (string &optional flow
)
5556 "Return copy of STRING for literal reproduction across LaTeX processing.
5557 Expresses the original characters (including carriage returns) of the
5558 string across LaTeX processing."
5559 (mapconcat (function
5561 (cond ((memq char
'(?
\\ ?$ ?% ?
# ?
& ?
{ ?
} ?_ ?^ ?- ?
*))
5562 (concat "\\char" (number-to-string char
) "{}"))
5563 ((= char ?
\n) "\\\\")
5564 (t (char-to-string char
)))))
5567 ;;;_ > allout-latex-verbatim-quote-curr-line ()
5568 (defun allout-latex-verbatim-quote-curr-line ()
5569 "Express line for exact (literal) representation across LaTeX processing.
5571 Adjust line contents so it is unaltered (from the original line)
5572 across LaTeX processing, within the context of a `verbatim'
5573 environment. Leaves point at the end of the line."
5574 (let ((inhibit-field-text-motion t
))
5577 (end (progn (end-of-line)(point))))
5579 (while (re-search-forward "\\\\"
5580 ;;"\\\\\\|\\{\\|\\}\\|\\_\\|\\$\\|\\\"\\|\\&\\|\\^\\|\\-\\|\\*\\|#"
5581 end
; bounded by end-of-line
5582 1) ; no matches, move to end & return nil
5583 (goto-char (match-beginning 2))
5586 (goto-char (1+ (match-end 2)))))))
5587 ;;;_ > allout-insert-latex-header (buffer)
5588 (defun allout-insert-latex-header (buffer)
5589 "Insert initial LaTeX commands at point in BUFFER."
5590 ;; Much of this is being derived from the stuff in appendix of E in
5591 ;; the TeXBook, pg 421.
5593 (let ((doc-style (format "\n\\documentstyle{%s}\n"
5595 (page-numbering (if allout-number-pages
5596 "\\pagestyle{empty}\n"
5598 (titlecmd (format "\\newcommand{\\titlecmd}[1]{{%s #1}}\n"
5599 allout-title-style
))
5600 (labelcmd (format "\\newcommand{\\labelcmd}[1]{{%s #1}}\n"
5601 allout-label-style
))
5602 (headlinecmd (format "\\newcommand{\\headlinecmd}[1]{{%s #1}}\n"
5603 allout-head-line-style
))
5604 (bodylinecmd (format "\\newcommand{\\bodylinecmd}[1]{{%s #1}}\n"
5605 allout-body-line-style
))
5606 (setlength (format "%s%s%s%s"
5607 "\\newlength{\\stepsize}\n"
5608 "\\setlength{\\stepsize}{"
5611 (oneheadline (format "%s%s%s%s%s%s%s"
5612 "\\newcommand{\\OneHeadLine}[3]{%\n"
5614 "\\hspace*{#2\\stepsize}%\n"
5615 "\\labelcmd{#1}\\hspace*{.2cm}"
5616 "\\headlinecmd{#3}\\\\["
5619 (onebodyline (format "%s%s%s%s%s%s"
5620 "\\newcommand{\\OneBodyLine}[2]{%\n"
5622 "\\hspace*{#1\\stepsize}%\n"
5623 "\\bodylinecmd{#2}\\\\["
5626 (begindoc "\\begin{document}\n\\begin{center}\n")
5627 (title (format "%s%s%s%s"
5629 (allout-latex-verb-quote (if allout-title
5632 (error "<unnamed buffer>"))
5635 "\\end{center}\n\n"))
5636 (hsize "\\hsize = 7.5 true in\n")
5637 (hoffset "\\hoffset = -1.5 true in\n")
5638 (vspace "\\vspace{.1cm}\n\n"))
5639 (insert (concat doc-style
5654 ;;;_ > allout-insert-latex-trailer (buffer)
5655 (defun allout-insert-latex-trailer (buffer)
5656 "Insert concluding LaTeX commands at point in BUFFER."
5658 (insert "\n\\end{document}\n"))
5659 ;;;_ > allout-latexify-one-item (depth prefix bullet text)
5660 (defun allout-latexify-one-item (depth prefix bullet text
)
5661 "Insert LaTeX commands for formatting one outline item.
5663 Args are the topics numeric DEPTH, the header PREFIX lead string, the
5664 BULLET string, and a list of TEXT strings for the body."
5665 (let* ((head-line (if text
(car text
)))
5666 (body-lines (cdr text
))
5670 (insert (concat "\\OneHeadLine{\\verb\1 "
5671 (allout-latex-verb-quote bullet
)
5676 (allout-latex-verb-quote head-line
)
5679 (if (not body-lines
)
5681 ;;(insert "\\beginlines\n")
5682 (insert "\\begin{verbatim}\n")
5684 (setq curr-line
(car body-lines
))
5685 (if (and (not body-content
)
5686 (not (string-match "^\\s-*$" curr-line
)))
5687 (setq body-content t
))
5688 ; Mangle any occurrences of
5689 ; "\end{verbatim}" in text,
5691 (if (and body-content
5692 (setq bop
(string-match "\\end{verbatim}" curr-line
)))
5693 (setq curr-line
(concat (substring curr-line
0 bop
)
5695 (substring curr-line bop
))))
5696 ;;(insert "|" (car body-lines) "|")
5698 (allout-latex-verbatim-quote-curr-line)
5700 (setq body-lines
(cdr body-lines
)))
5702 (setq body-content nil
)
5706 ;;(insert "\\endlines\n")
5707 (insert "\\end{verbatim}\n")
5709 ;;;_ > allout-latexify-exposed (arg &optional tobuf)
5710 (defun allout-latexify-exposed (arg &optional tobuf
)
5711 "Format current topics exposed portions to TOBUF for LaTeX processing.
5712 TOBUF defaults to a buffer named the same as the current buffer, but
5713 with \"*\" prepended and \" latex-formed*\" appended.
5715 With repeat count, copy the exposed portions of entire buffer."
5720 (get-buffer-create (concat "*" (buffer-name) " latexified*"))))
5721 (let* ((start-pt (point))
5722 (beg (if arg
(point-min) (allout-back-to-current-heading)))
5723 (end (if arg
(point-max) (allout-end-of-current-subtree)))
5724 (buf (current-buffer)))
5727 (allout-insert-latex-header tobuf
)
5728 (goto-char (point-max))
5729 (allout-process-exposed 'allout-latexify-one-item
5734 (goto-char (point-max))
5735 (allout-insert-latex-trailer tobuf
)
5736 (goto-char (point-min))
5738 (goto-char start-pt
)))
5741 ;;;_ > allout-toggle-current-subtree-encryption (&optional fetch-pass)
5742 (defun allout-toggle-current-subtree-encryption (&optional fetch-pass
)
5743 "Encrypt clear or decrypt encoded text of visibly-containing topic's contents.
5745 Optional FETCH-PASS universal argument provokes key-pair encryption with
5746 single universal argument. With doubled universal argument (value = 16),
5747 it forces prompting for the passphrase regardless of availability from the
5748 passphrase cache. With no universal argument, the appropriate passphrase
5749 is obtained from the cache, if available, else from the user.
5751 Currently only GnuPG encryption is supported.
5753 \**NOTE WELL** that the encrypted text must be ascii-armored. For gnupg
5754 encryption, include the option ``armor'' in your ~/.gnupg/gpg.conf file.
5756 Both symmetric-key and key-pair encryption is implemented. Symmetric is
5757 the default, use a single (x4) universal argument for keypair mode.
5759 Encrypted topic's bullet is set to a `~' to signal that the contents of the
5760 topic (body and subtopics, but not heading) is pending encryption or
5761 encrypted. `*' asterisk immediately after the bullet signals that the body
5762 is encrypted, its' absence means the topic is meant to be encrypted but is
5763 not. When a file with topics pending encryption is saved, topics pending
5764 encryption are encrypted. See allout-encrypt-unencrypted-on-saves for
5765 auto-encryption specifics.
5767 \**NOTE WELL** that automatic encryption that happens during saves will
5768 default to symmetric encryption - you must manually (re)encrypt key-pair
5769 encrypted topics if you want them to continue to use the key-pair cipher.
5771 Level-one topics, with prefix consisting solely of an `*' asterisk, cannot be
5772 encrypted. If you want to encrypt the contents of a top-level topic, use
5773 \\[allout-shift-in] to increase its depth.
5777 The encryption passphrase is solicited if not currently available in the
5778 passphrase cache from a recent encryption action.
5780 The solicited passphrase is retained for reuse in a buffer-specific cache
5781 for some set period of time (default, 60 seconds), after which the string
5782 is nulled. The passphrase cache timeout is customized by setting
5783 `pgg-passphrase-cache-expiry'.
5785 Symmetric Passphrase Hinting and Verification
5787 If the file previously had no associated passphrase, or had a different
5788 passphrase than specified, the user is prompted to repeat the new one for
5789 corroboration. A random string encrypted by the new passphrase is set on
5790 the buffer-specific variable `allout-passphrase-verifier-string', for
5791 confirmation of the passphrase when next obtained, before encrypting or
5792 decrypting anything with it. This helps avoid mistakenly shifting between
5795 If allout customization var `allout-passphrase-verifier-handling' is
5796 non-nil, an entry for `allout-passphrase-verifier-string' and its value is
5797 added to an Emacs 'local variables' section at the end of the file, which
5798 is created if necessary. That setting is for retention of the passphrase
5799 verifier across Emacs sessions.
5801 Similarly, `allout-passphrase-hint-string' stores a user-provided reminder
5802 about their passphrase, and `allout-passphrase-hint-handling' specifies
5803 when the hint is presented, or if passphrase hints are disabled. If
5804 enabled (see the `allout-passphrase-hint-handling' docstring for details),
5805 the hint string is stored in the local-variables section of the file, and
5806 solicited whenever the passphrase is changed."
5809 (allout-back-to-current-heading)
5810 (allout-toggle-subtree-encryption fetch-pass
)
5813 ;;;_ > allout-toggle-subtree-encryption (&optional fetch-pass)
5814 (defun allout-toggle-subtree-encryption (&optional fetch-pass
)
5815 "Encrypt clear text or decrypt encoded topic contents (body and subtopics.)
5817 Optional FETCH-PASS universal argument provokes key-pair encryption with
5818 single universal argument. With doubled universal argument (value = 16),
5819 it forces prompting for the passphrase regardless of availability from the
5820 passphrase cache. With no universal argument, the appropriate passphrase
5821 is obtained from the cache, if available, else from the user.
5823 Currently only GnuPG encryption is supported.
5825 \**NOTE WELL** that the encrypted text must be ascii-armored. For gnupg
5826 encryption, include the option ``armor'' in your ~/.gnupg/gpg.conf file.
5828 See `allout-toggle-current-subtree-encryption' for more details."
5832 (allout-end-of-prefix t
)
5834 (if (= allout-recent-depth
1)
5835 (error (concat "Cannot encrypt or decrypt level 1 topics -"
5836 " shift it in to make it encryptable")))
5838 (let* ((allout-buffer (current-buffer))
5840 (bullet-pos allout-recent-prefix-beginning
)
5841 (after-bullet-pos (point))
5843 (progn (if (= (point-max) after-bullet-pos
)
5844 (error "no body to encrypt"))
5845 (allout-encrypted-topic-p)))
5846 (was-collapsed (if (not (search-forward "\n" nil t
))
5850 (subtree-beg (1+ (point)))
5851 (subtree-end (allout-end-of-subtree))
5852 (subject-text (buffer-substring-no-properties subtree-beg
5854 (subtree-end-char (char-after (1- subtree-end
)))
5855 (subtree-trailing-char (char-after subtree-end
))
5856 ;; kluge - result-text needs to be nil, but we also want to
5857 ;; check for the error condition
5858 (result-text (if (or (string= "" subject-text
)
5859 (string= "\n" subject-text
))
5860 (error "No topic contents to %scrypt"
5861 (if was-encrypted
"de" "en"))
5863 ;; Assess key parameters:
5865 ;; detect the type by which it is already encrypted
5867 (allout-encrypted-key-info subject-text
))
5868 (and (member fetch-pass
'(4 (4)))
5871 (for-key-type (car key-info
))
5872 (for-key-identity (cadr key-info
))
5873 (fetch-pass (and fetch-pass
(member fetch-pass
'(16 (16)))))
5874 (was-coding-system buffer-file-coding-system
))
5876 (when (not was-encrypted
)
5877 ;; ensure that non-ascii chars pending encryption are noticed before
5878 ;; they're encrypted, so the coding system is set to accomodate
5880 (setq buffer-file-coding-system
5881 (select-safe-coding-system subtree-beg subtree-end
))
5882 ;; if the coding system for the text being encrypted is different
5883 ;; than that prevailing, then there a real risk that the coding
5884 ;; system can't be noticed by emacs when the file is visited. to
5885 ;; mitigate that, offer to preserve the coding system using a file
5887 (if (and (not (equal buffer-file-coding-system
5890 (format (concat "Register coding system %s as file local"
5891 " var? Necessary when only encrypted text"
5892 " is in that coding system. ")
5893 buffer-file-coding-system
)))
5894 (allout-adjust-file-variable "buffer-file-coding-system"
5895 buffer-file-coding-system
)))
5898 (allout-encrypt-string subject-text was-encrypted
5900 for-key-type for-key-identity fetch-pass
))
5902 ;; Replace the subtree with the processed product.
5905 (set-buffer allout-buffer
)
5906 (delete-region subtree-beg subtree-end
)
5907 (insert result-text
)
5909 (allout-flag-region (1- subtree-beg
) (point) t
))
5910 ;; adjust trailing-blank-lines to preserve topic spacing:
5911 (if (not was-encrypted
)
5912 (if (and (= subtree-end-char ?
\n)
5913 (= subtree-trailing-char ?
\n))
5914 (insert subtree-trailing-char
)))
5915 ;; Ensure that the item has an encrypted-entry bullet:
5916 (if (not (string= (buffer-substring-no-properties
5917 (1- after-bullet-pos
) after-bullet-pos
)
5918 allout-topic-encryption-bullet
))
5919 (progn (goto-char (1- after-bullet-pos
))
5921 (insert allout-topic-encryption-bullet
)))
5923 ;; Remove the is-encrypted bullet qualifier:
5924 (progn (goto-char after-bullet-pos
)
5926 ;; Add the is-encrypted bullet qualifier:
5927 (goto-char after-bullet-pos
)
5929 (run-hook-with-args 'allout-structure-added-hook
5930 bullet-pos subtree-end
))))
5931 ;;;_ > allout-encrypt-string (text decrypt allout-buffer key-type for-key
5932 ;;; fetch-pass &optional retried verifying
5934 (defun allout-encrypt-string (text decrypt allout-buffer key-type for-key
5935 fetch-pass
&optional retried rejected
5936 verifying passphrase
)
5937 "Encrypt or decrypt message TEXT.
5939 If DECRYPT is true (default false), then decrypt instead of encrypt.
5941 FETCH-PASS (default false) forces fresh prompting for the passphrase.
5943 KEY-TYPE indicates whether to use a 'symmetric or 'keypair cipher.
5945 FOR-KEY is human readable identification of the first of the user's
5946 eligible secret keys a keypair decryption targets, or else nil.
5948 Optional RETRIED is for internal use - conveys the number of failed keys
5949 that have been solicited in sequence leading to this current call.
5951 Optional PASSPHRASE enables explicit delivery of the decryption passphrase,
5952 for verification purposes.
5954 Optional REJECTED is for internal use - conveys the number of
5955 rejections due to matches against
5956 `allout-encryption-ciphertext-rejection-regexps', as limited by
5957 `allout-encryption-ciphertext-rejection-ceiling'.
5959 Returns the resulting string, or nil if the transformation fails."
5963 (if (not (fboundp 'pgg-encrypt-symmetric
))
5964 (error "Allout encryption depends on a newer version of pgg"))
5966 (let* ((scheme (upcase
5967 (format "%s" (or pgg-scheme pgg-default-scheme
"GPG"))))
5968 (for-key (and (equal key-type
'keypair
)
5970 (split-string (read-string
5971 (format "%s message recipients: "
5974 (target-prompt-id (if (equal key-type
'keypair
)
5975 (if (= (length for-key
) 1)
5976 (car for-key
) for-key
)
5977 (buffer-name allout-buffer
)))
5978 (target-cache-id (format "%s-%s"
5980 (if (equal key-type
'keypair
)
5982 (or (buffer-file-name allout-buffer
)
5983 target-prompt-id
))))
5984 (encoding (with-current-buffer allout-buffer
5985 buffer-file-coding-system
))
5986 (multibyte (with-current-buffer allout-buffer
5987 enable-multibyte-characters
))
5988 (strip-plaintext-regexps
5990 (allout-get-configvar-values
5991 'allout-encryption-plaintext-sanitization-regexps
)))
5992 (reject-ciphertext-regexps
5994 (allout-get-configvar-values
5995 'allout-encryption-ciphertext-rejection-regexps
)))
5996 (rejected (or rejected
0))
5997 (rejections-left (- allout-encryption-ciphertext-rejection-ceiling
6001 (if (and fetch-pass
(not passphrase
))
6002 ;; Force later fetch by evicting passphrase from the cache.
6003 (pgg-remove-passphrase-from-cache target-cache-id t
))
6005 (catch 'encryption-failed
6007 ;; Obtain the passphrase if we don't already have one and we're not
6008 ;; doing a keypair encryption:
6009 (if (not (or passphrase
6010 (and (equal key-type
'keypair
)
6013 (setq passphrase
(allout-obtain-passphrase for-key
6018 retried fetch-pass
)))
6024 ;; convey the text characteristics of the original buffer:
6025 (set-buffer-multibyte multibyte
)
6027 (set-buffer-file-coding-system encoding
)
6029 (encode-coding-region (point-min) (point-max) encoding
)))
6031 (when (and strip-plaintext-regexps
(not decrypt
))
6032 (dolist (re strip-plaintext-regexps
)
6033 (let ((re (if (listp re
) (car re
) re
))
6034 (replacement (if (listp re
) (cadr re
) "")))
6035 (goto-char (point-min))
6036 (while (re-search-forward re nil t
)
6037 (replace-match replacement nil nil
)))))
6042 ((equal key-type
'symmetric
)
6046 (pgg-decrypt (point-min) (point-max) passphrase
)
6048 (pgg-encrypt-symmetric (point-min) (point-max)
6052 (pgg-situate-output (point-min) (point-max))
6053 ;; failed - handle passphrase caching
6055 (throw 'encryption-failed nil
)
6056 (pgg-remove-passphrase-from-cache target-cache-id t
)
6057 (error "Symmetric-cipher %scryption failed - %s"
6058 (if decrypt
"de" "en")
6059 "try again with different passphrase."))))
6061 ;; encrypt 'keypair:
6066 (pgg-encrypt for-key
6067 nil
(point-min) (point-max) passphrase
))
6070 (pgg-situate-output (point-min) (point-max))
6071 (error (pgg-remove-passphrase-from-cache target-cache-id t
)
6072 (error "encryption failed"))))
6074 ;; decrypt 'keypair:
6078 (pgg-decrypt (point-min) (point-max) passphrase
))
6081 (pgg-situate-output (point-min) (point-max))
6082 (error (pgg-remove-passphrase-from-cache target-cache-id t
)
6083 (error "decryption failed")))))
6086 (buffer-substring-no-properties
6087 1 (- (point-max) (if decrypt
0 1))))
6090 ;; validate result - non-empty
6091 (cond ((not result-text
)
6094 ;; transform was fruitless, retry w/new passphrase.
6095 (pgg-remove-passphrase-from-cache target-cache-id t
)
6096 (allout-encrypt-string text decrypt allout-buffer
6097 key-type for-key nil
6098 (if retried
(1+ retried
) 1)
6099 rejected verifying nil
)))
6101 ;; Retry (within limit) if ciphertext contains rejections:
6103 ;; Check for disqualification of this ciphertext:
6104 (let ((regexps reject-ciphertext-regexps
)
6106 (while (and regexps
(not reject-it
))
6107 (setq reject-it
(string-match (car regexps
)
6111 (setq rejections-left
(1- rejections-left
))
6112 (if (<= rejections-left
0)
6113 (error (concat "Ciphertext rejected too many times"
6115 allout-encryption-ciphertext-rejection-ceiling
6116 'allout-encryption-ciphertext-rejection-regexps
)
6117 (allout-encrypt-string text decrypt allout-buffer
6118 key-type for-key nil
6119 retried
(1+ rejected
)
6120 verifying passphrase
)))
6121 ;; Barf if encryption yields extraordinary control chars:
6123 (string-match "[\C-a\C-k\C-o-\C-z\C-@]"
6125 (error (concat "Encryption produced non-armored text, which"
6126 "conflicts with allout mode - reconfigure!")))
6128 ;; valid result and just verifying or non-symmetric:
6129 ((or verifying
(not (equal key-type
'symmetric
)))
6130 (if (or verifying decrypt
)
6131 (pgg-add-passphrase-to-cache target-cache-id
6135 ;; valid result and regular symmetric - "register"
6136 ;; passphrase with mnemonic aids/cache.
6138 (set-buffer allout-buffer
)
6140 (pgg-add-passphrase-to-cache target-cache-id
6142 (allout-update-passphrase-mnemonic-aids for-key passphrase
6149 ;;;_ > allout-obtain-passphrase (for-key cache-id prompt-id key-type
6150 ;;; allout-buffer retried fetch-pass)
6151 (defun allout-obtain-passphrase (for-key cache-id prompt-id key-type
6152 allout-buffer retried fetch-pass
)
6153 "Obtain passphrase for a key from the cache or else from the user.
6155 When obtaining from the user, symmetric-cipher passphrases are verified
6156 against either, if available and enabled, a random string that was
6157 encrypted against the passphrase, or else against repeated entry by the
6158 user for corroboration.
6160 FOR-KEY is the key for which the passphrase is being obtained.
6162 CACHE-ID is the cache id of the key for the passphrase.
6164 PROMPT-ID is the id for use when prompting the user.
6166 KEY-TYPE is either 'symmetric or 'keypair.
6168 ALLOUT-BUFFER is the buffer containing the entry being en/decrypted.
6170 RETRIED is the number of this attempt to obtain this passphrase.
6172 FETCH-PASS causes the passphrase to be solicited from the user, regardless
6173 of the availability of a cached copy."
6175 (if (not (equal key-type
'symmetric
))
6176 ;; do regular passphrase read on non-symmetric passphrase:
6177 (pgg-read-passphrase (format "%s passphrase%s: "
6178 (upcase (format "%s" (or pgg-scheme
6182 (format " for %s" prompt-id
)
6186 ;; Symmetric hereon:
6189 (set-buffer allout-buffer
)
6190 (let* ((hint (if (and (not (string= allout-passphrase-hint-string
""))
6191 (or (equal allout-passphrase-hint-handling
'always
)
6192 (and (equal allout-passphrase-hint-handling
6195 (format " [%s]" allout-passphrase-hint-string
)
6197 (retry-message (if retried
(format " (%s retry)" retried
) ""))
6198 (prompt-sans-hint (format "'%s' symmetric passphrase%s: "
6199 prompt-id retry-message
))
6200 (full-prompt (format "'%s' symmetric passphrase%s%s: "
6201 prompt-id hint retry-message
))
6202 (prompt full-prompt
)
6203 (verifier-string (allout-get-encryption-passphrase-verifier))
6205 (cached (and (not fetch-pass
)
6206 (pgg-read-passphrase-from-cache cache-id t
)))
6207 (got-pass (or cached
6208 (pgg-read-passphrase full-prompt cache-id t
)))
6214 ;; Duplicate our handle on the passphrase so it's not clobbered by
6215 ;; deactivate-passwd memory clearing:
6216 (setq got-pass
(copy-sequence got-pass
))
6218 (cond (verifier-string
6219 (save-window-excursion
6220 (if (allout-encrypt-string verifier-string
'decrypt
6221 allout-buffer
'symmetric
6222 for-key nil
0 0 'verifying
6223 (copy-sequence got-pass
))
6224 (setq confirmation
(format "%s" got-pass
))))
6226 (if (and (not confirmation
)
6228 (concat "Passphrase differs from established"
6229 " - use new one instead? "))
6230 ;; deactivate password for subsequent
6233 (pgg-remove-passphrase-from-cache cache-id t
)
6234 (setq prompt prompt-sans-hint
)
6237 (progn (pgg-remove-passphrase-from-cache cache-id t
)
6238 (error "Wrong passphrase."))))
6239 ;; No verifier string - force confirmation by repetition of
6240 ;; (new) passphrase:
6241 ((or fetch-pass
(not cached
))
6242 (pgg-remove-passphrase-from-cache cache-id t
))))
6243 ;; confirmation vs new input - doing pgg-read-passphrase will do the
6244 ;; right thing, in either case:
6245 (if (not confirmation
)
6247 (pgg-read-passphrase (concat prompt
6248 " ... confirm spelling: ")
6251 (if (equal got-pass confirmation
)
6253 (if (yes-or-no-p (concat "spelling of original and"
6254 " confirmation differ - retry? "))
6255 (progn (setq retried
(if retried
(1+ retried
) 1))
6256 (pgg-remove-passphrase-from-cache cache-id t
)
6257 ;; recurse to this routine:
6258 (pgg-read-passphrase prompt-sans-hint cache-id t
))
6259 (pgg-remove-passphrase-from-cache cache-id t
)
6260 (error "Confirmation failed."))))))))
6261 ;;;_ > allout-encrypted-topic-p ()
6262 (defun allout-encrypted-topic-p ()
6263 "True if the current topic is encryptable and encrypted."
6265 (allout-end-of-prefix t
)
6266 (and (string= (buffer-substring-no-properties (1- (point)) (point))
6267 allout-topic-encryption-bullet
)
6271 ;;;_ > allout-encrypted-key-info (text)
6272 ;; XXX gpg-specific, alas
6273 (defun allout-encrypted-key-info (text)
6274 "Return a pair of the key type and identity of a recipient's secret key.
6276 The key type is one of 'symmetric or 'keypair.
6278 if 'keypair, and some of the user's secret keys are among those for which
6279 the message was encoded, return the identity of the first. otherwise,
6280 return nil for the second item of the pair.
6282 An error is raised if the text is not encrypted."
6283 (require 'pgg-parse
)
6287 (let* ((parsed-armor (pgg-parse-armor-region (point-min) (point-max)))
6288 (type (if (pgg-gpg-symmetric-key-p parsed-armor
)
6291 secret-keys first-secret-key for-key-owner
)
6292 (if (equal type
'keypair
)
6293 (setq secret-keys
(pgg-gpg-lookup-all-secret-keys)
6294 first-secret-key
(pgg-gpg-select-matching-key parsed-armor
6296 for-key-owner
(and first-secret-key
6297 (pgg-gpg-lookup-key-owner
6298 first-secret-key
))))
6299 (list type
(pgg-gpg-key-id-from-key-owner for-key-owner
))
6304 ;;;_ > allout-create-encryption-passphrase-verifier (passphrase)
6305 (defun allout-create-encryption-passphrase-verifier (passphrase)
6306 "Encrypt random message for later validation of symmetric key's passphrase."
6307 ;; use 20 random ascii characters, across the entire ascii range.
6309 (let ((spew (make-string 20 ?\
0)))
6310 (dotimes (i (length spew
))
6311 (aset spew i
(1+ (random 254))))
6312 (allout-encrypt-string spew nil
(current-buffer) 'symmetric
6313 nil nil
0 0 passphrase
))
6315 ;;;_ > allout-update-passphrase-mnemonic-aids (for-key passphrase
6317 (defun allout-update-passphrase-mnemonic-aids (for-key passphrase
6319 "Update passphrase verifier and hint strings if necessary.
6321 See `allout-passphrase-verifier-string' and `allout-passphrase-hint-string'
6324 PASSPHRASE is the passphrase being mnemonicized
6326 OUTLINE-BUFFER is the buffer of the outline being adjusted.
6328 These are used to help the user keep track of the passphrase they use for
6329 symmetric encryption in the file.
6331 Behavior is governed by `allout-passphrase-verifier-handling',
6332 `allout-passphrase-hint-handling', and also, controlling whether the values
6333 are preserved on Emacs local file variables,
6334 `allout-enable-file-variable-adjustment'."
6336 ;; If passphrase doesn't agree with current verifier:
6337 ;; - adjust the verifier
6338 ;; - if passphrase hint handling is enabled, adjust the passphrase hint
6339 ;; - if file var settings are enabled, adjust the file vars
6341 (let* ((new-verifier-needed (not (allout-verify-passphrase
6342 for-key passphrase outline-buffer
)))
6343 (new-verifier-string
6344 (if new-verifier-needed
6345 ;; Collapse to a single line and enclose in string quotes:
6346 (subst-char-in-string
6347 ?
\n ?\C-a
(allout-create-encryption-passphrase-verifier
6350 (when new-verifier-string
6351 ;; do the passphrase hint first, since it's interactive
6352 (when (and allout-passphrase-hint-handling
6353 (not (equal allout-passphrase-hint-handling
'disabled
)))
6355 (read-from-minibuffer "Passphrase hint to jog your memory: "
6356 allout-passphrase-hint-string
))
6357 (when (not (string= new-hint allout-passphrase-hint-string
))
6358 (setq allout-passphrase-hint-string new-hint
)
6359 (allout-adjust-file-variable "allout-passphrase-hint-string"
6360 allout-passphrase-hint-string
)))
6361 (when allout-passphrase-verifier-handling
6362 (setq allout-passphrase-verifier-string new-verifier-string
)
6363 (allout-adjust-file-variable "allout-passphrase-verifier-string"
6364 allout-passphrase-verifier-string
))
6368 ;;;_ > allout-get-encryption-passphrase-verifier ()
6369 (defun allout-get-encryption-passphrase-verifier ()
6370 "Return text of the encrypt passphrase verifier, unmassaged, or nil if none.
6372 Derived from value of `allout-passphrase-verifier-string'."
6374 (let ((verifier-string (and (boundp 'allout-passphrase-verifier-string
)
6375 allout-passphrase-verifier-string
)))
6377 ;; Return it uncollapsed
6378 (subst-char-in-string ?\C-a ?
\n verifier-string
))
6381 ;;;_ > allout-verify-passphrase (key passphrase allout-buffer)
6382 (defun allout-verify-passphrase (key passphrase allout-buffer
)
6383 "True if passphrase successfully decrypts verifier, nil otherwise.
6385 \"Otherwise\" includes absence of passphrase verifier."
6387 (set-buffer allout-buffer
)
6388 (and (boundp 'allout-passphrase-verifier-string
)
6389 allout-passphrase-verifier-string
6390 (allout-encrypt-string (allout-get-encryption-passphrase-verifier)
6391 'decrypt allout-buffer
'symmetric
6392 key nil
0 0 'verifying passphrase
)
6394 ;;;_ > allout-next-topic-pending-encryption (&optional except-mark)
6395 (defun allout-next-topic-pending-encryption (&optional except-mark
)
6396 "Return the point of the next topic pending encryption, or nil if none.
6398 EXCEPT-MARK identifies a point whose containing topics should be excluded
6399 from encryption. This supports 'except-current mode of
6400 `allout-encrypt-unencrypted-on-saves'.
6402 Such a topic has the allout-topic-encryption-bullet without an
6403 immediately following '*' that would mark the topic as being encrypted. It
6404 must also have content."
6405 (let (done got content-beg
)
6408 (if (not (re-search-forward
6409 (format "\\(\\`\\|\n\\)%s *%s[^*]"
6410 (regexp-quote allout-header-prefix
)
6411 (regexp-quote allout-topic-encryption-bullet
))
6415 (goto-char (setq got
(match-beginning 0)))
6416 (if (looking-at "\n")
6423 ((not (search-forward "\n"))
6432 (setq content-beg
(point))
6434 (allout-end-of-subtree)
6435 (if (or (<= (point) content-beg
)
6437 (<= content-beg except-mark
)
6438 (>= (point) except-mark
)))
6449 ;;;_ > allout-encrypt-decrypted (&optional except-mark)
6450 (defun allout-encrypt-decrypted (&optional except-mark
)
6451 "Encrypt topics pending encryption except those containing exemption point.
6453 EXCEPT-MARK identifies a point whose containing topics should be excluded
6454 from encryption. This supports 'except-current mode of
6455 `allout-encrypt-unencrypted-on-saves'.
6457 If a topic that is currently being edited was encrypted, we return a list
6458 containing the location of the topic and the location of the cursor just
6459 before the topic was encrypted. This can be used, eg, to decrypt the topic
6460 and exactly resituate the cursor if this is being done as part of a file
6461 save. See `allout-encrypt-unencrypted-on-saves' for more info."
6465 (let* ((current-mark (point-marker))
6466 (current-mark-position (marker-position current-mark
))
6469 editing-topic editing-point
)
6470 (goto-char (point-min))
6471 (while (allout-next-topic-pending-encryption except-mark
)
6472 (setq was-modified
(buffer-modified-p))
6473 (when (save-excursion
6474 (and (boundp 'allout-encrypt-unencrypted-on-saves
)
6475 allout-encrypt-unencrypted-on-saves
6476 (setq bo-subtree
(re-search-forward "$"))
6477 (not (allout-hidden-p))
6478 (>= current-mark
(point))
6479 (allout-end-of-current-subtree)
6480 (<= current-mark
(point))))
6481 (setq editing-topic
(point)
6482 ;; we had to wait for this 'til now so prior topics are
6483 ;; encrypted, any relevant text shifts are in place:
6484 editing-point
(- current-mark-position
6485 (count-trailing-whitespace-region
6486 bo-subtree current-mark-position
))))
6487 (allout-toggle-subtree-encryption)
6488 (if (not was-modified
)
6489 (set-buffer-modified-p nil
))
6491 (if (not was-modified
)
6492 (set-buffer-modified-p nil
))
6493 (if editing-topic
(list editing-topic editing-point
))
6498 ;;;_ #9 miscellaneous
6500 ;;;_ > outlineify-sticky ()
6501 ;; outlinify-sticky is correct spelling; provide this alias for sticklers:
6503 (defalias 'outlinify-sticky
'outlineify-sticky
)
6505 (defun outlineify-sticky (&optional arg
)
6506 "Activate outline mode and establish file var so it is started subsequently.
6508 See doc-string for `allout-layout' and `allout-init' for details on
6509 setup for auto-startup."
6516 (goto-char (point-min))
6517 (if (allout-goto-prefix)
6519 (allout-open-topic 2)
6520 (insert (concat "Dummy outline topic header - see"
6521 "`allout-mode' docstring: `^Hm'."))
6522 (allout-adjust-file-variable
6523 "allout-layout" (or allout-layout
'(-1 : 0))))))
6524 ;;;_ > allout-file-vars-section-data ()
6525 (defun allout-file-vars-section-data ()
6526 "Return data identifying the file-vars section, or nil if none.
6528 Returns list `(beginning-point prefix-string suffix-string)'."
6529 ;; minimally gleaned from emacs 21.4 files.el hack-local-variables function.
6530 (let (beg prefix suffix
)
6532 (goto-char (point-max))
6533 (search-backward "\n\^L" (max (- (point-max) 3000) (point-min)) 'move
)
6534 (if (let ((case-fold-search t
))
6535 (not (search-forward "Local Variables:" nil t
)))
6537 (setq beg
(- (point) 16))
6538 (setq suffix
(buffer-substring-no-properties
6540 (progn (if (search-forward "\n" nil t
)
6543 (setq prefix
(buffer-substring-no-properties
6544 (progn (if (search-backward "\n" nil t
)
6548 (list beg prefix suffix
))
6552 ;;;_ > allout-adjust-file-variable (varname value)
6553 (defun allout-adjust-file-variable (varname value
)
6554 "Adjust the setting of an Emacs file variable named VARNAME to VALUE.
6556 This activity is inhibited if either `enable-local-variables'
6557 `allout-enable-file-variable-adjustment' are nil.
6559 When enabled, an entry for the variable is created if not already present,
6560 or changed if established with a different value. The section for the file
6561 variables, itself, is created if not already present. When created, the
6562 section lines (including the section line) exist as second-level topics in
6563 a top-level topic at the end of the file.
6565 `enable-local-variables' must be true for any of this to happen."
6566 (if (not (and enable-local-variables
6567 allout-enable-file-variable-adjustment
))
6570 (let ((inhibit-field-text-motion t
)
6571 (section-data (allout-file-vars-section-data))
6574 (setq beg
(car section-data
)
6575 prefix
(cadr section-data
)
6576 suffix
(car (cddr section-data
)))
6577 ;; create the section
6578 (goto-char (point-max))
6580 (allout-open-topic 0)
6582 (insert "Local emacs vars.\n")
6583 (allout-open-topic 1)
6586 prefix
(buffer-substring-no-properties (progn
6591 (insert "Local variables:\n")
6592 (allout-open-topic 0)
6595 ;; look for existing entry or create one, leaving point for insertion
6598 (allout-show-to-offshoot)
6599 (if (search-forward (concat "\n" prefix varname
":") nil t
)
6600 (let* ((value-beg (point))
6601 (line-end (progn (if (search-forward "\n" nil t
)
6604 (value-end (- line-end
(length suffix
))))
6605 (if (> value-end value-beg
)
6606 (delete-region value-beg value-end
)))
6610 (insert (concat prefix varname
":")))
6611 (insert (format " %S%s" value suffix
))
6616 ;;;_ > allout-get-configvar-values (varname)
6617 (defun allout-get-configvar-values (configvar-name)
6618 "Return a list of values of the symbols in list bound to CONFIGVAR-NAME.
6620 The user is prompted for removal of symbols that are unbound, and they
6621 otherwise are ignored.
6623 CONFIGVAR-NAME should be the name of the configuration variable,
6626 (let ((configvar-value (symbol-value configvar-name
))
6628 (dolist (sym configvar-value
)
6629 (if (not (boundp sym
))
6630 (if (yes-or-no-p (format "%s entry `%s' is unbound - remove it? "
6631 configvar-name sym
))
6632 (delq sym
(symbol-value configvar-name
)))
6633 (push (symbol-value sym
) got
)))
6636 ;;;_ > allout-mark-topic ()
6637 (defun allout-mark-topic ()
6638 "Put the region around topic currently containing point."
6640 (let ((inhibit-field-text-motion t
))
6641 (beginning-of-line))
6642 (allout-goto-prefix-doublechecked)
6644 (allout-end-of-current-subtree)
6645 (exchange-point-and-mark))
6647 ;;;_ > solicit-char-in-string (prompt string &optional do-defaulting)
6648 (defun solicit-char-in-string (prompt string
&optional do-defaulting
)
6649 "Solicit (with first arg PROMPT) choice of a character from string STRING.
6651 Optional arg DO-DEFAULTING indicates to accept empty input (CR)."
6653 (let ((new-prompt prompt
)
6657 (message "%s" new-prompt
)
6659 ;; We do our own reading here, so we can circumvent, eg, special
6660 ;; treatment for `?' character. (Oughta use minibuffer keymap instead.)
6662 (char-to-string (let ((cursor-in-echo-area nil
)) (read-char))))
6665 (cond ((string-match (regexp-quote got
) string
) got
)
6666 ((and do-defaulting
(string= got
"\r"))
6667 ;; Return empty string to default:
6669 ((string= got
"\C-g") (signal 'quit nil
))
6671 (setq new-prompt
(concat prompt
6677 ;; got something out of loop - return it:
6681 ;;;_ > regexp-sans-escapes (string)
6682 (defun regexp-sans-escapes (regexp &optional successive-backslashes
)
6683 "Return a copy of REGEXP with all character escapes stripped out.
6685 Representations of actual backslashes - '\\\\\\\\' - are left as a
6688 Optional arg SUCCESSIVE-BACKSLASHES is used internally for recursion."
6690 (if (string= regexp
"")
6692 ;; Set successive-backslashes to number if current char is
6693 ;; backslash, or else to nil:
6694 (setq successive-backslashes
6695 (if (= (aref regexp
0) ?
\\)
6696 (if successive-backslashes
(1+ successive-backslashes
) 1)
6698 (if (or (not successive-backslashes
) (= 2 successive-backslashes
))
6699 ;; Include first char:
6700 (concat (substring regexp
0 1)
6701 (regexp-sans-escapes (substring regexp
1)))
6702 ;; Exclude first char, but maintain count:
6703 (regexp-sans-escapes (substring regexp
1) successive-backslashes
))))
6704 ;;;_ > count-trailing-whitespace-region (beg end)
6705 (defun count-trailing-whitespace-region (beg end
)
6706 "Return number of trailing whitespace chars between BEG and END.
6708 If BEG is bigger than END we return 0."
6714 (while (re-search-forward "[ ][ ]*$" end t
)
6715 (goto-char (1+ (match-beginning 2)))
6716 (setq count
(1+ count
)))
6718 ;;;_ > allout-format-quote (string)
6719 (defun allout-format-quote (string)
6720 "Return a copy of string with all \"%\" characters doubled."
6722 (mapcar (lambda (char) (if (= char ?%
) "%%" (char-to-string char
)))
6725 ;;;_ > allout-flatten (list)
6726 (defun allout-flatten (list)
6727 "Return a list of all atoms in list."
6729 (cond ((null list
) nil
)
6730 ((atom (car list
)) (cons (car list
) (allout-flatten (cdr list
))))
6731 (t (append (allout-flatten (car list
)) (allout-flatten (cdr list
))))))
6732 ;;;_ : Compatability:
6733 ;;;_ > allout-mark-marker to accommodate divergent emacsen:
6734 (defun allout-mark-marker (&optional force buffer
)
6735 "Accommodate the different signature for `mark-marker' across Emacsen.
6737 XEmacs takes two optional args, while mainline GNU Emacs does not,
6738 so pass them along when appropriate."
6739 (if (featurep 'xemacs
)
6740 (apply 'mark-marker force buffer
)
6742 ;;;_ > subst-char-in-string if necessary
6743 (if (not (fboundp 'subst-char-in-string
))
6744 (defun subst-char-in-string (fromchar tochar string
&optional inplace
)
6745 "Replace FROMCHAR with TOCHAR in STRING each time it occurs.
6746 Unless optional argument INPLACE is non-nil, return a new string."
6747 (let ((i (length string
))
6748 (newstr (if inplace string
(copy-sequence string
))))
6751 (if (eq (aref newstr i
) fromchar
)
6752 (aset newstr i tochar
)))
6754 ;;;_ > wholenump if necessary
6755 (if (not (fboundp 'wholenump
))
6756 (defalias 'wholenump
'natnump
))
6757 ;;;_ > remove-overlays if necessary
6758 (if (not (fboundp 'remove-overlays
))
6759 (defun remove-overlays (&optional beg end name val
)
6760 "Clear BEG and END of overlays whose property NAME has value VAL.
6761 Overlays might be moved and/or split.
6762 BEG and END default respectively to the beginning and end of buffer."
6763 (unless beg
(setq beg
(point-min)))
6764 (unless end
(setq end
(point-max)))
6766 (setq beg
(prog1 end
(setq end beg
))))
6768 (dolist (o (overlays-in beg end
))
6769 (when (eq (overlay-get o name
) val
)
6770 ;; Either push this overlay outside beg...end
6771 ;; or split it to exclude beg...end
6772 ;; or delete it entirely (if it is contained in beg...end).
6773 (if (< (overlay-start o
) beg
)
6774 (if (> (overlay-end o
) end
)
6776 (move-overlay (copy-overlay o
)
6777 (overlay-start o
) beg
)
6778 (move-overlay o end
(overlay-end o
)))
6779 (move-overlay o
(overlay-start o
) beg
))
6780 (if (> (overlay-end o
) end
)
6781 (move-overlay o end
(overlay-end o
))
6782 (delete-overlay o
)))))))
6784 ;;;_ > copy-overlay if necessary - xemacs ~ 21.4
6785 (if (not (fboundp 'copy-overlay
))
6786 (defun copy-overlay (o)
6787 "Return a copy of overlay O."
6788 (let ((o1 (make-overlay (overlay-start o
) (overlay-end o
)
6789 ;; FIXME: there's no easy way to find the
6790 ;; insertion-type of the two markers.
6791 (overlay-buffer o
)))
6792 (props (overlay-properties o
)))
6794 (overlay-put o1
(pop props
) (pop props
)))
6796 ;;;_ > add-to-invisibility-spec if necessary - xemacs ~ 21.4
6797 (if (not (fboundp 'add-to-invisibility-spec
))
6798 (defun add-to-invisibility-spec (element)
6799 "Add ELEMENT to `buffer-invisibility-spec'.
6800 See documentation for `buffer-invisibility-spec' for the kind of elements
6802 (if (eq buffer-invisibility-spec t
)
6803 (setq buffer-invisibility-spec
(list t
)))
6804 (setq buffer-invisibility-spec
6805 (cons element buffer-invisibility-spec
))))
6806 ;;;_ > remove-from-invisibility-spec if necessary - xemacs ~ 21.4
6807 (if (not (fboundp 'remove-from-invisibility-spec
))
6808 (defun remove-from-invisibility-spec (element)
6809 "Remove ELEMENT from `buffer-invisibility-spec'."
6810 (if (consp buffer-invisibility-spec
)
6811 (setq buffer-invisibility-spec
(delete element
6812 buffer-invisibility-spec
)))))
6813 ;;;_ > move-beginning-of-line if necessary - older emacs, xemacs
6814 (if (not (fboundp 'move-beginning-of-line
))
6815 (defun move-beginning-of-line (arg)
6816 "Move point to beginning of current line as displayed.
6817 \(This disregards invisible newlines such as those
6818 which are part of the text that an image rests on.)
6820 With argument ARG not nil or 1, move forward ARG - 1 lines first.
6821 If point reaches the beginning or end of buffer, it stops there.
6822 To ignore intangibility, bind `inhibit-point-motion-hooks' to t."
6824 (or arg
(setq arg
1))
6826 (condition-case nil
(line-move (1- arg
)) (error nil
)))
6828 ;; Move to beginning-of-line, ignoring fields and invisibles.
6829 (skip-chars-backward "^\n")
6830 (while (and (not (bobp)) (line-move-invisible-p (1- (point))))
6831 (goto-char (if (featurep 'xemacs
)
6832 (previous-property-change (point))
6833 (previous-char-property-change (point))))
6834 (skip-chars-backward "^\n"))
6835 (vertical-motion 0))
6837 ;;;_ > move-end-of-line if necessary - older emacs, xemacs
6838 (if (not (fboundp 'move-end-of-line
))
6839 (defun move-end-of-line (arg)
6840 "Move point to end of current line as displayed.
6841 \(This disregards invisible newlines such as those
6842 which are part of the text that an image rests on.)
6844 With argument ARG not nil or 1, move forward ARG - 1 lines first.
6845 If point reaches the beginning or end of buffer, it stops there.
6846 To ignore intangibility, bind `inhibit-point-motion-hooks' to t."
6848 (or arg
(setq arg
1))
6853 (let ((goal-column 0))
6854 (and (condition-case nil
6855 (or (line-move arg
) t
)
6859 (while (and (not (bobp))
6860 (line-move-invisible-p (1- (point))))
6862 (previous-char-property-change (point))))
6866 (if (and (> (point) newpos
)
6867 (eq (preceding-char) ?
\n))
6869 (if (and (> (point) newpos
) (not (eobp))
6870 (not (eq (following-char) ?
\n)))
6871 ;; If we skipped something intangible
6872 ;; and now we're not really at eol,
6877 ;;;_ > line-move-invisible-p if necessary
6878 (if (not (fboundp 'line-move-invisible-p
))
6879 (defun line-move-invisible-p (pos)
6880 "Return non-nil if the character after POS is currently invisible."
6882 (get-char-property pos
'invisible
)))
6883 (if (eq buffer-invisibility-spec t
)
6885 (or (memq prop buffer-invisibility-spec
)
6886 (assq prop buffer-invisibility-spec
))))))
6889 ;;;_ > allout-bullet-isearch (&optional bullet)
6890 (defun allout-bullet-isearch (&optional bullet
)
6891 "Isearch (regexp) for topic with bullet BULLET."
6894 (setq bullet
(solicit-char-in-string
6895 "ISearch for topic with bullet: "
6896 (regexp-sans-escapes allout-bullets-string
))))
6898 (let ((isearch-regexp t
)
6899 (isearch-string (concat "^"
6900 allout-header-prefix
6903 (isearch-repeat 'forward
)
6906 ;;;_ #11 Unit tests - this should be last item before "Provide"
6907 ;;;_ > allout-run-unit-tests ()
6908 (defun allout-run-unit-tests ()
6909 "Run the various allout unit tests."
6910 (message "Running allout tests...")
6911 (allout-test-resumptions)
6912 (message "Running allout tests... Done.")
6914 ;;;_ : test resumptions:
6915 ;;;_ > allout-tests-obliterate-variable (name)
6916 (defun allout-tests-obliterate-variable (name)
6917 "Completely unbind variable with NAME."
6918 (if (local-variable-p name
) (kill-local-variable name
))
6919 (while (boundp name
) (makunbound name
)))
6920 ;;;_ > allout-test-resumptions ()
6921 (defvar allout-tests-globally-unbound nil
6922 "Fodder for allout resumptions tests - defvar just for byte compiler.")
6923 (defvar allout-tests-globally-true nil
6924 "Fodder for allout resumptions tests - defvar just just for byte compiler.")
6925 (defvar allout-tests-locally-true nil
6926 "Fodder for allout resumptions tests - defvar just for byte compiler.")
6927 (defun allout-test-resumptions ()
6928 "Exercise allout resumptions."
6929 ;; for each resumption case, we also test that the right local/global
6930 ;; scopes are affected during resumption effects:
6932 ;; ensure that previously unbound variables return to the unbound state.
6934 (allout-tests-obliterate-variable 'allout-tests-globally-unbound
)
6935 (allout-add-resumptions '(allout-tests-globally-unbound t
))
6936 (assert (not (default-boundp 'allout-tests-globally-unbound
)))
6937 (assert (local-variable-p 'allout-tests-globally-unbound
))
6938 (assert (boundp 'allout-tests-globally-unbound
))
6939 (assert (equal allout-tests-globally-unbound t
))
6940 (allout-do-resumptions)
6941 (assert (not (local-variable-p 'allout-tests-globally-unbound
)))
6942 (assert (not (boundp 'allout-tests-globally-unbound
))))
6944 ;; ensure that variable with prior global value is resumed
6946 (allout-tests-obliterate-variable 'allout-tests-globally-true
)
6947 (setq allout-tests-globally-true t
)
6948 (allout-add-resumptions '(allout-tests-globally-true nil
))
6949 (assert (equal (default-value 'allout-tests-globally-true
) t
))
6950 (assert (local-variable-p 'allout-tests-globally-true
))
6951 (assert (equal allout-tests-globally-true nil
))
6952 (allout-do-resumptions)
6953 (assert (not (local-variable-p 'allout-tests-globally-true
)))
6954 (assert (boundp 'allout-tests-globally-true
))
6955 (assert (equal allout-tests-globally-true t
)))
6957 ;; ensure that prior local value is resumed
6959 (allout-tests-obliterate-variable 'allout-tests-locally-true
)
6960 (set (make-local-variable 'allout-tests-locally-true
) t
)
6961 (assert (not (default-boundp 'allout-tests-locally-true
))
6962 nil
(concat "Test setup mistake - variable supposed to"
6963 " not have global binding, but it does."))
6964 (assert (local-variable-p 'allout-tests-locally-true
)
6965 nil
(concat "Test setup mistake - variable supposed to have"
6966 " local binding, but it lacks one."))
6967 (allout-add-resumptions '(allout-tests-locally-true nil
))
6968 (assert (not (default-boundp 'allout-tests-locally-true
)))
6969 (assert (local-variable-p 'allout-tests-locally-true
))
6970 (assert (equal allout-tests-locally-true nil
))
6971 (allout-do-resumptions)
6972 (assert (boundp 'allout-tests-locally-true
))
6973 (assert (local-variable-p 'allout-tests-locally-true
))
6974 (assert (equal allout-tests-locally-true t
))
6975 (assert (not (default-boundp 'allout-tests-locally-true
))))
6977 ;; ensure that last of multiple resumptions holds, for various scopes.
6979 (allout-tests-obliterate-variable 'allout-tests-globally-unbound
)
6980 (allout-tests-obliterate-variable 'allout-tests-globally-true
)
6981 (setq allout-tests-globally-true t
)
6982 (allout-tests-obliterate-variable 'allout-tests-locally-true
)
6983 (set (make-local-variable 'allout-tests-locally-true
) t
)
6984 (allout-add-resumptions '(allout-tests-globally-unbound t
)
6985 '(allout-tests-globally-true nil
)
6986 '(allout-tests-locally-true nil
))
6987 (allout-add-resumptions '(allout-tests-globally-unbound 2)
6988 '(allout-tests-globally-true 3)
6989 '(allout-tests-locally-true 4))
6990 ;; reestablish many of the basic conditions are maintained after re-add:
6991 (assert (not (default-boundp 'allout-tests-globally-unbound
)))
6992 (assert (local-variable-p 'allout-tests-globally-unbound
))
6993 (assert (equal allout-tests-globally-unbound
2))
6994 (assert (default-boundp 'allout-tests-globally-true
))
6995 (assert (local-variable-p 'allout-tests-globally-true
))
6996 (assert (equal allout-tests-globally-true
3))
6997 (assert (not (default-boundp 'allout-tests-locally-true
)))
6998 (assert (local-variable-p 'allout-tests-locally-true
))
6999 (assert (equal allout-tests-locally-true
4))
7000 (allout-do-resumptions)
7001 (assert (not (local-variable-p 'allout-tests-globally-unbound
)))
7002 (assert (not (boundp 'allout-tests-globally-unbound
)))
7003 (assert (not (local-variable-p 'allout-tests-globally-true
)))
7004 (assert (boundp 'allout-tests-globally-true
))
7005 (assert (equal allout-tests-globally-true t
))
7006 (assert (boundp 'allout-tests-locally-true
))
7007 (assert (local-variable-p 'allout-tests-locally-true
))
7008 (assert (equal allout-tests-locally-true t
))
7009 (assert (not (default-boundp 'allout-tests-locally-true
))))
7011 ;; ensure that deliberately unbinding registered variables doesn't foul things
7013 (allout-tests-obliterate-variable 'allout-tests-globally-unbound
)
7014 (allout-tests-obliterate-variable 'allout-tests-globally-true
)
7015 (setq allout-tests-globally-true t
)
7016 (allout-tests-obliterate-variable 'allout-tests-locally-true
)
7017 (set (make-local-variable 'allout-tests-locally-true
) t
)
7018 (allout-add-resumptions '(allout-tests-globally-unbound t
)
7019 '(allout-tests-globally-true nil
)
7020 '(allout-tests-locally-true nil
))
7021 (allout-tests-obliterate-variable 'allout-tests-globally-unbound
)
7022 (allout-tests-obliterate-variable 'allout-tests-globally-true
)
7023 (allout-tests-obliterate-variable 'allout-tests-locally-true
)
7024 (allout-do-resumptions))
7026 ;;;_ % Run unit tests if `allout-run-unit-tests-after-load' is true:
7027 (when allout-run-unit-tests-on-load
7028 (allout-run-unit-tests))
7033 ;;;_* Local emacs vars.
7034 ;; The following `allout-layout' local variable setting:
7035 ;; - closes all topics from the first topic to just before the third-to-last,
7036 ;; - shows the children of the third to last (config vars)
7037 ;; - and the second to last (code section),
7038 ;; - and closes the last topic (this local-variables section).
7040 ;;allout-layout: (0 : -1 -1 0)
7043 ;; arch-tag: cf38fbc3-c044-450f-8bff-afed8ba5681c
7044 ;;; allout.el ends here