]> code.delx.au - gnu-emacs/blob - lisp/allout.el
cf7b922eea6b9133c1cf52d925afcee1bfdf5fe6
[gnu-emacs] / lisp / allout.el
1 ;;; allout.el --- extensive outline mode for use alone and with other modes
2
3 ;; Copyright (C) 1992, 1993, 1994, 2001, 2002, 2003, 2004,
4 ;; 2005, 2006 Free Software Foundation, Inc.
5
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
9 ;; Version: 2.2.1
10 ;; Keywords: outlines wp languages
11
12 ;; This file is part of GNU Emacs.
13
14 ;; GNU Emacs is free software; you can redistribute it and/or modify
15 ;; it under the terms of the GNU General Public License as published by
16 ;; the Free Software Foundation; either version 2, or (at your option)
17 ;; any later version.
18
19 ;; GNU Emacs is distributed in the hope that it will be useful,
20 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
22 ;; GNU General Public License for more details.
23
24 ;; You should have received a copy of the GNU General Public License
25 ;; along with GNU Emacs; see the file COPYING. If not, write to the
26 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
27 ;; Boston, MA 02110-1301, USA.
28
29 ;;; Commentary:
30
31 ;; Allout outline minor mode provides extensive outline formatting and
32 ;; and manipulation beyond standard emacs outline mode. Some features:
33 ;;
34 ;; - Classic outline-mode topic-oriented navigation and exposure adjustment
35 ;; - Topic-oriented editing including coherent topic and subtopic
36 ;; creation, promotion, demotion, cut/paste across depths, etc.
37 ;; - Incremental search with dynamic exposure and reconcealment of text
38 ;; - Customizable bullet format - enables programming-language specific
39 ;; outlining, for code-folding editing. (Allout code itself is to try it;
40 ;; formatted as an outline - do ESC-x eval-current-buffer in allout.el; but
41 ;; emacs local file variables need to be enabled when the
42 ;; file was visited - see `enable-local-variables'.)
43 ;; - Configurable per-file initial exposure settings
44 ;; - Symmetric-key and key-pair topic encryption, plus symmetric passphrase
45 ;; mnemonic support, with verification against an established passphrase
46 ;; (using a stashed encrypted dummy string) and user-supplied hint
47 ;; maintenance. (See allout-toggle-current-subtree-encryption docstring.)
48 ;; - Automatic topic-number maintenance
49 ;; - "Hot-spot" operation, for single-keystroke maneuvering and
50 ;; exposure control (see the allout-mode docstring)
51 ;; - Easy rendering of exposed portions into numbered, latex, indented, etc
52 ;; outline styles
53 ;; - Careful attention to whitespace - enabling blank lines between items
54 ;; and maintenance of hanging indentation (in paragraph auto-fill and
55 ;; across topic promotion and demotion) of topic bodies consistent with
56 ;; indentation of their topic header.
57 ;;
58 ;; and more.
59 ;;
60 ;; See the `allout-mode' function's docstring for an introduction to the
61 ;; mode. The development version and helpful notes are available at
62 ;; http://myriadicity.net/Sundry/EmacsAllout .
63 ;;
64 ;; The outline menubar additions provide quick reference to many of
65 ;; the features, and see the docstring of the variable `allout-init'
66 ;; for instructions on priming your emacs session for automatic
67 ;; activation of allout-mode.
68 ;;
69 ;; See the docstring of the variables `allout-layout' and
70 ;; `allout-auto-activation' for details on automatic activation of
71 ;; `allout-mode' as a minor mode. (It has changed since allout
72 ;; 3.x, for those of you that depend on the old method.)
73 ;;
74 ;; Note - the lines beginning with `;;;_' are outline topic headers.
75 ;; Just `ESC-x eval-current-buffer' to give it a whirl.
76
77 ;; ken manheimer (ken dot manheimer at gmail dot com)
78
79 ;;; Code:
80
81 ;;;_* Dependency autoloads
82 (require 'overlay)
83 (eval-when-compile (progn (require 'pgg)
84 (require 'pgg-gpg)
85 (require 'overlay)
86 ))
87 (autoload 'pgg-gpg-symmetric-key-p "pgg-gpg"
88 "True if decoded armor MESSAGE-KEYS has symmetric encryption indicator.")
89
90 ;;;_* USER CUSTOMIZATION VARIABLES:
91
92 ;;;_ > defgroup allout
93 (defgroup allout nil
94 "Extensive outline mode for use alone and with other modes."
95 :prefix "allout-"
96 :group 'outlines)
97
98 ;;;_ + Layout, Mode, and Topic Header Configuration
99
100 ;;;_ = allout-auto-activation
101 (defcustom allout-auto-activation nil
102 "*Regulates auto-activation modality of allout outlines - see `allout-init'.
103
104 Setq-default by `allout-init' to regulate whether or not allout
105 outline mode is automatically activated when the buffer-specific
106 variable `allout-layout' is non-nil, and whether or not the layout
107 dictated by `allout-layout' should be imposed on mode activation.
108
109 With value t, auto-mode-activation and auto-layout are enabled.
110 \(This also depends on `allout-find-file-hook' being installed in
111 `find-file-hook', which is also done by `allout-init'.)
112
113 With value `ask', auto-mode-activation is enabled, and endorsement for
114 performing auto-layout is asked of the user each time.
115
116 With value `activate', only auto-mode-activation is enabled,
117 auto-layout is not.
118
119 With value nil, neither auto-mode-activation nor auto-layout are
120 enabled.
121
122 See the docstring for `allout-init' for the proper interface to
123 this variable."
124 :type '(choice (const :tag "On" t)
125 (const :tag "Ask about layout" "ask")
126 (const :tag "Mode only" "activate")
127 (const :tag "Off" nil))
128 :group 'allout)
129 ;;;_ = allout-default-layout
130 (defcustom allout-default-layout '(-2 : 0)
131 "*Default allout outline layout specification.
132
133 This setting specifies the outline exposure to use when
134 `allout-layout' has the local value `t'. This docstring describes the
135 layout specifications.
136
137 A list value specifies a default layout for the current buffer,
138 to be applied upon activation of `allout-mode'. Any non-nil
139 value will automatically trigger `allout-mode', provided
140 `allout-init' has been called to enable this behavior.
141
142 The types of elements in the layout specification are:
143
144 integer - dictate the relative depth to open the corresponding topic(s),
145 where:
146 - negative numbers force the topic to be closed before opening
147 to the absolute value of the number, so all siblings are open
148 only to that level.
149 - positive numbers open to the relative depth indicated by the
150 number, but do not force already opened subtopics to be closed.
151 - 0 means to close topic - hide all subitems.
152 : - repeat spec - apply the preceeding element to all siblings at
153 current level, *up to* those siblings that would be covered by specs
154 following the `:' on the list. Ie, apply to all topics at level but
155 trailing ones accounted for by trailing specs. \(Only the first of
156 multiple colons at the same level is honored - later ones are ignored.)
157 * - completely exposes the topic, including bodies
158 + - exposes all subtopics, but not the bodies
159 - - exposes the body of the corresponding topic, but not subtopics
160 list - a nested layout spec, to be applied intricately to its
161 corresponding item(s)
162
163 Examples:
164 '(-2 : 0)
165 Collapse the top-level topics to show their children and
166 grandchildren, but completely collapse the final top-level topic.
167 '(-1 () : 1 0)
168 Close the first topic so only the immediate subtopics are shown,
169 leave the subsequent topics exposed as they are until the second
170 second to last topic, which is exposed at least one level, and
171 completely close the last topic.
172 '(-2 : -1 *)
173 Expose children and grandchildren of all topics at current
174 level except the last two; expose children of the second to
175 last and completely expose the last one, including its subtopics.
176
177 See `allout-expose-topic' for more about the exposure process.
178
179 Also, allout's mode-specific provisions will make topic prefixes default
180 to the comment-start string, if any, of the language of the file. This
181 is modulo the setting of `allout-use-mode-specific-leader', which see."
182 :type 'allout-layout-type
183 :group 'allout)
184 ;;;_ : allout-layout-type
185 (define-widget 'allout-layout-type 'lazy
186 "Allout layout format customization basic building blocks."
187 :type '(repeat
188 (choice (integer :tag "integer (<= zero is strict)")
189 (const :tag ": (repeat prior)" :)
190 (const :tag "* (completely expose)" *)
191 (const :tag "+ (expose all offspring, headlines only)" +)
192 (const :tag "- (expose topic body but not offspring)" -)
193 (allout-layout-type :tag "<Nested layout>"))))
194
195 ;;;_ = allout-show-bodies
196 (defcustom allout-show-bodies nil
197 "*If non-nil, show entire body when exposing a topic, rather than
198 just the header."
199 :type 'boolean
200 :group 'allout)
201 (make-variable-buffer-local 'allout-show-bodies)
202
203 ;;;_ = allout-header-prefix
204 (defcustom allout-header-prefix "."
205 "*Leading string which helps distinguish topic headers.
206
207 Outline topic header lines are identified by a leading topic
208 header prefix, which mostly have the value of this var at their front.
209 \(Level 1 topics are exceptions. They consist of only a single
210 character, which is typically set to the `allout-primary-bullet'. Many
211 outlines start at level 2 to avoid this discrepancy."
212 :type 'string
213 :group 'allout)
214 (make-variable-buffer-local 'allout-header-prefix)
215 ;;;_ = allout-primary-bullet
216 (defcustom allout-primary-bullet "*"
217 "Bullet used for top-level outline topics.
218
219 Outline topic header lines are identified by a leading topic header
220 prefix, which is concluded by bullets that includes the value of this
221 var and the respective allout-*-bullets-string vars.
222
223 The value of an asterisk (`*') provides for backwards compatibility
224 with the original Emacs outline mode. See `allout-plain-bullets-string'
225 and `allout-distinctive-bullets-string' for the range of available
226 bullets."
227 :type 'string
228 :group 'allout)
229 (make-variable-buffer-local 'allout-primary-bullet)
230 ;;;_ = allout-plain-bullets-string
231 (defcustom allout-plain-bullets-string ".,"
232 "*The bullets normally used in outline topic prefixes.
233
234 See `allout-distinctive-bullets-string' for the other kind of
235 bullets.
236
237 DO NOT include the close-square-bracket, `]', as a bullet.
238
239 Outline mode has to be reactivated in order for changes to the value
240 of this var to take effect."
241 :type 'string
242 :group 'allout)
243 (make-variable-buffer-local 'allout-plain-bullets-string)
244 ;;;_ = allout-distinctive-bullets-string
245 (defcustom allout-distinctive-bullets-string "*+-=>()[{}&!?#%\"X@$~_\\:;^"
246 "*Persistent outline header bullets used to distinguish special topics.
247
248 These bullets are used to distinguish topics from the run-of-the-mill
249 ones. They are not used in the standard topic headers created by
250 the topic-opening, shifting, and rebulleting \(eg, on topic shift,
251 topic paste, blanket rebulleting) routines, but are offered among the
252 choices for rebulleting. They are not altered by the above automatic
253 rebulleting, so they can be used to characterize topics, eg:
254
255 `?' question topics
256 `\(' parenthetic comment \(with a matching close paren inside)
257 `[' meta-note \(with a matching close ] inside)
258 `\"' a quotation
259 `=' value settings
260 `~' \"more or less\"
261 `^' see above
262
263 ... for example. (`#' typically has a special meaning to the software,
264 according to the value of `allout-numbered-bullet'.)
265
266 See `allout-plain-bullets-string' for the selection of
267 alternating bullets.
268
269 You must run `set-allout-regexp' in order for outline mode to
270 reconcile to changes of this value.
271
272 DO NOT include the close-square-bracket, `]', on either of the bullet
273 strings."
274 :type 'string
275 :group 'allout)
276 (make-variable-buffer-local 'allout-distinctive-bullets-string)
277
278 ;;;_ = allout-use-mode-specific-leader
279 (defcustom allout-use-mode-specific-leader t
280 "*When non-nil, use mode-specific topic-header prefixes.
281
282 Allout outline mode will use the mode-specific `allout-mode-leaders'
283 and/or comment-start string, if any, to lead the topic prefix string,
284 so topic headers look like comments in the programming language.
285
286 String values are used as they stand.
287
288 Value t means to first check for assoc value in `allout-mode-leaders'
289 alist, then use comment-start string, if any, then use default \(`.').
290 \(See note about use of comment-start strings, below.)
291
292 Set to the symbol for either of `allout-mode-leaders' or
293 `comment-start' to use only one of them, respectively.
294
295 Value nil means to always use the default \(`.').
296
297 comment-start strings that do not end in spaces are tripled, and an
298 `_' underscore is tacked on the end, to distinguish them from regular
299 comment strings. comment-start strings that do end in spaces are not
300 tripled, but an underscore is substituted for the space. [This
301 presumes that the space is for appearance, not comment syntax. You
302 can use `allout-mode-leaders' to override this behavior, when
303 incorrect.]"
304 :type '(choice (const t) (const nil) string
305 (const allout-mode-leaders)
306 (const comment-start))
307 :group 'allout)
308 ;;;_ = allout-mode-leaders
309 (defvar allout-mode-leaders '()
310 "Specific allout-prefix leading strings per major modes.
311
312 Entries will be used instead or in lieu of mode-specific
313 comment-start strings. See also `allout-use-mode-specific-leader'.
314
315 If you're constructing a string that will comment-out outline
316 structuring so it can be included in program code, append an extra
317 character, like an \"_\" underscore, to distinguish the lead string
318 from regular comments that start at bol.")
319
320 ;;;_ = allout-old-style-prefixes
321 (defcustom allout-old-style-prefixes nil
322 "*When non-nil, use only old-and-crusty `outline-mode' `*' topic prefixes.
323
324 Non-nil restricts the topic creation and modification
325 functions to asterix-padded prefixes, so they look exactly
326 like the original Emacs-outline style prefixes.
327
328 Whatever the setting of this variable, both old and new style prefixes
329 are always respected by the topic maneuvering functions."
330 :type 'boolean
331 :group 'allout)
332 (make-variable-buffer-local 'allout-old-style-prefixes)
333 ;;;_ = allout-stylish-prefixes - alternating bullets
334 (defcustom allout-stylish-prefixes t
335 "*Do fancy stuff with topic prefix bullets according to level, etc.
336
337 Non-nil enables topic creation, modification, and repositioning
338 functions to vary the topic bullet char (the char that marks the topic
339 depth) just preceding the start of the topic text) according to level.
340 Otherwise, only asterisks (`*') and distinctive bullets are used.
341
342 This is how an outline can look (but sans indentation) with stylish
343 prefixes:
344
345 * Top level
346 .* A topic
347 . + One level 3 subtopic
348 . . One level 4 subtopic
349 . . A second 4 subtopic
350 . + Another level 3 subtopic
351 . #1 A numbered level 4 subtopic
352 . #2 Another
353 . ! Another level 4 subtopic with a different distinctive bullet
354 . #4 And another numbered level 4 subtopic
355
356 This would be an outline with stylish prefixes inhibited (but the
357 numbered and other distinctive bullets retained):
358
359 * Top level
360 .* A topic
361 . * One level 3 subtopic
362 . * One level 4 subtopic
363 . * A second 4 subtopic
364 . * Another level 3 subtopic
365 . #1 A numbered level 4 subtopic
366 . #2 Another
367 . ! Another level 4 subtopic with a different distinctive bullet
368 . #4 And another numbered level 4 subtopic
369
370 Stylish and constant prefixes (as well as old-style prefixes) are
371 always respected by the topic maneuvering functions, regardless of
372 this variable setting.
373
374 The setting of this var is not relevant when `allout-old-style-prefixes'
375 is non-nil."
376 :type 'boolean
377 :group 'allout)
378 (make-variable-buffer-local 'allout-stylish-prefixes)
379
380 ;;;_ = allout-numbered-bullet
381 (defcustom allout-numbered-bullet "#"
382 "*String designating bullet of topics that have auto-numbering; nil for none.
383
384 Topics having this bullet have automatic maintenance of a sibling
385 sequence-number tacked on, just after the bullet. Conventionally set
386 to \"#\", you can set it to a bullet of your choice. A nil value
387 disables numbering maintenance."
388 :type '(choice (const nil) string)
389 :group 'allout)
390 (make-variable-buffer-local 'allout-numbered-bullet)
391 ;;;_ = allout-file-xref-bullet
392 (defcustom allout-file-xref-bullet "@"
393 "*Bullet signifying file cross-references, for `allout-resolve-xref'.
394
395 Set this var to the bullet you want to use for file cross-references."
396 :type '(choice (const nil) string)
397 :group 'allout)
398 ;;;_ = allout-presentation-padding
399 (defcustom allout-presentation-padding 2
400 "*Presentation-format white-space padding factor, for greater indent."
401 :type 'integer
402 :group 'allout)
403
404 (make-variable-buffer-local 'allout-presentation-padding)
405
406 ;;;_ = allout-abbreviate-flattened-numbering
407 (defcustom allout-abbreviate-flattened-numbering nil
408 "*If non-nil, `allout-flatten-exposed-to-buffer' abbreviates topic
409 numbers to minimal amount with some context. Otherwise, entire
410 numbers are always used."
411 :type 'boolean
412 :group 'allout)
413
414 ;;;_ + LaTeX formatting
415 ;;;_ - allout-number-pages
416 (defcustom allout-number-pages nil
417 "*Non-nil turns on page numbering for LaTeX formatting of an outline."
418 :type 'boolean
419 :group 'allout)
420 ;;;_ - allout-label-style
421 (defcustom allout-label-style "\\large\\bf"
422 "*Font and size of labels for LaTeX formatting of an outline."
423 :type 'string
424 :group 'allout)
425 ;;;_ - allout-head-line-style
426 (defcustom allout-head-line-style "\\large\\sl "
427 "*Font and size of entries for LaTeX formatting of an outline."
428 :type 'string
429 :group 'allout)
430 ;;;_ - allout-body-line-style
431 (defcustom allout-body-line-style " "
432 "*Font and size of entries for LaTeX formatting of an outline."
433 :type 'string
434 :group 'allout)
435 ;;;_ - allout-title-style
436 (defcustom allout-title-style "\\Large\\bf"
437 "*Font and size of titles for LaTeX formatting of an outline."
438 :type 'string
439 :group 'allout)
440 ;;;_ - allout-title
441 (defcustom allout-title '(or buffer-file-name (buffer-name))
442 "*Expression to be evaluated to determine the title for LaTeX
443 formatted copy."
444 :type 'sexp
445 :group 'allout)
446 ;;;_ - allout-line-skip
447 (defcustom allout-line-skip ".05cm"
448 "*Space between lines for LaTeX formatting of an outline."
449 :type 'string
450 :group 'allout)
451 ;;;_ - allout-indent
452 (defcustom allout-indent ".3cm"
453 "*LaTeX formatted depth-indent spacing."
454 :type 'string
455 :group 'allout)
456
457 ;;;_ + Topic encryption
458 ;;;_ = allout-topic-encryption-bullet
459 (defcustom allout-topic-encryption-bullet "~"
460 "*Bullet signifying encryption of the entry's body."
461 :type '(choice (const nil) string)
462 :group 'allout)
463 ;;;_ = allout-passphrase-verifier-handling
464 (defcustom allout-passphrase-verifier-handling t
465 "*Enable use of symmetric encryption passphrase verifier if non-nil.
466
467 See the docstring for the `allout-enable-file-variable-adjustment'
468 variable for details about allout ajustment of file variables."
469 :type 'boolean
470 :group 'allout)
471 (make-variable-buffer-local 'allout-passphrase-verifier-handling)
472 ;;;_ = allout-passphrase-hint-handling
473 (defcustom allout-passphrase-hint-handling 'always
474 "*Dictate outline encryption passphrase reminder handling:
475
476 always - always show reminder when prompting
477 needed - show reminder on passphrase entry failure
478 disabled - never present or adjust reminder
479
480 See the docstring for the `allout-enable-file-variable-adjustment'
481 variable for details about allout ajustment of file variables."
482 :type '(choice (const always)
483 (const needed)
484 (const disabled))
485 :group 'allout)
486 (make-variable-buffer-local 'allout-passphrase-hint-handling)
487 ;;;_ = allout-encrypt-unencrypted-on-saves
488 (defcustom allout-encrypt-unencrypted-on-saves t
489 "*When saving, should topics pending encryption be encrypted?
490
491 The idea is to prevent file-system exposure of any un-encrypted stuff, and
492 mostly covers both deliberate file writes and auto-saves.
493
494 - Yes: encrypt all topics pending encryption, even if it's the one
495 currently being edited. \(In that case, the currently edited topic
496 will be automatically decrypted before any user interaction, so they
497 can continue editing but the copy on the file system will be
498 encrypted.)
499 Auto-saves will use the \"All except current topic\" mode if this
500 one is selected, to avoid practical difficulties - see below.
501 - All except current topic: skip the topic currently being edited, even if
502 it's pending encryption. This may expose the current topic on the
503 file sytem, but avoids the nuisance of prompts for the encryption
504 passphrase in the middle of editing for, eg, autosaves.
505 This mode is used for auto-saves for both this option and \"Yes\".
506 - No: leave it to the user to encrypt any unencrypted topics.
507
508 For practical reasons, auto-saves always use the 'except-current policy
509 when auto-encryption is enabled. \(Otherwise, spurious passphrase prompts
510 and unavoidable timing collisions are too disruptive.) If security for a
511 file requires that even the current topic is never auto-saved in the clear,
512 disable auto-saves for that file."
513
514 :type '(choice (const :tag "Yes" t)
515 (const :tag "All except current topic" except-current)
516 (const :tag "No" nil))
517 :group 'allout)
518 (make-variable-buffer-local 'allout-encrypt-unencrypted-on-saves)
519
520 ;;;_ + Miscellaneous customization
521
522 ;;;_ = allout-command-prefix
523 (defcustom allout-command-prefix "\C-c "
524 "*Key sequence to be used as prefix for outline mode command key bindings.
525
526 Default is '\C-c<space>'; just '\C-c' is more short-and-sweet, if you're
527 willing to let allout use a bunch of \C-c keybindings."
528 :type 'string
529 :group 'allout)
530
531 ;;;_ = allout-keybindings-list
532 ;;; You have to reactivate allout-mode - `(allout-mode t)' - to
533 ;;; institute changes to this var.
534 (defvar allout-keybindings-list ()
535 "*List of `allout-mode' key / function bindings, for `allout-mode-map'.
536
537 String or vector key will be prefaced with `allout-command-prefix',
538 unless optional third, non-nil element is present.")
539 (setq allout-keybindings-list
540 '(
541 ; Motion commands:
542 ("\C-n" allout-next-visible-heading)
543 ("\C-p" allout-previous-visible-heading)
544 ("\C-u" allout-up-current-level)
545 ("\C-f" allout-forward-current-level)
546 ("\C-b" allout-backward-current-level)
547 ("\C-a" allout-beginning-of-current-entry)
548 ("\C-e" allout-end-of-entry)
549 ; Exposure commands:
550 ("\C-i" allout-show-children)
551 ("\C-s" allout-show-current-subtree)
552 ("\C-h" allout-hide-current-subtree)
553 ("h" allout-hide-current-subtree)
554 ("\C-o" allout-show-current-entry)
555 ("!" allout-show-all)
556 ("x" allout-toggle-current-subtree-encryption)
557 ; Alteration commands:
558 (" " allout-open-sibtopic)
559 ("." allout-open-subtopic)
560 ("," allout-open-supertopic)
561 ("'" allout-shift-in)
562 (">" allout-shift-in)
563 ("<" allout-shift-out)
564 ("\C-m" allout-rebullet-topic)
565 ("*" allout-rebullet-current-heading)
566 ("#" allout-number-siblings)
567 ("\C-k" allout-kill-line t)
568 ("\C-y" allout-yank t)
569 ("\M-y" allout-yank-pop t)
570 ("\C-k" allout-kill-topic)
571 ; Miscellaneous commands:
572 ;([?\C-\ ] allout-mark-topic)
573 ("@" allout-resolve-xref)
574 ("=c" allout-copy-exposed-to-buffer)
575 ("=i" allout-indented-exposed-to-buffer)
576 ("=t" allout-latexify-exposed)
577 ("=p" allout-flatten-exposed-to-buffer)))
578
579 ;;;_ = allout-use-hanging-indents
580 (defcustom allout-use-hanging-indents t
581 "*If non-nil, topic body text auto-indent defaults to indent of the header.
582 Ie, it is indented to be just past the header prefix. This is
583 relevant mostly for use with indented-text-mode, or other situations
584 where auto-fill occurs."
585 :type 'boolean
586 :group 'allout)
587 (make-variable-buffer-local 'allout-use-hanging-indents)
588
589 ;;;_ = allout-reindent-bodies
590 (defcustom allout-reindent-bodies (if allout-use-hanging-indents
591 'text)
592 "*Non-nil enables auto-adjust of topic body hanging indent with depth shifts.
593
594 When active, topic body lines that are indented even with or beyond
595 their topic header are reindented to correspond with depth shifts of
596 the header.
597
598 A value of t enables reindent in non-programming-code buffers, ie
599 those that do not have the variable `comment-start' set. A value of
600 `force' enables reindent whether or not `comment-start' is set."
601 :type '(choice (const nil) (const t) (const text) (const force))
602 :group 'allout)
603
604 (make-variable-buffer-local 'allout-reindent-bodies)
605
606 ;;;_ = allout-enable-file-variable-adjustment
607 (defcustom allout-enable-file-variable-adjustment t
608 "*If non-nil, some allout outline actions edit Emacs local file var text.
609
610 This can range from changes to existing entries, addition of new ones,
611 and creation of a new local variables section when necessary.
612
613 Emacs file variables adjustments are also inhibited if `enable-local-variables'
614 is nil.
615
616 Operations potentially causing edits include allout encryption routines.
617 For details, see `allout-toggle-current-subtree-encryption's docstring."
618 :type 'boolean
619 :group 'allout)
620 (make-variable-buffer-local 'allout-enable-file-variable-adjustment)
621
622 ;;;_* CODE - no user customizations below.
623
624 ;;;_ #1 Internal Outline Formatting and Configuration
625 ;;;_ : Version
626 ;;;_ = allout-version
627 (defvar allout-version "2.2.1"
628 "Version of currently loaded outline package. \(allout.el)")
629 ;;;_ > allout-version
630 (defun allout-version (&optional here)
631 "Return string describing the loaded outline version."
632 (interactive "P")
633 (let ((msg (concat "Allout Outline Mode v " allout-version)))
634 (if here (insert msg))
635 (message "%s" msg)
636 msg))
637 ;;;_ : Mode activation (defined here because it's referenced early)
638 ;;;_ = allout-mode
639 (defvar allout-mode nil "Allout outline mode minor-mode flag.")
640 (make-variable-buffer-local 'allout-mode)
641 ;;;_ = allout-layout nil
642 (defvar allout-layout nil ; LEAVE GLOBAL VALUE NIL - see docstring.
643 "Buffer-specific setting for allout layout.
644
645 In buffers where this is non-nil \(and if `allout-init' has been run, to
646 enable this behavior), `allout-mode' will be automatically activated. The
647 layout dictated by the value will be used to set the initial exposure when
648 `allout-mode' is activated.
649
650 \*You should not setq-default this variable non-nil unless you want every
651 visited file to be treated as an allout file.*
652
653 The value would typically be set by a file local variable. For
654 example, the following lines at the bottom of an Emacs Lisp file:
655
656 ;;;Local variables:
657 ;;;allout-layout: \(0 : -1 -1 0)
658 ;;;End:
659
660 dictate activation of `allout-mode' mode when the file is visited
661 \(presuming allout-init was already run), followed by the
662 equivalent of `\(allout-expose-topic 0 : -1 -1 0)'. \(This is
663 the layout used for the allout.el source file.)
664
665 `allout-default-layout' describes the specification format.
666 `allout-layout' can additionally have the value `t', in which
667 case the value of `allout-default-layout' is used.")
668 (make-variable-buffer-local 'allout-layout)
669 ;;;###autoload
670 (put 'allout-layout 'safe-local-variable (lambda (x) (or (listp x) (symbolp x))))
671
672 ;;;_ : Topic header format
673 ;;;_ = allout-regexp
674 (defvar allout-regexp ""
675 "*Regular expression to match the beginning of a heading line.
676
677 Any line whose beginning matches this regexp is considered a
678 heading. This var is set according to the user configuration vars
679 by `set-allout-regexp'.")
680 (make-variable-buffer-local 'allout-regexp)
681 ;;;_ = allout-bullets-string
682 (defvar allout-bullets-string ""
683 "A string dictating the valid set of outline topic bullets.
684
685 This var should *not* be set by the user - it is set by `set-allout-regexp',
686 and is produced from the elements of `allout-plain-bullets-string'
687 and `allout-distinctive-bullets-string'.")
688 (make-variable-buffer-local 'allout-bullets-string)
689 ;;;_ = allout-bullets-string-len
690 (defvar allout-bullets-string-len 0
691 "Length of current buffers' `allout-plain-bullets-string'.")
692 (make-variable-buffer-local 'allout-bullets-string-len)
693 ;;;_ = allout-line-boundary-regexp
694 (defvar allout-line-boundary-regexp ()
695 "`allout-regexp' with outline style beginning-of-line anchor.
696
697 This is properly set when `allout-regexp' is produced by
698 `set-allout-regexp', so that (match-beginning 2) and (match-end
699 2) delimit the prefix.")
700 (make-variable-buffer-local 'allout-line-boundary-regexp)
701 ;;;_ = allout-bob-regexp
702 (defvar allout-bob-regexp ()
703 "Like `allout-line-boundary-regexp', for headers at beginning of buffer.
704 \(match-beginning 2) and \(match-end 2) delimit the prefix.")
705 (make-variable-buffer-local 'allout-bob-regexp)
706 ;;;_ = allout-header-subtraction
707 (defvar allout-header-subtraction (1- (length allout-header-prefix))
708 "Allout-header prefix length to subtract when computing topic depth.")
709 (make-variable-buffer-local 'allout-header-subtraction)
710 ;;;_ = allout-plain-bullets-string-len
711 (defvar allout-plain-bullets-string-len (length allout-plain-bullets-string)
712 "Length of `allout-plain-bullets-string', updated by `set-allout-regexp'.")
713 (make-variable-buffer-local 'allout-plain-bullets-string-len)
714
715
716 ;;;_ X allout-reset-header-lead (header-lead)
717 (defun allout-reset-header-lead (header-lead)
718 "*Reset the leading string used to identify topic headers."
719 (interactive "sNew lead string: ")
720 (setq allout-header-prefix header-lead)
721 (setq allout-header-subtraction (1- (length allout-header-prefix)))
722 (set-allout-regexp))
723 ;;;_ X allout-lead-with-comment-string (header-lead)
724 (defun allout-lead-with-comment-string (&optional header-lead)
725 "*Set the topic-header leading string to specified string.
726
727 Useful when for encapsulating outline structure in programming
728 language comments. Returns the leading string."
729
730 (interactive "P")
731 (if (not (stringp header-lead))
732 (setq header-lead (read-string
733 "String prefix for topic headers: ")))
734 (setq allout-reindent-bodies nil)
735 (allout-reset-header-lead header-lead)
736 header-lead)
737 ;;;_ > allout-infer-header-lead ()
738 (defun allout-infer-header-lead ()
739 "Determine appropriate `allout-header-prefix'.
740
741 Works according to settings of:
742
743 `comment-start'
744 `allout-header-prefix' (default)
745 `allout-use-mode-specific-leader'
746 and `allout-mode-leaders'.
747
748 Apply this via \(re)activation of `allout-mode', rather than
749 invoking it directly."
750 (let* ((use-leader (and (boundp 'allout-use-mode-specific-leader)
751 (if (or (stringp allout-use-mode-specific-leader)
752 (memq allout-use-mode-specific-leader
753 '(allout-mode-leaders
754 comment-start
755 t)))
756 allout-use-mode-specific-leader
757 ;; Oops - garbled value, equate with effect of 't:
758 t)))
759 (leader
760 (cond
761 ((not use-leader) nil)
762 ;; Use the explicitly designated leader:
763 ((stringp use-leader) use-leader)
764 (t (or (and (memq use-leader '(t allout-mode-leaders))
765 ;; Get it from outline mode leaders?
766 (cdr (assq major-mode allout-mode-leaders)))
767 ;; ... didn't get from allout-mode-leaders...
768 (and (memq use-leader '(t comment-start))
769 comment-start
770 ;; Use comment-start, maybe tripled, and with
771 ;; underscore:
772 (concat
773 (if (string= " "
774 (substring comment-start
775 (1- (length comment-start))))
776 ;; Use comment-start, sans trailing space:
777 (substring comment-start 0 -1)
778 (concat comment-start comment-start comment-start))
779 ;; ... and append underscore, whichever:
780 "_")))))))
781 (if (not leader)
782 nil
783 (if (string= leader allout-header-prefix)
784 nil ; no change, nothing to do.
785 (setq allout-header-prefix leader)
786 allout-header-prefix))))
787 ;;;_ > allout-infer-body-reindent ()
788 (defun allout-infer-body-reindent ()
789 "Determine proper setting for `allout-reindent-bodies'.
790
791 Depends on default setting of `allout-reindent-bodies' \(which see)
792 and presence of setting for `comment-start', to tell whether the
793 file is programming code."
794 (if (and allout-reindent-bodies
795 comment-start
796 (not (eq 'force allout-reindent-bodies)))
797 (setq allout-reindent-bodies nil)))
798 ;;;_ > set-allout-regexp ()
799 (defun set-allout-regexp ()
800 "Generate proper topic-header regexp form for outline functions.
801
802 Works with respect to `allout-plain-bullets-string' and
803 `allout-distinctive-bullets-string'."
804
805 (interactive)
806 ;; Derive allout-bullets-string from user configured components:
807 (setq allout-bullets-string "")
808 (let ((strings (list 'allout-plain-bullets-string
809 'allout-distinctive-bullets-string
810 'allout-primary-bullet))
811 cur-string
812 cur-len
813 cur-char
814 index)
815 (while strings
816 (setq index 0)
817 (setq cur-len (length (setq cur-string (symbol-value (car strings)))))
818 (while (< index cur-len)
819 (setq cur-char (aref cur-string index))
820 (setq allout-bullets-string
821 (concat allout-bullets-string
822 (cond
823 ; Single dash would denote a
824 ; sequence, repeated denotes
825 ; a dash:
826 ((eq cur-char ?-) "--")
827 ; literal close-square-bracket
828 ; doesn't work right in the
829 ; expr, exclude it:
830 ((eq cur-char ?\]) "")
831 (t (regexp-quote (char-to-string cur-char))))))
832 (setq index (1+ index)))
833 (setq strings (cdr strings)))
834 )
835 ;; Derive next for repeated use in allout-pending-bullet:
836 (setq allout-plain-bullets-string-len (length allout-plain-bullets-string))
837 (setq allout-header-subtraction (1- (length allout-header-prefix)))
838 ;; Produce the new allout-regexp:
839 (setq allout-regexp (concat "\\(\\"
840 allout-header-prefix
841 "[ \t]*["
842 allout-bullets-string
843 "]\\)\\|\\"
844 allout-primary-bullet
845 "+\\|\^l"))
846 (setq allout-line-boundary-regexp
847 (concat "\\(\n\\)\\(" allout-regexp "\\)"))
848 (setq allout-bob-regexp
849 (concat "\\(\\`\\)\\(" allout-regexp "\\)"))
850 )
851 ;;;_ : Key bindings
852 ;;;_ = allout-mode-map
853 (defvar allout-mode-map nil "Keybindings for (allout) outline minor mode.")
854 ;;;_ > produce-allout-mode-map (keymap-alist &optional base-map)
855 (defun produce-allout-mode-map (keymap-list &optional base-map)
856 "Produce keymap for use as allout-mode-map, from KEYMAP-LIST.
857
858 Built on top of optional BASE-MAP, or empty sparse map if none specified.
859 See doc string for allout-keybindings-list for format of binding list."
860 (let ((map (or base-map (make-sparse-keymap)))
861 (pref (list allout-command-prefix)))
862 (mapcar (function
863 (lambda (cell)
864 (let ((add-pref (null (cdr (cdr cell))))
865 (key-suff (list (car cell))))
866 (apply 'define-key
867 (list map
868 (apply 'concat (if add-pref
869 (append pref key-suff)
870 key-suff))
871 (car (cdr cell)))))))
872 keymap-list)
873 map))
874 ;;;_ = allout-prior-bindings - being deprecated.
875 (defvar allout-prior-bindings nil
876 "Variable for use in V18, with allout-added-bindings, for
877 resurrecting, on mode deactivation, bindings that existed before
878 activation. Being deprecated.")
879 ;;;_ = allout-added-bindings - being deprecated
880 (defvar allout-added-bindings nil
881 "Variable for use in V18, with allout-prior-bindings, for
882 resurrecting, on mode deactivation, bindings that existed before
883 activation. Being deprecated.")
884 ;;;_ : Menu bar
885 (defvar allout-mode-exposure-menu)
886 (defvar allout-mode-editing-menu)
887 (defvar allout-mode-navigation-menu)
888 (defvar allout-mode-misc-menu)
889 (defun produce-allout-mode-menubar-entries ()
890 (require 'easymenu)
891 (easy-menu-define allout-mode-exposure-menu
892 allout-mode-map
893 "Allout outline exposure menu."
894 '("Exposure"
895 ["Show Entry" allout-show-current-entry t]
896 ["Show Children" allout-show-children t]
897 ["Show Subtree" allout-show-current-subtree t]
898 ["Hide Subtree" allout-hide-current-subtree t]
899 ["Hide Leaves" allout-hide-current-leaves t]
900 "----"
901 ["Show All" allout-show-all t]))
902 (easy-menu-define allout-mode-editing-menu
903 allout-mode-map
904 "Allout outline editing menu."
905 '("Headings"
906 ["Open Sibling" allout-open-sibtopic t]
907 ["Open Subtopic" allout-open-subtopic t]
908 ["Open Supertopic" allout-open-supertopic t]
909 "----"
910 ["Shift Topic In" allout-shift-in t]
911 ["Shift Topic Out" allout-shift-out t]
912 ["Rebullet Topic" allout-rebullet-topic t]
913 ["Rebullet Heading" allout-rebullet-current-heading t]
914 ["Number Siblings" allout-number-siblings t]
915 "----"
916 ["Toggle Topic Encryption"
917 allout-toggle-current-subtree-encryption
918 (> (allout-current-depth) 1)]))
919 (easy-menu-define allout-mode-navigation-menu
920 allout-mode-map
921 "Allout outline navigation menu."
922 '("Navigation"
923 ["Next Visible Heading" allout-next-visible-heading t]
924 ["Previous Visible Heading"
925 allout-previous-visible-heading t]
926 "----"
927 ["Up Level" allout-up-current-level t]
928 ["Forward Current Level" allout-forward-current-level t]
929 ["Backward Current Level"
930 allout-backward-current-level t]
931 "----"
932 ["Beginning of Entry"
933 allout-beginning-of-current-entry t]
934 ["End of Entry" allout-end-of-entry t]
935 ["End of Subtree" allout-end-of-current-subtree t]))
936 (easy-menu-define allout-mode-misc-menu
937 allout-mode-map
938 "Allout outlines miscellaneous bindings."
939 '("Misc"
940 ["Version" allout-version t]
941 "----"
942 ["Duplicate Exposed" allout-copy-exposed-to-buffer t]
943 ["Duplicate Exposed, numbered"
944 allout-flatten-exposed-to-buffer t]
945 ["Duplicate Exposed, indented"
946 allout-indented-exposed-to-buffer t]
947 "----"
948 ["Set Header Lead" allout-reset-header-lead t]
949 ["Set New Exposure" allout-expose-topic t])))
950 ;;;_ : Mode-Specific Variable Maintenance Utilities
951 ;;;_ = allout-mode-prior-settings
952 (defvar allout-mode-prior-settings nil
953 "Internal `allout-mode' use; settings to be resumed on mode deactivation.")
954 (make-variable-buffer-local 'allout-mode-prior-settings)
955 ;;;_ > allout-resumptions (name &optional value)
956 (defun allout-resumptions (name &optional value)
957
958 "Registers or resumes settings over `allout-mode' activation/deactivation.
959
960 First arg is NAME of variable affected. Optional second arg is list
961 containing allout-mode-specific VALUE to be imposed on named
962 variable, and to be registered. \(It's a list so you can specify
963 registrations of null values.) If no value is specified, the
964 registered value is returned (encapsulated in the list, so the caller
965 can distinguish nil vs no value), and the registration is popped
966 from the list."
967
968 (let ((on-list (assq name allout-mode-prior-settings))
969 prior-capsule ; By `capsule' i mean a list
970 ; containing a value, so we can
971 ; distinguish nil from no value.
972 )
973
974 (if value
975
976 ;; Registering:
977 (progn
978 (if on-list
979 nil ; Already preserved prior value - don't mess with it.
980 ;; Register the old value, or nil if previously unbound:
981 (setq allout-mode-prior-settings
982 (cons (list name
983 (if (boundp name) (list (symbol-value name))))
984 allout-mode-prior-settings)))
985 ; And impose the new value, locally:
986 (progn (make-local-variable name)
987 (set name (car value))))
988
989 ;; Relinquishing:
990 (if (not on-list)
991
992 ;; Oops, not registered - leave it be:
993 nil
994
995 ;; Some registration:
996 ; reestablish it:
997 (setq prior-capsule (car (cdr on-list)))
998 (if prior-capsule
999 (set name (car prior-capsule)) ; Some prior value - reestablish it.
1000 (makunbound name)) ; Previously unbound - demolish var.
1001 ; Remove registration:
1002 (let (rebuild)
1003 (while allout-mode-prior-settings
1004 (if (not (eq (car allout-mode-prior-settings)
1005 on-list))
1006 (setq rebuild
1007 (cons (car allout-mode-prior-settings)
1008 rebuild)))
1009 (setq allout-mode-prior-settings
1010 (cdr allout-mode-prior-settings)))
1011 (setq allout-mode-prior-settings rebuild)))))
1012 )
1013 ;;;_ : Mode-specific incidentals
1014 ;;;_ > allout-unprotected (expr)
1015 (defmacro allout-unprotected (expr)
1016 "Enable internal outline operations to alter invisible text."
1017 `(let ((inhibit-read-only t))
1018 ,expr))
1019 ;;;_ = allout-mode-hook
1020 (defvar allout-mode-hook nil
1021 "*Hook that's run when allout mode starts.")
1022 ;;;_ = allout-overlay-category
1023 (defvar allout-overlay-category nil
1024 "Symbol for use in allout invisible-text overlays as the category.")
1025 ;;;_ = allout-view-change-hook
1026 (defvar allout-view-change-hook nil
1027 "*Hook that's run after allout outline visibility changes.")
1028
1029 ;;;_ = allout-outside-normal-auto-fill-function
1030 (defvar allout-outside-normal-auto-fill-function nil
1031 "Value of normal-auto-fill-function outside of allout mode.
1032
1033 Used by allout-auto-fill to do the mandated normal-auto-fill-function
1034 wrapped within allout's automatic fill-prefix setting.")
1035 (make-variable-buffer-local 'allout-outside-normal-auto-fill-function)
1036 ;;;_ = file-var-bug hack
1037 (defvar allout-v18/19-file-var-hack nil
1038 "Horrible hack used to prevent invalid multiple triggering of outline
1039 mode from prop-line file-var activation. Used by `allout-mode' function
1040 to track repeats.")
1041 ;;;_ = allout-passphrase-verifier-string
1042 (defvar allout-passphrase-verifier-string nil
1043 "Setting used to test solicited encryption passphrases against the one
1044 already associated with a file.
1045
1046 It consists of an encrypted random string useful only to verify that a
1047 passphrase entered by the user is effective for decryption. The passphrase
1048 itself is \*not* recorded in the file anywhere, and the encrypted contents
1049 are random binary characters to avoid exposing greater susceptibility to
1050 search attacks.
1051
1052 The verifier string is retained as an Emacs file variable, as well as in
1053 the emacs buffer state, if file variable adjustments are enabled. See
1054 `allout-enable-file-variable-adjustment' for details about that.")
1055 (make-variable-buffer-local 'allout-passphrase-verifier-string)
1056 (put 'allout-passphrase-verifier-string 'safe-local-variable 'stringp)
1057 ;;;_ = allout-passphrase-hint-string
1058 (defvar allout-passphrase-hint-string ""
1059 "Variable used to retain reminder string for file's encryption passphrase.
1060
1061 See the description of `allout-passphrase-hint-handling' for details about how
1062 the reminder is deployed.
1063
1064 The hint is retained as an Emacs file variable, as well as in the emacs buffer
1065 state, if file variable adjustments are enabled. See
1066 `allout-enable-file-variable-adjustment' for details about that.")
1067 (make-variable-buffer-local 'allout-passphrase-hint-string)
1068 (put 'allout-passphrase-hint-string 'safe-local-variable 'stringp)
1069 (setq-default allout-passphrase-hint-string "")
1070 ;;;_ = allout-after-save-decrypt
1071 (defvar allout-after-save-decrypt nil
1072 "Internal variable, is nil or has the value of two points:
1073
1074 - the location of a topic to be decrypted after saving is done
1075 - where to situate the cursor after the decryption is performed
1076
1077 This is used to decrypt the topic that was currently being edited, if it
1078 was encrypted automatically as part of a file write or autosave.")
1079 (make-variable-buffer-local 'allout-after-save-decrypt)
1080 ;;;_ > allout-mode-p ()
1081 ;; Must define this macro above any uses, or byte compilation will lack
1082 ;; proper def, if file isn't loaded - eg, during emacs build!
1083 (defmacro allout-mode-p ()
1084 "Return t if `allout-mode' is active in current buffer."
1085 'allout-mode)
1086 ;;;_ > allout-write-file-hook-handler ()
1087 (defun allout-write-file-hook-handler ()
1088 "Implement `allout-encrypt-unencrypted-on-saves' policy for file writes."
1089
1090 (if (or (not (allout-mode-p))
1091 (not (boundp 'allout-encrypt-unencrypted-on-saves))
1092 (not allout-encrypt-unencrypted-on-saves))
1093 nil
1094 (let ((except-mark (and (equal allout-encrypt-unencrypted-on-saves
1095 'except-current)
1096 (point-marker))))
1097 (if (save-excursion (goto-char (point-min))
1098 (allout-next-topic-pending-encryption except-mark))
1099 (progn
1100 (message "auto-encrypting pending topics")
1101 (sit-for 0)
1102 (condition-case failure
1103 (setq allout-after-save-decrypt
1104 (allout-encrypt-decrypted except-mark))
1105 (error (progn
1106 (message
1107 "allout-write-file-hook-handler suppressing error %s"
1108 failure)
1109 (sit-for 2))))))
1110 ))
1111 nil)
1112 ;;;_ > allout-auto-save-hook-handler ()
1113 (defun allout-auto-save-hook-handler ()
1114 "Implement `allout-encrypt-unencrypted-on-saves' policy for auto save."
1115
1116 (if (and (allout-mode-p) allout-encrypt-unencrypted-on-saves)
1117 ;; Always implement 'except-current policy when enabled.
1118 (let ((allout-encrypt-unencrypted-on-saves 'except-current))
1119 (allout-write-file-hook-handler))))
1120 ;;;_ > allout-after-saves-handler ()
1121 (defun allout-after-saves-handler ()
1122 "Decrypt topic encrypted for save, if it's currently being edited.
1123
1124 Ie, if it was pending encryption and contained the point in its body before
1125 the save.
1126
1127 We use values stored in `allout-after-save-decrypt' to locate the topic
1128 and the place for the cursor after the decryption is done."
1129 (if (not (and (allout-mode-p)
1130 (boundp 'allout-after-save-decrypt)
1131 allout-after-save-decrypt))
1132 t
1133 (goto-char (car allout-after-save-decrypt))
1134 (let ((was-modified (buffer-modified-p)))
1135 (allout-toggle-subtree-encryption)
1136 (if (not was-modified)
1137 (set-buffer-modified-p nil)))
1138 (goto-char (cadr allout-after-save-decrypt))
1139 (setq allout-after-save-decrypt nil))
1140 )
1141
1142 ;;;_ #2 Mode activation
1143 ;;;_ = allout-explicitly-deactivated
1144 (defvar allout-explicitly-deactivated nil
1145 "If t, `allout-mode's last deactivation was deliberate.
1146 So `allout-post-command-business' should not reactivate it...")
1147 (make-variable-buffer-local 'allout-explicitly-deactivated)
1148 ;;;_ > allout-init (&optional mode)
1149 (defun allout-init (&optional mode)
1150 "Prime `allout-mode' to enable/disable auto-activation, wrt `allout-layout'.
1151
1152 MODE is one of the following symbols:
1153
1154 - nil \(or no argument) deactivate auto-activation/layout;
1155 - `activate', enable auto-activation only;
1156 - `ask', enable auto-activation, and enable auto-layout but with
1157 confirmation for layout operation solicited from user each time;
1158 - `report', just report and return the current auto-activation state;
1159 - anything else \(eg, t) for auto-activation and auto-layout, without
1160 any confirmation check.
1161
1162 Use this function to setup your Emacs session for automatic activation
1163 of allout outline mode, contingent to the buffer-specific setting of
1164 the `allout-layout' variable. (See `allout-layout' and
1165 `allout-expose-topic' docstrings for more details on auto layout).
1166
1167 `allout-init' works by setting up (or removing) the `allout-mode'
1168 find-file-hook, and giving `allout-auto-activation' a suitable
1169 setting.
1170
1171 To prime your Emacs session for full auto-outline operation, include
1172 the following two lines in your Emacs init file:
1173
1174 \(require 'allout)
1175 \(allout-init t)"
1176
1177 (interactive)
1178 (if (interactive-p)
1179 (progn
1180 (setq mode
1181 (completing-read
1182 (concat "Select outline auto setup mode "
1183 "(empty for report, ? for options) ")
1184 '(("nil")("full")("activate")("deactivate")
1185 ("ask") ("report") (""))
1186 nil
1187 t))
1188 (if (string= mode "")
1189 (setq mode 'report)
1190 (setq mode (intern-soft mode)))))
1191 (let
1192 ;; convenience aliases, for consistent ref to respective vars:
1193 ((hook 'allout-find-file-hook)
1194 (find-file-hook-var-name (if (boundp 'find-file-hook)
1195 'find-file-hook
1196 'find-file-hooks))
1197 (curr-mode 'allout-auto-activation))
1198
1199 (cond ((not mode)
1200 (set find-file-hook-var-name
1201 (delq hook (symbol-value find-file-hook-var-name)))
1202 (if (interactive-p)
1203 (message "Allout outline mode auto-activation inhibited.")))
1204 ((eq mode 'report)
1205 (if (not (memq hook (symbol-value find-file-hook-var-name)))
1206 (allout-init nil)
1207 ;; Just punt and use the reports from each of the modes:
1208 (allout-init (symbol-value curr-mode))))
1209 (t (add-hook find-file-hook-var-name hook)
1210 (set curr-mode ; `set', not `setq'!
1211 (cond ((eq mode 'activate)
1212 (message
1213 "Outline mode auto-activation enabled.")
1214 'activate)
1215 ((eq mode 'report)
1216 ;; Return the current mode setting:
1217 (allout-init mode))
1218 ((eq mode 'ask)
1219 (message
1220 (concat "Outline mode auto-activation and "
1221 "-layout \(upon confirmation) enabled."))
1222 'ask)
1223 ((message
1224 "Outline mode auto-activation and -layout enabled.")
1225 'full)))))))
1226 ;;;_ > allout-setup-menubar ()
1227 (defun allout-setup-menubar ()
1228 "Populate the current buffer's menubar with `allout-mode' stuff."
1229 (let ((menus (list allout-mode-exposure-menu
1230 allout-mode-editing-menu
1231 allout-mode-navigation-menu
1232 allout-mode-misc-menu))
1233 cur)
1234 (while menus
1235 (setq cur (car menus)
1236 menus (cdr menus))
1237 (easy-menu-add cur))))
1238 ;;;_ > allout-set-overlay-category
1239 (defun allout-set-overlay-category ()
1240 "Set the properties of the allout invisible-text overlay."
1241 (setplist 'allout-overlay-category nil)
1242 (put 'allout-overlay-category 'invisible 'allout)
1243 (put 'allout-overlay-category 'evaporate t)
1244 ;; XXX We use isearch-open-invisible *and* isearch-mode-end-hook. The
1245 ;; latter would be sufficient, but it seems that a separate behavior -
1246 ;; the _transient_ opening of invisible text during isearch - is keyed to
1247 ;; presence of the isearch-open-invisible property - even though this
1248 ;; property controls the isearch _arrival_ behavior. This is the case at
1249 ;; least in emacs 21, 22.0, and xemacs 21.4.
1250 (put 'allout-overlay-category 'isearch-open-invisible
1251 'allout-isearch-end-handler)
1252 (if (featurep 'xemacs)
1253 (put 'allout-overlay-category 'start-open t)
1254 (put 'allout-overlay-category 'insert-in-front-hooks
1255 '(allout-overlay-insert-in-front-handler)))
1256 (if (featurep 'xemacs)
1257 (progn (make-variable-buffer-local 'before-change-functions)
1258 (add-hook 'before-change-functions
1259 'allout-before-change-handler))
1260 (put 'allout-overlay-category 'modification-hooks
1261 '(allout-overlay-interior-modification-handler))))
1262 ;;;_ > allout-mode (&optional toggle)
1263 ;;;_ : Defun:
1264 ;;;###autoload
1265 (defun allout-mode (&optional toggle)
1266 ;;;_ . Doc string:
1267 "Toggle minor mode for controlling exposure and editing of text outlines.
1268 \\<allout-mode-map>
1269
1270 Optional arg forces mode to re-initialize iff arg is positive num or
1271 symbol. Allout outline mode always runs as a minor mode.
1272
1273 Allout outline mode provides extensive outline oriented formatting and
1274 manipulation. It enables structural editing of outlines, as well as
1275 navigation and exposure. It also is specifically aimed at
1276 accommodating syntax-sensitive text like programming languages. \(For
1277 an example, see the allout code itself, which is organized as an allout
1278 outline.)
1279
1280 In addition to outline navigation and exposure, allout includes:
1281
1282 - topic-oriented repositioning, promotion/demotion, cut, and paste
1283 - integral outline exposure-layout
1284 - incremental search with dynamic exposure and reconcealment of hidden text
1285 - automatic topic-number maintenance
1286 - easy topic encryption and decryption
1287 - \"Hot-spot\" operation, for single-keystroke maneuvering and
1288 exposure control. \(See the allout-mode docstring.)
1289
1290 and many other features.
1291
1292 Below is a description of the bindings, and then explanation of
1293 special `allout-mode' features and terminology. See also the outline
1294 menubar additions for quick reference to many of the features, and see
1295 the docstring of the function `allout-init' for instructions on
1296 priming your emacs session for automatic activation of `allout-mode'.
1297
1298
1299 The bindings are dictated by the `allout-keybindings-list' and
1300 `allout-command-prefix' variables.
1301
1302 Navigation: Exposure Control:
1303 ---------- ----------------
1304 \\[allout-next-visible-heading] allout-next-visible-heading | \\[allout-hide-current-subtree] allout-hide-current-subtree
1305 \\[allout-previous-visible-heading] allout-previous-visible-heading | \\[allout-show-children] allout-show-children
1306 \\[allout-up-current-level] allout-up-current-level | \\[allout-show-current-subtree] allout-show-current-subtree
1307 \\[allout-forward-current-level] allout-forward-current-level | \\[allout-show-current-entry] allout-show-current-entry
1308 \\[allout-backward-current-level] allout-backward-current-level | \\[allout-show-all] allout-show-all
1309 \\[allout-end-of-entry] allout-end-of-entry
1310 \\[allout-beginning-of-current-entry] allout-beginning-of-current-entry, alternately, goes to hot-spot
1311
1312 Topic Header Production:
1313 -----------------------
1314 \\[allout-open-sibtopic] allout-open-sibtopic Create a new sibling after current topic.
1315 \\[allout-open-subtopic] allout-open-subtopic ... an offspring of current topic.
1316 \\[allout-open-supertopic] allout-open-supertopic ... a sibling of the current topic's parent.
1317
1318 Topic Level and Prefix Adjustment:
1319 ---------------------------------
1320 \\[allout-shift-in] allout-shift-in Shift current topic and all offspring deeper.
1321 \\[allout-shift-out] allout-shift-out ... less deep.
1322 \\[allout-rebullet-current-heading] allout-rebullet-current-heading Prompt for alternate bullet for
1323 current topic.
1324 \\[allout-rebullet-topic] allout-rebullet-topic Reconcile bullets of topic and its offspring
1325 - distinctive bullets are not changed, others
1326 alternated according to nesting depth.
1327 \\[allout-number-siblings] allout-number-siblings Number bullets of topic and siblings - the
1328 offspring are not affected. With repeat
1329 count, revoke numbering.
1330
1331 Topic-oriented Killing and Yanking:
1332 ----------------------------------
1333 \\[allout-kill-topic] allout-kill-topic Kill current topic, including offspring.
1334 \\[allout-kill-line] allout-kill-line Like kill-line, but reconciles numbering, etc.
1335 \\[allout-yank] allout-yank Yank, adjusting depth of yanked topic to
1336 depth of heading if yanking into bare topic
1337 heading (ie, prefix sans text).
1338 \\[allout-yank-pop] allout-yank-pop Is to allout-yank as yank-pop is to yank
1339
1340 Topic-oriented Encryption:
1341 -------------------------
1342 \\[allout-toggle-current-subtree-encryption] allout-toggle-current-subtree-encryption Encrypt/Decrypt topic content
1343
1344 Misc commands:
1345 -------------
1346 M-x outlineify-sticky Activate outline mode for current buffer,
1347 and establish a default file-var setting
1348 for `allout-layout'.
1349 \\[allout-mark-topic] allout-mark-topic
1350 \\[allout-copy-exposed-to-buffer] allout-copy-exposed-to-buffer
1351 Duplicate outline, sans concealed text, to
1352 buffer with name derived from derived from that
1353 of current buffer - \"*BUFFERNAME exposed*\".
1354 \\[allout-flatten-exposed-to-buffer] allout-flatten-exposed-to-buffer
1355 Like above 'copy-exposed', but convert topic
1356 prefixes to section.subsection... numeric
1357 format.
1358 \\[eval-expression] (allout-init t) Setup Emacs session for outline mode
1359 auto-activation.
1360
1361 Topic Encryption
1362
1363 Outline mode supports gpg encryption of topics, with support for
1364 symmetric and key-pair modes, passphrase timeout, passphrase
1365 consistency checking, user-provided hinting for symmetric key
1366 mode, and auto-encryption of topics pending encryption on save.
1367 \(Topics pending encryption are, by default, automatically
1368 encrypted during file saves; if you're editing the contents of
1369 such a topic, it is automatically decrypted for continued
1370 editing.) The aim is reliable topic privacy while preventing
1371 accidents like neglected encryption before saves, forgetting
1372 which passphrase was used, and other practical pitfalls.
1373
1374 See `allout-toggle-current-subtree-encryption' function docstring and
1375 `allout-encrypt-unencrypted-on-saves' customization variable for details.
1376
1377 HOT-SPOT Operation
1378
1379 Hot-spot operation provides a means for easy, single-keystroke outline
1380 navigation and exposure control.
1381
1382 When the text cursor is positioned directly on the bullet character of
1383 a topic, regular characters (a to z) invoke the commands of the
1384 corresponding allout-mode keymap control chars. For example, \"f\"
1385 would invoke the command typically bound to \"C-c<space>C-f\"
1386 \(\\[allout-forward-current-level] `allout-forward-current-level').
1387
1388 Thus, by positioning the cursor on a topic bullet, you can
1389 execute the outline navigation and manipulation commands with a
1390 single keystroke. Regular navigation keys (eg, \\[forward-char], \\[next-line]) never get
1391 this special translation, so you can use them to get out of the
1392 hot-spot and back to normal operation.
1393
1394 Note that the command `allout-beginning-of-current-entry' \(\\[allout-beginning-of-current-entry]\)
1395 will move to the hot-spot when the cursor is already located at the
1396 beginning of the current entry, so you usually can hit \\[allout-beginning-of-current-entry]
1397 twice in a row to get to the hot-spot.
1398
1399 Terminology
1400
1401 Topic hierarchy constituents - TOPICS and SUBTOPICS:
1402
1403 TOPIC: A basic, coherent component of an Emacs outline. It can
1404 contain and be contained by other topics.
1405 CURRENT topic:
1406 The visible topic most immediately containing the cursor.
1407 DEPTH: The degree of nesting of a topic; it increases with
1408 containment. Also called the:
1409 LEVEL: The same as DEPTH.
1410
1411 ANCESTORS:
1412 The topics that contain a topic.
1413 PARENT: A topic's immediate ancestor. It has a depth one less than
1414 the topic.
1415 OFFSPRING:
1416 The topics contained by a topic;
1417 SUBTOPIC:
1418 An immediate offspring of a topic;
1419 CHILDREN:
1420 The immediate offspring of a topic.
1421 SIBLINGS:
1422 Topics having the same parent and depth.
1423
1424 Topic text constituents:
1425
1426 HEADER: The first line of a topic, include the topic PREFIX and header
1427 text.
1428 PREFIX: The leading text of a topic which distinguishes it from normal
1429 text. It has a strict form, which consists of a prefix-lead
1430 string, padding, and a bullet. The bullet may be followed by a
1431 number, indicating the ordinal number of the topic among its
1432 siblings, a space, and then the header text.
1433
1434 The relative length of the PREFIX determines the nesting depth
1435 of the topic.
1436 PREFIX-LEAD:
1437 The string at the beginning of a topic prefix, normally a `.'.
1438 It can be customized by changing the setting of
1439 `allout-header-prefix' and then reinitializing `allout-mode'.
1440
1441 By setting the prefix-lead to the comment-string of a
1442 programming language, you can embed outline structuring in
1443 program code without interfering with the language processing
1444 of that code. See `allout-use-mode-specific-leader'
1445 docstring for more detail.
1446 PREFIX-PADDING:
1447 Spaces or asterisks which separate the prefix-lead and the
1448 bullet, determining the depth of the topic.
1449 BULLET: A character at the end of the topic prefix, it must be one of
1450 the characters listed on `allout-plain-bullets-string' or
1451 `allout-distinctive-bullets-string'. (See the documentation
1452 for these variables for more details.) The default choice of
1453 bullet when generating topics varies in a cycle with the depth of
1454 the topic.
1455 ENTRY: The text contained in a topic before any offspring.
1456 BODY: Same as ENTRY.
1457
1458
1459 EXPOSURE:
1460 The state of a topic which determines the on-screen visibility
1461 of its offspring and contained text.
1462 CONCEALED:
1463 Topics and entry text whose display is inhibited. Contiguous
1464 units of concealed text is represented by `...' ellipses.
1465
1466 Concealed topics are effectively collapsed within an ancestor.
1467 CLOSED: A topic whose immediate offspring and body-text is concealed.
1468 OPEN: A topic that is not closed, though its offspring or body may be."
1469 ;;;_ . Code
1470 (interactive "P")
1471
1472 (let* ((active (and (not (equal major-mode 'outline))
1473 (allout-mode-p)))
1474 ; Massage universal-arg `toggle' val:
1475 (toggle (and toggle
1476 (or (and (listp toggle)(car toggle))
1477 toggle)))
1478 ; Activation specifically demanded?
1479 (explicit-activation (and toggle
1480 (or (symbolp toggle)
1481 (and (wholenump toggle)
1482 (not (zerop toggle))))))
1483 ;; allout-mode already called once during this complex command?
1484 (same-complex-command (eq allout-v18/19-file-var-hack
1485 (car command-history)))
1486 (write-file-hook-var-name (cond ((boundp 'write-file-functions)
1487 'write-file-functions)
1488 ((boundp 'write-file-hooks)
1489 'write-file-hooks)
1490 (t 'local-write-file-hooks)))
1491 do-layout
1492 )
1493
1494 ; See comments below re v19.18,.19 bug.
1495 (setq allout-v18/19-file-var-hack (car command-history))
1496
1497 (cond
1498
1499 ;; Provision for v19.18, 19.19 bug -
1500 ;; Emacs v 19.18, 19.19 file-var code invokes prop-line-designated
1501 ;; modes twice when file is visited. We have to avoid toggling mode
1502 ;; off on second invocation, so we detect it as best we can, and
1503 ;; skip everything.
1504 ((and same-complex-command ; Still in same complex command
1505 ; as last time `allout-mode' invoked.
1506 active ; Already activated.
1507 (not explicit-activation) ; Prop-line file-vars don't have args.
1508 (string-match "^19.1[89]" ; Bug only known to be in v19.18 and
1509 emacs-version)); 19.19.
1510 t)
1511
1512 ;; Deactivation:
1513 ((and (not explicit-activation)
1514 (or active toggle))
1515 ; Activation not explicitly
1516 ; requested, and either in
1517 ; active state or *de*activation
1518 ; specifically requested:
1519 (setq allout-explicitly-deactivated t)
1520 (if (string-match "^18\." emacs-version)
1521 ; Revoke those keys that remain
1522 ; as we set them:
1523 (let ((curr-loc (current-local-map)))
1524 (mapcar (function
1525 (lambda (cell)
1526 (if (eq (lookup-key curr-loc (car cell))
1527 (car (cdr cell)))
1528 (define-key curr-loc (car cell)
1529 (assq (car cell) allout-prior-bindings)))))
1530 allout-added-bindings)
1531 (allout-resumptions 'allout-added-bindings)
1532 (allout-resumptions 'allout-prior-bindings)))
1533
1534 (if allout-old-style-prefixes
1535 (progn
1536 (allout-resumptions 'allout-primary-bullet)
1537 (allout-resumptions 'allout-old-style-prefixes)))
1538 ;;(allout-resumptions 'selective-display)
1539 (remove-from-invisibility-spec '(allout . t))
1540 (set write-file-hook-var-name
1541 (delq 'allout-write-file-hook-handler
1542 (symbol-value write-file-hook-var-name)))
1543 (setq auto-save-hook
1544 (delq 'allout-auto-save-hook-handler
1545 auto-save-hook))
1546 (allout-resumptions 'paragraph-start)
1547 (allout-resumptions 'paragraph-separate)
1548 (allout-resumptions 'auto-fill-function)
1549 (allout-resumptions 'normal-auto-fill-function)
1550 (allout-resumptions 'allout-former-auto-filler)
1551 (setq allout-mode nil))
1552
1553 ;; Activation:
1554 ((not active)
1555 (setq allout-explicitly-deactivated nil)
1556 (if allout-old-style-prefixes
1557 (progn ; Inhibit all the fancy formatting:
1558 (allout-resumptions 'allout-primary-bullet '("*"))
1559 (allout-resumptions 'allout-old-style-prefixes '(()))))
1560
1561 (allout-set-overlay-category) ; Doesn't hurt to redo this.
1562
1563 (allout-infer-header-lead)
1564 (allout-infer-body-reindent)
1565
1566 (set-allout-regexp)
1567
1568 ; Produce map from current version
1569 ; of allout-keybindings-list:
1570 (if (boundp 'minor-mode-map-alist)
1571
1572 (progn ; V19, and maybe lucid and
1573 ; epoch, minor-mode key bindings:
1574 (setq allout-mode-map
1575 (produce-allout-mode-map allout-keybindings-list))
1576 (produce-allout-mode-menubar-entries)
1577 (fset 'allout-mode-map allout-mode-map)
1578 ; Include on minor-mode-map-alist,
1579 ; if not already there:
1580 (if (not (member '(allout-mode . allout-mode-map)
1581 minor-mode-map-alist))
1582 (setq minor-mode-map-alist
1583 (cons '(allout-mode . allout-mode-map)
1584 minor-mode-map-alist))))
1585
1586 ; V18 minor-mode key bindings:
1587 ; Stash record of added bindings
1588 ; for later revocation:
1589 (allout-resumptions 'allout-added-bindings
1590 (list allout-keybindings-list))
1591 (allout-resumptions 'allout-prior-bindings
1592 (list (current-local-map)))
1593 ; and add them:
1594 (use-local-map (produce-allout-mode-map allout-keybindings-list
1595 (current-local-map)))
1596 )
1597
1598 (add-to-invisibility-spec '(allout . t))
1599 (make-local-variable 'line-move-ignore-invisible)
1600 (setq line-move-ignore-invisible t)
1601 (add-hook 'pre-command-hook 'allout-pre-command-business)
1602 (add-hook 'post-command-hook 'allout-post-command-business)
1603 (add-hook 'isearch-mode-end-hook 'allout-isearch-end-handler)
1604 (add-hook write-file-hook-var-name 'allout-write-file-hook-handler)
1605 (add-hook 'auto-save-hook 'allout-auto-save-hook-handler)
1606 ; Custom auto-fill func, to support
1607 ; respect for topic headline,
1608 ; hanging-indents, etc:
1609 ;; Register prevailing fill func for use by allout-auto-fill:
1610 (allout-resumptions 'allout-former-auto-filler (list auto-fill-function))
1611 ;; Register allout-auto-fill to be used if filling is active:
1612 (allout-resumptions 'auto-fill-function '(allout-auto-fill))
1613 (allout-resumptions 'allout-outside-normal-auto-fill-function
1614 (list normal-auto-fill-function))
1615 (allout-resumptions 'normal-auto-fill-function '(allout-auto-fill))
1616 ;; Paragraphs are broken by topic headlines.
1617 (make-local-variable 'paragraph-start)
1618 (allout-resumptions 'paragraph-start
1619 (list (concat paragraph-start "\\|^\\("
1620 allout-regexp "\\)")))
1621 (make-local-variable 'paragraph-separate)
1622 (allout-resumptions 'paragraph-separate
1623 (list (concat paragraph-separate "\\|^\\("
1624 allout-regexp "\\)")))
1625
1626 (or (assq 'allout-mode minor-mode-alist)
1627 (setq minor-mode-alist
1628 (cons '(allout-mode " Allout") minor-mode-alist)))
1629
1630 (allout-setup-menubar)
1631
1632 (if allout-layout
1633 (setq do-layout t))
1634
1635 (run-hooks 'allout-mode-hook)
1636 (setq allout-mode t))
1637
1638 ;; Reactivation:
1639 ((setq do-layout t)
1640 (allout-infer-body-reindent))
1641 ) ; cond
1642
1643 (let ((use-layout (if (listp allout-layout)
1644 allout-layout
1645 allout-default-layout)))
1646 (if (and do-layout
1647 allout-auto-activation
1648 use-layout
1649 (and (not (eq allout-auto-activation 'activate))
1650 (if (eq allout-auto-activation 'ask)
1651 (if (y-or-n-p (format "Expose %s with layout '%s'? "
1652 (buffer-name)
1653 use-layout))
1654 t
1655 (message "Skipped %s layout." (buffer-name))
1656 nil)
1657 t)))
1658 (save-excursion
1659 (message "Adjusting '%s' exposure..." (buffer-name))
1660 (goto-char 0)
1661 (allout-this-or-next-heading)
1662 (condition-case err
1663 (progn
1664 (apply 'allout-expose-topic (list use-layout))
1665 (message "Adjusting '%s' exposure... done." (buffer-name)))
1666 ;; Problem applying exposure - notify user, but don't
1667 ;; interrupt, eg, file visit:
1668 (error (message "%s" (car (cdr err)))
1669 (sit-for 1))))))
1670 allout-mode
1671 ) ; let*
1672 ) ; defun
1673 ;;;_ > allout-minor-mode
1674 (defalias 'allout-minor-mode 'allout-mode)
1675
1676 ;;;_ - Position Assessment
1677 ;;;_ > allout-hidden-p (&optional pos)
1678 (defsubst allout-hidden-p (&optional pos)
1679 "Non-nil if the character after point is invisible."
1680 (get-char-property (or pos (point)) 'invisible))
1681
1682 ;;;_ > allout-overlay-insert-in-front-handler (ol after beg end
1683 ;;; &optional prelen)
1684 (defun allout-overlay-insert-in-front-handler (ol after beg end
1685 &optional prelen)
1686 "Shift the overlay so stuff inserted in front of it are excluded."
1687 (if after
1688 (move-overlay ol (1+ beg) (overlay-end ol))))
1689 ;;;_ > allout-overlay-interior-modification-handler (ol after beg end
1690 ;;; &optional prelen)
1691 (defun allout-overlay-interior-modification-handler (ol after beg end
1692 &optional prelen)
1693 "Get confirmation before making arbitrary changes to invisible text.
1694
1695 We expose the invisible text and ask for confirmation. Refusal or
1696 keyboard-quit abandons the changes, with keyboard-quit additionally
1697 reclosing the opened text.
1698
1699 No confirmation is necessary when inhibit-read-only is set - eg, allout
1700 internal functions use this feature cohesively bunch changes."
1701
1702 (when (and (not inhibit-read-only) (not after))
1703 (let ((start (point))
1704 (ol-start (overlay-start ol))
1705 (ol-end (overlay-end ol))
1706 (msg "Change within concealed text disallowed.")
1707 opened
1708 first)
1709 (goto-char beg)
1710 (while (< (point) end)
1711 (when (allout-hidden-p)
1712 (allout-show-to-offshoot)
1713 (if (allout-hidden-p)
1714 (save-excursion (forward-char 1)
1715 (allout-show-to-offshoot)))
1716 (when (not first)
1717 (setq opened t)
1718 (setq first (point))))
1719 (goto-char (if (featurep 'xemacs)
1720 (next-property-change (1+ (point)) nil end)
1721 (next-char-property-change (1+ (point)) end))))
1722 (when first
1723 (goto-char first)
1724 (condition-case nil
1725 (if (not
1726 (yes-or-no-p
1727 (substitute-command-keys
1728 (concat "Modify concealed text? (\"no\" just aborts,"
1729 " \\[keyboard-quit] also reconceals) "))))
1730 (progn (goto-char start)
1731 (error "Concealed-text change refused.")))
1732 (quit (allout-flag-region ol-start ol-end nil)
1733 (allout-flag-region ol-start ol-end t)
1734 (error "Concealed-text change abandoned, text reconcealed."))))
1735 (goto-char start))))
1736 ;;;_ > allout-before-change-handler (beg end)
1737 (defun allout-before-change-handler (beg end)
1738 "Protect against changes to invisible text.
1739
1740 See allout-overlay-interior-modification-handler for details.
1741
1742 This before-change handler is used only where modification-hooks
1743 overlay property is not supported."
1744 (if (not (allout-mode-p))
1745 nil
1746 (allout-overlay-interior-modification-handler nil nil beg end nil)))
1747 ;;;_ > allout-isearch-end-handler (&optional overlay)
1748 (defun allout-isearch-end-handler (&optional overlay)
1749 "Reconcile allout outline exposure on arriving in hidden text after isearch.
1750
1751 Optional OVERLAY parameter is for when this function is used by
1752 `isearch-open-invisible' overlay property. It is otherwise unused, so this
1753 function can also be used as an `isearch-mode-end-hook'."
1754
1755 (if (and (allout-mode-p) (allout-hidden-p))
1756 (allout-show-to-offshoot)))
1757
1758 ;;;_ #3 Internal Position State-Tracking - "allout-recent-*" funcs
1759 ;;; All the basic outline functions that directly do string matches to
1760 ;;; evaluate heading prefix location set the variables
1761 ;;; `allout-recent-prefix-beginning' and `allout-recent-prefix-end'
1762 ;;; when successful. Functions starting with `allout-recent-' all
1763 ;;; use this state, providing the means to avoid redundant searches
1764 ;;; for just-established data. This optimization can provide
1765 ;;; significant speed improvement, but it must be employed carefully.
1766 ;;;_ = allout-recent-prefix-beginning
1767 (defvar allout-recent-prefix-beginning 0
1768 "Buffer point of the start of the last topic prefix encountered.")
1769 (make-variable-buffer-local 'allout-recent-prefix-beginning)
1770 ;;;_ = allout-recent-prefix-end
1771 (defvar allout-recent-prefix-end 0
1772 "Buffer point of the end of the last topic prefix encountered.")
1773 (make-variable-buffer-local 'allout-recent-prefix-end)
1774 ;;;_ = allout-recent-end-of-subtree
1775 (defvar allout-recent-end-of-subtree 0
1776 "Buffer point last returned by `allout-end-of-current-subtree'.")
1777 (make-variable-buffer-local 'allout-recent-end-of-subtree)
1778 ;;;_ > allout-prefix-data (beg end)
1779 (defmacro allout-prefix-data (beg end)
1780 "Register allout-prefix state data - BEGINNING and END of prefix.
1781
1782 For reference by `allout-recent' funcs. Returns BEGINNING."
1783 `(setq allout-recent-prefix-end ,end
1784 allout-recent-prefix-beginning ,beg))
1785 ;;;_ > allout-recent-depth ()
1786 (defmacro allout-recent-depth ()
1787 "Return depth of last heading encountered by an outline maneuvering function.
1788
1789 All outline functions which directly do string matches to assess
1790 headings set the variables `allout-recent-prefix-beginning' and
1791 `allout-recent-prefix-end' if successful. This function uses those settings
1792 to return the current depth."
1793
1794 '(max 1 (- allout-recent-prefix-end
1795 allout-recent-prefix-beginning
1796 allout-header-subtraction)))
1797 ;;;_ > allout-recent-prefix ()
1798 (defmacro allout-recent-prefix ()
1799 "Like `allout-recent-depth', but returns text of last encountered prefix.
1800
1801 All outline functions which directly do string matches to assess
1802 headings set the variables `allout-recent-prefix-beginning' and
1803 `allout-recent-prefix-end' if successful. This function uses those settings
1804 to return the current depth."
1805 '(buffer-substring allout-recent-prefix-beginning
1806 allout-recent-prefix-end))
1807 ;;;_ > allout-recent-bullet ()
1808 (defmacro allout-recent-bullet ()
1809 "Like allout-recent-prefix, but returns bullet of last encountered prefix.
1810
1811 All outline functions which directly do string matches to assess
1812 headings set the variables `allout-recent-prefix-beginning' and
1813 `allout-recent-prefix-end' if successful. This function uses those settings
1814 to return the current depth of the most recently matched topic."
1815 '(buffer-substring (1- allout-recent-prefix-end)
1816 allout-recent-prefix-end))
1817
1818 ;;;_ #4 Navigation
1819
1820 ;;;_ - Position Assessment
1821 ;;;_ : Location Predicates
1822 ;;;_ > allout-on-current-heading-p ()
1823 (defun allout-on-current-heading-p ()
1824 "Return non-nil if point is on current visible topics' header line.
1825
1826 Actually, returns prefix beginning point."
1827 (save-excursion
1828 (allout-beginning-of-current-line)
1829 (and (looking-at allout-regexp)
1830 (allout-prefix-data (match-beginning 0) (match-end 0)))))
1831 ;;;_ > allout-on-heading-p ()
1832 (defalias 'allout-on-heading-p 'allout-on-current-heading-p)
1833 ;;;_ > allout-e-o-prefix-p ()
1834 (defun allout-e-o-prefix-p ()
1835 "True if point is located where current topic prefix ends, heading begins."
1836 (and (save-excursion (beginning-of-line)
1837 (looking-at allout-regexp))
1838 (= (point)(save-excursion (allout-end-of-prefix)(point)))))
1839 ;;;_ : Location attributes
1840 ;;;_ > allout-depth ()
1841 (defun allout-depth ()
1842 "Return depth of topic most immediately containing point.
1843
1844 Return zero if point is not within any topic.
1845
1846 Like `allout-current-depth', but respects hidden as well as visible topics."
1847 (save-excursion
1848 (let ((start-point (point)))
1849 (if (and (allout-goto-prefix)
1850 (not (< start-point (point))))
1851 (allout-recent-depth)
1852 (progn
1853 ;; Oops, no prefix, zero prefix data:
1854 (allout-prefix-data (point)(point))
1855 ;; ... and return 0:
1856 0)))))
1857 ;;;_ > allout-current-depth ()
1858 (defun allout-current-depth ()
1859 "Return depth of visible topic most immediately containing point.
1860
1861 Return zero if point is not within any topic."
1862 (save-excursion
1863 (if (allout-back-to-current-heading)
1864 (max 1
1865 (- allout-recent-prefix-end
1866 allout-recent-prefix-beginning
1867 allout-header-subtraction))
1868 0)))
1869 ;;;_ > allout-get-current-prefix ()
1870 (defun allout-get-current-prefix ()
1871 "Topic prefix of the current topic."
1872 (save-excursion
1873 (if (allout-goto-prefix)
1874 (allout-recent-prefix))))
1875 ;;;_ > allout-get-bullet ()
1876 (defun allout-get-bullet ()
1877 "Return bullet of containing topic (visible or not)."
1878 (save-excursion
1879 (and (allout-goto-prefix)
1880 (allout-recent-bullet))))
1881 ;;;_ > allout-current-bullet ()
1882 (defun allout-current-bullet ()
1883 "Return bullet of current (visible) topic heading, or none if none found."
1884 (condition-case nil
1885 (save-excursion
1886 (allout-back-to-current-heading)
1887 (buffer-substring (- allout-recent-prefix-end 1)
1888 allout-recent-prefix-end))
1889 ;; Quick and dirty provision, ostensibly for missing bullet:
1890 ('args-out-of-range nil))
1891 )
1892 ;;;_ > allout-get-prefix-bullet (prefix)
1893 (defun allout-get-prefix-bullet (prefix)
1894 "Return the bullet of the header prefix string PREFIX."
1895 ;; Doesn't make sense if we're old-style prefixes, but this just
1896 ;; oughtn't be called then, so forget about it...
1897 (if (string-match allout-regexp prefix)
1898 (substring prefix (1- (match-end 0)) (match-end 0))))
1899 ;;;_ > allout-sibling-index (&optional depth)
1900 (defun allout-sibling-index (&optional depth)
1901 "Item number of this prospective topic among its siblings.
1902
1903 If optional arg DEPTH is greater than current depth, then we're
1904 opening a new level, and return 0.
1905
1906 If less than this depth, ascend to that depth and count..."
1907
1908 (save-excursion
1909 (cond ((and depth (<= depth 0) 0))
1910 ((or (not depth) (= depth (allout-depth)))
1911 (let ((index 1))
1912 (while (allout-previous-sibling (allout-recent-depth) nil)
1913 (setq index (1+ index)))
1914 index))
1915 ((< depth (allout-recent-depth))
1916 (allout-ascend-to-depth depth)
1917 (allout-sibling-index))
1918 (0))))
1919 ;;;_ > allout-topic-flat-index ()
1920 (defun allout-topic-flat-index ()
1921 "Return a list indicating point's numeric section.subsect.subsubsect...
1922 Outermost is first."
1923 (let* ((depth (allout-depth))
1924 (next-index (allout-sibling-index depth))
1925 (rev-sibls nil))
1926 (while (> next-index 0)
1927 (setq rev-sibls (cons next-index rev-sibls))
1928 (setq depth (1- depth))
1929 (setq next-index (allout-sibling-index depth)))
1930 rev-sibls)
1931 )
1932
1933 ;;;_ - Navigation routines
1934 ;;;_ > allout-beginning-of-current-line ()
1935 (defun allout-beginning-of-current-line ()
1936 "Like beginning of line, but to visible text."
1937
1938 ;; XXX We would use `(move-beginning-of-line 1)', but it gets
1939 ;; stuck on some hidden newlines, eg at column 80, as of GNU Emacs 22.0.50.
1940 ;; Conversely, `beginning-of-line' can make no progress in other
1941 ;; situations. Both are necessary, in the order used below.
1942 (move-beginning-of-line 1)
1943 (beginning-of-line)
1944 (while (or (not (bolp)) (allout-hidden-p))
1945 (beginning-of-line)
1946 (if (or (allout-hidden-p) (not (bolp)))
1947 (forward-char -1))))
1948 ;;;_ > allout-end-of-current-line ()
1949 (defun allout-end-of-current-line ()
1950 "Move to the end of line, past concealed text if any."
1951 ;; XXX This is for symmetry with `allout-beginning-of-current-line' -
1952 ;; `move-end-of-line' doesn't suffer the same problem as
1953 ;; `move-beginning-of-line'.
1954 (end-of-line)
1955 (while (allout-hidden-p)
1956 (end-of-line)
1957 (if (allout-hidden-p) (forward-char 1))))
1958 ;;;_ > allout-next-heading ()
1959 (defsubst allout-next-heading ()
1960 "Move to the heading for the topic \(possibly invisible) before this one.
1961
1962 Returns the location of the heading, or nil if none found."
1963
1964 (if (and (bobp) (not (eobp)))
1965 (forward-char 1))
1966
1967 (if (re-search-forward allout-line-boundary-regexp nil 0)
1968 (allout-prefix-data ; Got valid location state - set vars:
1969 (goto-char (or (match-beginning 2)
1970 allout-recent-prefix-beginning))
1971 (or (match-end 2) allout-recent-prefix-end))))
1972 ;;;_ > allout-this-or-next-heading
1973 (defun allout-this-or-next-heading ()
1974 "Position cursor on current or next heading."
1975 ;; A throwaway non-macro that is defined after allout-next-heading
1976 ;; and usable by allout-mode.
1977 (if (not (allout-goto-prefix)) (allout-next-heading)))
1978 ;;;_ > allout-previous-heading ()
1979 (defmacro allout-previous-heading ()
1980 "Move to the prior \(possibly invisible) heading line.
1981
1982 Return the location of the beginning of the heading, or nil if not found."
1983
1984 '(if (bobp)
1985 nil
1986 (allout-goto-prefix)
1987 (if
1988 ;; searches are unbounded and return nil if failed:
1989 (or (re-search-backward allout-line-boundary-regexp nil 0)
1990 (looking-at allout-bob-regexp))
1991 (progn ; Got valid location state - set vars:
1992 (allout-prefix-data
1993 (goto-char (or (match-beginning 2)
1994 allout-recent-prefix-beginning))
1995 (or (match-end 2) allout-recent-prefix-end))))))
1996 ;;;_ > allout-get-invisibility-overlay ()
1997 (defun allout-get-invisibility-overlay ()
1998 "Return the overlay at point that dictates allout invisibility."
1999 (let ((overlays (overlays-at (point)))
2000 got)
2001 (while (and overlays (not got))
2002 (if (equal (overlay-get (car overlays) 'invisible) 'allout)
2003 (setq got (car overlays))))
2004 got))
2005 ;;;_ > allout-back-to-visible-text ()
2006 (defun allout-back-to-visible-text ()
2007 "Move to most recent prior character that is visible, and return point."
2008 (if (allout-hidden-p)
2009 (goto-char (overlay-start (allout-get-invisibility-overlay))))
2010 (point))
2011
2012 ;;;_ - Subtree Charting
2013 ;;;_ " These routines either produce or assess charts, which are
2014 ;;; nested lists of the locations of topics within a subtree.
2015 ;;;
2016 ;;; Use of charts enables efficient navigation of subtrees, by
2017 ;;; requiring only a single regexp-search based traversal, to scope
2018 ;;; out the subtopic locations. The chart then serves as the basis
2019 ;;; for assessment or adjustment of the subtree, without redundant
2020 ;;; traversal of the structure.
2021
2022 ;;;_ > allout-chart-subtree (&optional levels orig-depth prev-depth)
2023 (defun allout-chart-subtree (&optional levels orig-depth prev-depth)
2024 "Produce a location \"chart\" of subtopics of the containing topic.
2025
2026 Optional argument LEVELS specifies the depth \(relative to start
2027 depth) for the chart. Subsequent optional args are not for public
2028 use.
2029
2030 Point is left at the end of the subtree.
2031
2032 Charts are used to capture outline structure, so that outline-altering
2033 routines need assess the structure only once, and then use the chart
2034 for their elaborate manipulations.
2035
2036 Topics are entered in the chart so the last one is at the car.
2037 The entry for each topic consists of an integer indicating the point
2038 at the beginning of the topic. Charts for offspring consists of a
2039 list containing, recursively, the charts for the respective subtopics.
2040 The chart for a topics' offspring precedes the entry for the topic
2041 itself.
2042
2043 The other function parameters are for internal recursion, and should
2044 not be specified by external callers. ORIG-DEPTH is depth of topic at
2045 starting point, and PREV-DEPTH is depth of prior topic."
2046
2047 (let ((original (not orig-depth)) ; `orig-depth' set only in recursion.
2048 chart curr-depth)
2049
2050 (if original ; Just starting?
2051 ; Register initial settings and
2052 ; position to first offspring:
2053 (progn (setq orig-depth (allout-depth))
2054 (or prev-depth (setq prev-depth (1+ orig-depth)))
2055 (allout-next-heading)))
2056
2057 ;; Loop over the current levels' siblings. Besides being more
2058 ;; efficient than tail-recursing over a level, it avoids exceeding
2059 ;; the typically quite constrained Emacs max-lisp-eval-depth.
2060 ;;
2061 ;; Probably would speed things up to implement loop-based stack
2062 ;; operation rather than recursing for lower levels. Bah.
2063
2064 (while (and (not (eobp))
2065 ; Still within original topic?
2066 (< orig-depth (setq curr-depth (allout-recent-depth)))
2067 (cond ((= prev-depth curr-depth)
2068 ;; Register this one and move on:
2069 (setq chart (cons (point) chart))
2070 (if (and levels (<= levels 1))
2071 ;; At depth limit - skip sublevels:
2072 (or (allout-next-sibling curr-depth)
2073 ;; or no more siblings - proceed to
2074 ;; next heading at lesser depth:
2075 (while (and (<= curr-depth
2076 (allout-recent-depth))
2077 (allout-next-heading))))
2078 (allout-next-heading)))
2079
2080 ((and (< prev-depth curr-depth)
2081 (or (not levels)
2082 (> levels 0)))
2083 ;; Recurse on deeper level of curr topic:
2084 (setq chart
2085 (cons (allout-chart-subtree (and levels
2086 (1- levels))
2087 orig-depth
2088 curr-depth)
2089 chart))
2090 ;; ... then continue with this one.
2091 )
2092
2093 ;; ... else nil if we've ascended back to prev-depth.
2094
2095 )))
2096
2097 (if original ; We're at the last sibling on
2098 ; the original level. Position
2099 ; to the end of it:
2100 (progn (and (not (eobp)) (forward-char -1))
2101 (and (= (preceding-char) ?\n)
2102 (= (aref (buffer-substring (max 1 (- (point) 3))
2103 (point))
2104 1)
2105 ?\n)
2106 (forward-char -1))
2107 (setq allout-recent-end-of-subtree (point))))
2108
2109 chart ; (nreverse chart) not necessary,
2110 ; and maybe not preferable.
2111 ))
2112 ;;;_ > allout-chart-siblings (&optional start end)
2113 (defun allout-chart-siblings (&optional start end)
2114 "Produce a list of locations of this and succeeding sibling topics.
2115 Effectively a top-level chart of siblings. See `allout-chart-subtree'
2116 for an explanation of charts."
2117 (save-excursion
2118 (if (allout-goto-prefix)
2119 (let ((chart (list (point))))
2120 (while (allout-next-sibling)
2121 (setq chart (cons (point) chart)))
2122 (if chart (setq chart (nreverse chart)))))))
2123 ;;;_ > allout-chart-to-reveal (chart depth)
2124 (defun allout-chart-to-reveal (chart depth)
2125
2126 "Return a flat list of hidden points in subtree CHART, up to DEPTH.
2127
2128 Note that point can be left at any of the points on chart, or at the
2129 start point."
2130
2131 (let (result here)
2132 (while (and (or (eq depth t) (> depth 0))
2133 chart)
2134 (setq here (car chart))
2135 (if (listp here)
2136 (let ((further (allout-chart-to-reveal here (or (eq depth t)
2137 (1- depth)))))
2138 ;; We're on the start of a subtree - recurse with it, if there's
2139 ;; more depth to go:
2140 (if further (setq result (append further result)))
2141 (setq chart (cdr chart)))
2142 (goto-char here)
2143 (if (allout-hidden-p)
2144 (setq result (cons here result)))
2145 (setq chart (cdr chart))))
2146 result))
2147 ;;;_ X allout-chart-spec (chart spec &optional exposing)
2148 ;; (defun allout-chart-spec (chart spec &optional exposing)
2149 ;; "Not yet \(if ever) implemented.
2150
2151 ;; Produce exposure directives given topic/subtree CHART and an exposure SPEC.
2152
2153 ;; Exposure spec indicates the locations to be exposed and the prescribed
2154 ;; exposure status. Optional arg EXPOSING is an integer, with 0
2155 ;; indicating pending concealment, anything higher indicating depth to
2156 ;; which subtopic headers should be exposed, and negative numbers
2157 ;; indicating (negative of) the depth to which subtopic headers and
2158 ;; bodies should be exposed.
2159
2160 ;; The produced list can have two types of entries. Bare numbers
2161 ;; indicate points in the buffer where topic headers that should be
2162 ;; exposed reside.
2163
2164 ;; - bare negative numbers indicates that the topic starting at the
2165 ;; point which is the negative of the number should be opened,
2166 ;; including their entries.
2167 ;; - bare positive values indicate that this topic header should be
2168 ;; opened.
2169 ;; - Lists signify the beginning and end points of regions that should
2170 ;; be flagged, and the flag to employ. (For concealment: `\(\?r\)', and
2171 ;; exposure:"
2172 ;; (while spec
2173 ;; (cond ((listp spec)
2174 ;; )
2175 ;; )
2176 ;; (setq spec (cdr spec)))
2177 ;; )
2178
2179 ;;;_ - Within Topic
2180 ;;;_ > allout-goto-prefix ()
2181 (defun allout-goto-prefix ()
2182 "Put point at beginning of immediately containing outline topic.
2183
2184 Goes to most immediate subsequent topic if none immediately containing.
2185
2186 Not sensitive to topic visibility.
2187
2188 Returns the point at the beginning of the prefix, or nil if none."
2189
2190 (let (done)
2191 (while (and (not done)
2192 (search-backward "\n" nil 1))
2193 (forward-char 1)
2194 (if (looking-at allout-regexp)
2195 (setq done (allout-prefix-data (match-beginning 0)
2196 (match-end 0)))
2197 (forward-char -1)))
2198 (if (bobp)
2199 (cond ((looking-at allout-regexp)
2200 (allout-prefix-data (match-beginning 0)(match-end 0)))
2201 ((allout-next-heading))
2202 (done))
2203 done)))
2204 ;;;_ > allout-end-of-prefix ()
2205 (defun allout-end-of-prefix (&optional ignore-decorations)
2206 "Position cursor at beginning of header text.
2207
2208 If optional IGNORE-DECORATIONS is non-nil, put just after bullet,
2209 otherwise skip white space between bullet and ensuing text."
2210
2211 (if (not (allout-goto-prefix))
2212 nil
2213 (let ((match-data (match-data)))
2214 (goto-char (match-end 0))
2215 (if ignore-decorations
2216 t
2217 (while (looking-at "[0-9]") (forward-char 1))
2218 (if (and (not (eolp)) (looking-at "\\s-")) (forward-char 1)))
2219 (store-match-data match-data))
2220 ;; Reestablish where we are:
2221 (allout-current-depth)))
2222 ;;;_ > allout-current-bullet-pos ()
2223 (defun allout-current-bullet-pos ()
2224 "Return position of current \(visible) topic's bullet."
2225
2226 (if (not (allout-current-depth))
2227 nil
2228 (1- (match-end 0))))
2229 ;;;_ > allout-back-to-current-heading ()
2230 (defun allout-back-to-current-heading ()
2231 "Move to heading line of current topic, or beginning if already on the line.
2232
2233 Return value of point, unless we started outside of (before any) topics,
2234 in which case we return nil."
2235
2236 (allout-beginning-of-current-line)
2237 (if (or (allout-on-current-heading-p)
2238 (and (re-search-backward (concat "^\\(" allout-regexp "\\)")
2239 nil 'move)
2240 (progn (while (allout-hidden-p)
2241 (allout-beginning-of-current-line)
2242 (if (not (looking-at allout-regexp))
2243 (re-search-backward (concat
2244 "^\\(" allout-regexp "\\)")
2245 nil 'move)))
2246 (allout-prefix-data (match-beginning 1)
2247 (match-end 1)))))
2248 (if (interactive-p)
2249 (allout-end-of-prefix)
2250 (point))))
2251 ;;;_ > allout-back-to-heading ()
2252 (defalias 'allout-back-to-heading 'allout-back-to-current-heading)
2253 ;;;_ > allout-pre-next-prefix ()
2254 (defun allout-pre-next-prefix ()
2255 "Skip forward to just before the next heading line.
2256
2257 Returns that character position."
2258
2259 (if (re-search-forward allout-line-boundary-regexp nil 'move)
2260 (prog1 (goto-char (match-beginning 0))
2261 (allout-prefix-data (match-beginning 2)(match-end 2)))))
2262 ;;;_ > allout-end-of-subtree (&optional current include-trailing-blank)
2263 (defun allout-end-of-subtree (&optional current include-trailing-blank)
2264 "Put point at the end of the last leaf in the containing topic.
2265
2266 Optional CURRENT means put point at the end of the containing
2267 visible topic.
2268
2269 Optional INCLUDE-TRAILING-BLANK means include a trailing blank line, if
2270 any, as part of the subtree. Otherwise, that trailing blank will be
2271 excluded as delimiting whitespace between topics.
2272
2273 Returns the value of point."
2274 (interactive "P")
2275 (if current
2276 (allout-back-to-current-heading)
2277 (allout-goto-prefix))
2278 (let ((level (allout-recent-depth)))
2279 (allout-next-heading)
2280 (while (and (not (eobp))
2281 (> (allout-recent-depth) level))
2282 (allout-next-heading))
2283 (and (not (eobp)) (forward-char -1))
2284 (if (and (not include-trailing-blank) (= ?\n (preceding-char)))
2285 (forward-char -1))
2286 (setq allout-recent-end-of-subtree (point))))
2287 ;;;_ > allout-end-of-current-subtree (&optional include-trailing-blank)
2288 (defun allout-end-of-current-subtree (&optional include-trailing-blank)
2289
2290 "Put point at end of last leaf in currently visible containing topic.
2291
2292 Optional INCLUDE-TRAILING-BLANK means include a trailing blank line, if
2293 any, as part of the subtree. Otherwise, that trailing blank will be
2294 excluded as delimiting whitespace between topics.
2295
2296 Returns the value of point."
2297 (interactive)
2298 (allout-end-of-subtree t include-trailing-blank))
2299 ;;;_ > allout-beginning-of-current-entry ()
2300 (defun allout-beginning-of-current-entry ()
2301 "When not already there, position point at beginning of current topic header.
2302
2303 If already there, move cursor to bullet for hot-spot operation.
2304 \(See `allout-mode' doc string for details of hot-spot operation.)"
2305 (interactive)
2306 (let ((start-point (point)))
2307 (move-beginning-of-line 1)
2308 (allout-end-of-prefix)
2309 (if (and (interactive-p)
2310 (= (point) start-point))
2311 (goto-char (allout-current-bullet-pos)))))
2312 ;;;_ > allout-end-of-entry (&optional inclusive)
2313 (defun allout-end-of-entry (&optional inclusive)
2314 "Position the point at the end of the current topics' entry.
2315
2316 Optional INCLUSIVE means also include trailing empty line, if any. When
2317 unset, whitespace between items separates them even when the items are
2318 collapsed."
2319 (interactive)
2320 (allout-pre-next-prefix)
2321 (if (and (not inclusive) (not (bobp)) (= ?\n (preceding-char)))
2322 (forward-char -1))
2323 (point))
2324 ;;;_ > allout-end-of-current-heading ()
2325 (defun allout-end-of-current-heading ()
2326 (interactive)
2327 (allout-beginning-of-current-entry)
2328 (search-forward "\n" nil t)
2329 (forward-char -1))
2330 (defalias 'allout-end-of-heading 'allout-end-of-current-heading)
2331 ;;;_ > allout-get-body-text ()
2332 (defun allout-get-body-text ()
2333 "Return the unmangled body text of the topic immediately containing point."
2334 (save-excursion
2335 (allout-end-of-prefix)
2336 (if (not (search-forward "\n" nil t))
2337 nil
2338 (backward-char 1)
2339 (let ((pre-body (point)))
2340 (if (not pre-body)
2341 nil
2342 (allout-end-of-entry t)
2343 (if (not (= pre-body (point)))
2344 (buffer-substring-no-properties (1+ pre-body) (point))))
2345 )
2346 )
2347 )
2348 )
2349
2350 ;;;_ - Depth-wise
2351 ;;;_ > allout-ascend-to-depth (depth)
2352 (defun allout-ascend-to-depth (depth)
2353 "Ascend to depth DEPTH, returning depth if successful, nil if not."
2354 (if (and (> depth 0)(<= depth (allout-depth)))
2355 (let ((last-good (point)))
2356 (while (and (< depth (allout-depth))
2357 (setq last-good (point))
2358 (allout-beginning-of-level)
2359 (allout-previous-heading)))
2360 (if (= (allout-recent-depth) depth)
2361 (progn (goto-char allout-recent-prefix-beginning)
2362 depth)
2363 (goto-char last-good)
2364 nil))
2365 (if (interactive-p) (allout-end-of-prefix))))
2366 ;;;_ > allout-ascend ()
2367 (defun allout-ascend ()
2368 "Ascend one level, returning t if successful, nil if not."
2369 (prog1
2370 (if (allout-beginning-of-level)
2371 (allout-previous-heading))
2372 (if (interactive-p) (allout-end-of-prefix))))
2373 ;;;_ > allout-descend-to-depth (depth)
2374 (defun allout-descend-to-depth (depth)
2375 "Descend to depth DEPTH within current topic.
2376
2377 Returning depth if successful, nil if not."
2378 (let ((start-point (point))
2379 (start-depth (allout-depth)))
2380 (while
2381 (and (> (allout-depth) 0)
2382 (not (= depth (allout-recent-depth))) ; ... not there yet
2383 (allout-next-heading) ; ... go further
2384 (< start-depth (allout-recent-depth)))) ; ... still in topic
2385 (if (and (> (allout-depth) 0)
2386 (= (allout-recent-depth) depth))
2387 depth
2388 (goto-char start-point)
2389 nil))
2390 )
2391 ;;;_ > allout-up-current-level (arg &optional dont-complain)
2392 (defun allout-up-current-level (arg &optional dont-complain)
2393 "Move out ARG levels from current visible topic.
2394
2395 Positions on heading line of containing topic. Error if unable to
2396 ascend that far, or nil if unable to ascend but optional arg
2397 DONT-COMPLAIN is non-nil."
2398 (interactive "p")
2399 (allout-back-to-current-heading)
2400 (let ((present-level (allout-recent-depth))
2401 (last-good (point))
2402 failed)
2403 ;; Loop for iterating arg:
2404 (while (and (> (allout-recent-depth) 1)
2405 (> arg 0)
2406 (not (bobp))
2407 (not failed))
2408 (setq last-good (point))
2409 ;; Loop for going back over current or greater depth:
2410 (while (and (not (< (allout-recent-depth) present-level))
2411 (or (allout-previous-visible-heading 1)
2412 (not (setq failed present-level)))))
2413 (setq present-level (allout-current-depth))
2414 (setq arg (- arg 1)))
2415 (if (or failed
2416 (> arg 0))
2417 (progn (goto-char last-good)
2418 (if (interactive-p) (allout-end-of-prefix))
2419 (if (not dont-complain)
2420 (error "Can't ascend past outermost level")
2421 (if (interactive-p) (allout-end-of-prefix))
2422 nil))
2423 (if (interactive-p) (allout-end-of-prefix))
2424 allout-recent-prefix-beginning)))
2425
2426 ;;;_ - Linear
2427 ;;;_ > allout-next-sibling (&optional depth backward)
2428 (defun allout-next-sibling (&optional depth backward)
2429 "Like `allout-forward-current-level', but respects invisible topics.
2430
2431 Traverse at optional DEPTH, or current depth if none specified.
2432
2433 Go backward if optional arg BACKWARD is non-nil.
2434
2435 Return depth if successful, nil otherwise."
2436
2437 (if (and backward (bobp))
2438 nil
2439 (let ((start-depth (or depth (allout-depth)))
2440 (start-point (point))
2441 last-depth)
2442 (while (and (not (if backward (bobp) (eobp)))
2443 (if backward (allout-previous-heading)
2444 (allout-next-heading))
2445 (> (setq last-depth (allout-recent-depth)) start-depth)))
2446 (if (and (not (eobp))
2447 (and (> (or last-depth (allout-depth)) 0)
2448 (= (allout-recent-depth) start-depth)))
2449 allout-recent-prefix-beginning
2450 (goto-char start-point)
2451 (if depth (allout-depth) start-depth)
2452 nil))))
2453 ;;;_ > allout-previous-sibling (&optional depth backward)
2454 (defun allout-previous-sibling (&optional depth backward)
2455 "Like `allout-forward-current-level' backwards, respecting invisible topics.
2456
2457 Optional DEPTH specifies depth to traverse, default current depth.
2458
2459 Optional BACKWARD reverses direction.
2460
2461 Return depth if successful, nil otherwise."
2462 (allout-next-sibling depth (not backward))
2463 )
2464 ;;;_ > allout-snug-back ()
2465 (defun allout-snug-back ()
2466 "Position cursor at end of previous topic.
2467
2468 Presumes point is at the start of a topic prefix."
2469 (if (or (bobp) (eobp))
2470 nil
2471 (forward-char -1))
2472 (if (or (bobp) (not (= ?\n (preceding-char))))
2473 nil
2474 (forward-char -1))
2475 (point))
2476 ;;;_ > allout-beginning-of-level ()
2477 (defun allout-beginning-of-level ()
2478 "Go back to the first sibling at this level, visible or not."
2479 (allout-end-of-level 'backward))
2480 ;;;_ > allout-end-of-level (&optional backward)
2481 (defun allout-end-of-level (&optional backward)
2482 "Go to the last sibling at this level, visible or not."
2483
2484 (let ((depth (allout-depth)))
2485 (while (allout-previous-sibling depth nil))
2486 (prog1 (allout-recent-depth)
2487 (if (interactive-p) (allout-end-of-prefix)))))
2488 ;;;_ > allout-next-visible-heading (arg)
2489 (defun allout-next-visible-heading (arg)
2490 "Move to the next ARG'th visible heading line, backward if arg is negative.
2491
2492 Move to buffer limit in indicated direction if headings are exhausted."
2493
2494 (interactive "p")
2495 (let* ((backward (if (< arg 0) (setq arg (* -1 arg))))
2496 (step (if backward -1 1))
2497 prev got)
2498
2499 (while (> arg 0) ; limit condition
2500 (while (and (not (if backward (bobp)(eobp))) ; boundary condition
2501 ;; Move, skipping over all those concealed lines:
2502 (prog1 (condition-case nil (or (line-move step) t)
2503 (error nil))
2504 (allout-beginning-of-current-line))
2505 (not (setq got (looking-at allout-regexp)))))
2506 ;; Register this got, it may be the last:
2507 (if got (setq prev got))
2508 (setq arg (1- arg)))
2509 (cond (got ; Last move was to a prefix:
2510 (allout-prefix-data (match-beginning 0) (match-end 0))
2511 (allout-end-of-prefix))
2512 (prev ; Last move wasn't, but prev was:
2513 (allout-prefix-data (match-beginning 0) (match-end 0)))
2514 ((not backward) (end-of-line) nil))))
2515 ;;;_ > allout-previous-visible-heading (arg)
2516 (defun allout-previous-visible-heading (arg)
2517 "Move to the previous heading line.
2518
2519 With argument, repeats or can move forward if negative.
2520 A heading line is one that starts with a `*' (or that `allout-regexp'
2521 matches)."
2522 (interactive "p")
2523 (allout-next-visible-heading (- arg)))
2524 ;;;_ > allout-forward-current-level (arg)
2525 (defun allout-forward-current-level (arg)
2526 "Position point at the next heading of the same level.
2527
2528 Takes optional repeat-count, goes backward if count is negative.
2529
2530 Returns resulting position, else nil if none found."
2531 (interactive "p")
2532 (let ((start-depth (allout-current-depth))
2533 (start-arg arg)
2534 (backward (> 0 arg))
2535 last-depth
2536 (last-good (point))
2537 at-boundary)
2538 (if (= 0 start-depth)
2539 (error "No siblings, not in a topic..."))
2540 (if backward (setq arg (* -1 arg)))
2541 (while (not (or (zerop arg)
2542 at-boundary))
2543 (while (and (not (if backward (bobp) (eobp)))
2544 (if backward (allout-previous-visible-heading 1)
2545 (allout-next-visible-heading 1))
2546 (> (setq last-depth (allout-recent-depth)) start-depth)))
2547 (if (and last-depth (= last-depth start-depth)
2548 (not (if backward (bobp) (eobp))))
2549 (setq last-good (point)
2550 arg (1- arg))
2551 (setq at-boundary t)))
2552 (if (and (not (eobp))
2553 (= arg 0)
2554 (and (> (or last-depth (allout-depth)) 0)
2555 (= (allout-recent-depth) start-depth)))
2556 allout-recent-prefix-beginning
2557 (goto-char last-good)
2558 (if (not (interactive-p))
2559 nil
2560 (allout-end-of-prefix)
2561 (error "Hit %s level %d topic, traversed %d of %d requested"
2562 (if backward "first" "last")
2563 (allout-recent-depth)
2564 (- (abs start-arg) arg)
2565 (abs start-arg))))))
2566 ;;;_ > allout-backward-current-level (arg)
2567 (defun allout-backward-current-level (arg)
2568 "Inverse of `allout-forward-current-level'."
2569 (interactive "p")
2570 (if (interactive-p)
2571 (let ((current-prefix-arg (* -1 arg)))
2572 (call-interactively 'allout-forward-current-level))
2573 (allout-forward-current-level (* -1 arg))))
2574
2575 ;;;_ #5 Alteration
2576
2577 ;;;_ - Fundamental
2578 ;;;_ = allout-post-goto-bullet
2579 (defvar allout-post-goto-bullet nil
2580 "Outline internal var, for `allout-pre-command-business' hot-spot operation.
2581
2582 When set, tells post-processing to reposition on topic bullet, and
2583 then unset it. Set by `allout-pre-command-business' when implementing
2584 hot-spot operation, where literal characters typed over a topic bullet
2585 are mapped to the command of the corresponding control-key on the
2586 `allout-mode-map'.")
2587 (make-variable-buffer-local 'allout-post-goto-bullet)
2588 ;;;_ > allout-post-command-business ()
2589 (defun allout-post-command-business ()
2590 "Outline `post-command-hook' function.
2591
2592 - Implement (and clear) `allout-post-goto-bullet', for hot-spot
2593 outline commands.
2594
2595 - Decrypt topic currently being edited if it was encrypted for a save."
2596
2597 ; Apply any external change func:
2598 (if (not (allout-mode-p)) ; In allout-mode.
2599 nil
2600
2601 (if (and (boundp 'allout-after-save-decrypt)
2602 allout-after-save-decrypt)
2603 (allout-after-saves-handler))
2604
2605 ;; Implement -post-goto-bullet, if set:
2606 (if (and allout-post-goto-bullet
2607 (allout-current-bullet-pos))
2608 (progn (goto-char (allout-current-bullet-pos))
2609 (setq allout-post-goto-bullet nil)))
2610 ))
2611 ;;;_ > allout-pre-command-business ()
2612 (defun allout-pre-command-business ()
2613 "Outline `pre-command-hook' function for outline buffers.
2614 Implements special behavior when cursor is on bullet character.
2615
2616 When the cursor is on the bullet character, self-insert characters are
2617 reinterpreted as the corresponding control-character in the
2618 `allout-mode-map'. The `allout-mode' `post-command-hook' insures that
2619 the cursor which has moved as a result of such reinterpretation is
2620 positioned on the bullet character of the destination topic.
2621
2622 The upshot is that you can get easy, single (ie, unmodified) key
2623 outline maneuvering operations by positioning the cursor on the bullet
2624 char. When in this mode you can use regular cursor-positioning
2625 command/keystrokes to relocate the cursor off of a bullet character to
2626 return to regular interpretation of self-insert characters."
2627
2628 (if (not (allout-mode-p))
2629 nil
2630 ;; Hot-spot navigation provisions:
2631 (if (and (eq this-command 'self-insert-command)
2632 (eq (point)(allout-current-bullet-pos)))
2633 (let* ((this-key-num (cond
2634 ((numberp last-command-char)
2635 last-command-char)
2636 ;; Only xemacs has characterp.
2637 ((and (fboundp 'characterp)
2638 (apply 'characterp
2639 (list last-command-char)))
2640 (apply 'char-to-int (list last-command-char)))
2641 (t 0)))
2642 mapped-binding)
2643 (if (zerop this-key-num)
2644 nil
2645 ; Map upper-register literals
2646 ; to lower register:
2647 (if (<= 96 this-key-num)
2648 (setq this-key-num (- this-key-num 32)))
2649 ; Check if we have a literal:
2650 (if (and (<= 64 this-key-num)
2651 (>= 96 this-key-num))
2652 (setq mapped-binding
2653 (lookup-key 'allout-mode-map
2654 (concat allout-command-prefix
2655 (char-to-string (- this-key-num
2656 64))))))
2657 (if mapped-binding
2658 (setq allout-post-goto-bullet t
2659 this-command mapped-binding)))))))
2660 ;;;_ > allout-find-file-hook ()
2661 (defun allout-find-file-hook ()
2662 "Activate `allout-mode' on non-nil `allout-auto-activation', `allout-layout'.
2663
2664 See `allout-init' for setup instructions."
2665 (if (and allout-auto-activation
2666 (not (allout-mode-p))
2667 allout-layout)
2668 (allout-mode t)))
2669
2670 ;;;_ - Topic Format Assessment
2671 ;;;_ > allout-solicit-alternate-bullet (depth &optional current-bullet)
2672 (defun allout-solicit-alternate-bullet (depth &optional current-bullet)
2673
2674 "Prompt for and return a bullet char as an alternative to the current one.
2675
2676 Offer one suitable for current depth DEPTH as default."
2677
2678 (let* ((default-bullet (or (and (stringp current-bullet) current-bullet)
2679 (allout-bullet-for-depth depth)))
2680 (sans-escapes (regexp-sans-escapes allout-bullets-string))
2681 choice)
2682 (save-excursion
2683 (goto-char (allout-current-bullet-pos))
2684 (setq choice (solicit-char-in-string
2685 (format "Select bullet: %s ('%s' default): "
2686 sans-escapes
2687 default-bullet)
2688 sans-escapes
2689 t)))
2690 (message "")
2691 (if (string= choice "") default-bullet choice))
2692 )
2693 ;;;_ > allout-distinctive-bullet (bullet)
2694 (defun allout-distinctive-bullet (bullet)
2695 "True if BULLET is one of those on `allout-distinctive-bullets-string'."
2696 (string-match (regexp-quote bullet) allout-distinctive-bullets-string))
2697 ;;;_ > allout-numbered-type-prefix (&optional prefix)
2698 (defun allout-numbered-type-prefix (&optional prefix)
2699 "True if current header prefix bullet is numbered bullet."
2700 (and allout-numbered-bullet
2701 (string= allout-numbered-bullet
2702 (if prefix
2703 (allout-get-prefix-bullet prefix)
2704 (allout-get-bullet)))))
2705 ;;;_ > allout-encrypted-type-prefix (&optional prefix)
2706 (defun allout-encrypted-type-prefix (&optional prefix)
2707 "True if current header prefix bullet is for an encrypted entry \(body)."
2708 (and allout-topic-encryption-bullet
2709 (string= allout-topic-encryption-bullet
2710 (if prefix
2711 (allout-get-prefix-bullet prefix)
2712 (allout-get-bullet)))))
2713 ;;;_ > allout-bullet-for-depth (&optional depth)
2714 (defun allout-bullet-for-depth (&optional depth)
2715 "Return outline topic bullet suited to optional DEPTH, or current depth."
2716 ;; Find bullet in plain-bullets-string modulo DEPTH.
2717 (if allout-stylish-prefixes
2718 (char-to-string (aref allout-plain-bullets-string
2719 (% (max 0 (- depth 2))
2720 allout-plain-bullets-string-len)))
2721 allout-primary-bullet)
2722 )
2723
2724 ;;;_ - Topic Production
2725 ;;;_ > allout-make-topic-prefix (&optional prior-bullet
2726 (defun allout-make-topic-prefix (&optional prior-bullet
2727 new
2728 depth
2729 solicit
2730 number-control
2731 index)
2732 ;; Depth null means use current depth, non-null means we're either
2733 ;; opening a new topic after current topic, lower or higher, or we're
2734 ;; changing level of current topic.
2735 ;; Solicit dominates specified bullet-char.
2736 ;;;_ . Doc string:
2737 "Generate a topic prefix suitable for optional arg DEPTH, or current depth.
2738
2739 All the arguments are optional.
2740
2741 PRIOR-BULLET indicates the bullet of the prefix being changed, or
2742 nil if none. This bullet may be preserved (other options
2743 notwithstanding) if it is on the `allout-distinctive-bullets-string',
2744 for instance.
2745
2746 Second arg NEW indicates that a new topic is being opened after the
2747 topic at point, if non-nil. Default bullet for new topics, eg, may
2748 be set (contingent to other args) to numbered bullets if previous
2749 sibling is one. The implication otherwise is that the current topic
2750 is being adjusted - shifted or rebulleted - and we don't consider
2751 bullet or previous sibling.
2752
2753 Third arg DEPTH forces the topic prefix to that depth, regardless of
2754 the current topics' depth.
2755
2756 If SOLICIT is non-nil, then the choice of bullet is solicited from
2757 user. If it's a character, then that character is offered as the
2758 default, otherwise the one suited to the context \(according to
2759 distinction or depth) is offered. \(This overrides other options,
2760 including, eg, a distinctive PRIOR-BULLET.) If non-nil, then the
2761 context-specific bullet is used.
2762
2763 Fifth arg, NUMBER-CONTROL, matters only if `allout-numbered-bullet'
2764 is non-nil *and* soliciting was not explicitly invoked. Then
2765 NUMBER-CONTROL non-nil forces prefix to either numbered or
2766 denumbered format, depending on the value of the sixth arg, INDEX.
2767
2768 \(Note that NUMBER-CONTROL does *not* apply to level 1 topics. Sorry...)
2769
2770 If NUMBER-CONTROL is non-nil and sixth arg INDEX is non-nil then
2771 the prefix of the topic is forced to be numbered. Non-nil
2772 NUMBER-CONTROL and nil INDEX forces non-numbered format on the
2773 bullet. Non-nil NUMBER-CONTROL and non-nil, non-number INDEX means
2774 that the index for the numbered prefix will be derived, by counting
2775 siblings back to start of level. If INDEX is a number, then that
2776 number is used as the index for the numbered prefix (allowing, eg,
2777 sequential renumbering to not require this function counting back the
2778 index for each successive sibling)."
2779 ;;;_ . Code:
2780 ;; The options are ordered in likely frequence of use, most common
2781 ;; highest, least lowest. Ie, more likely to be doing prefix
2782 ;; adjustments than soliciting, and yet more than numbering.
2783 ;; Current prefix is least dominant, but most likely to be commonly
2784 ;; specified...
2785
2786 (let* (body
2787 numbering
2788 denumbering
2789 (depth (or depth (allout-depth)))
2790 (header-lead allout-header-prefix)
2791 (bullet-char
2792
2793 ;; Getting value for bullet char is practically the whole job:
2794
2795 (cond
2796 ; Simplest situation - level 1:
2797 ((<= depth 1) (setq header-lead "") allout-primary-bullet)
2798 ; Simple, too: all asterisks:
2799 (allout-old-style-prefixes
2800 ;; Cheat - make body the whole thing, null out header-lead and
2801 ;; bullet-char:
2802 (setq body (make-string depth
2803 (string-to-char allout-primary-bullet)))
2804 (setq header-lead "")
2805 "")
2806
2807 ;; (Neither level 1 nor old-style, so we're space padding.
2808 ;; Sneak it in the condition of the next case, whatever it is.)
2809
2810 ;; Solicitation overrides numbering and other cases:
2811 ((progn (setq body (make-string (- depth 2) ?\ ))
2812 ;; The actual condition:
2813 solicit)
2814 (let* ((got (allout-solicit-alternate-bullet depth solicit)))
2815 ;; Gotta check whether we're numbering and got a numbered bullet:
2816 (setq numbering (and allout-numbered-bullet
2817 (not (and number-control (not index)))
2818 (string= got allout-numbered-bullet)))
2819 ;; Now return what we got, regardless:
2820 got))
2821
2822 ;; Numbering invoked through args:
2823 ((and allout-numbered-bullet number-control)
2824 (if (setq numbering (not (setq denumbering (not index))))
2825 allout-numbered-bullet
2826 (if (and prior-bullet
2827 (not (string= allout-numbered-bullet
2828 prior-bullet)))
2829 prior-bullet
2830 (allout-bullet-for-depth depth))))
2831
2832 ;;; Neither soliciting nor controlled numbering ;;;
2833 ;;; (may be controlled denumbering, tho) ;;;
2834
2835 ;; Check wrt previous sibling:
2836 ((and new ; only check for new prefixes
2837 (<= depth (allout-depth))
2838 allout-numbered-bullet ; ... & numbering enabled
2839 (not denumbering)
2840 (let ((sibling-bullet
2841 (save-excursion
2842 ;; Locate correct sibling:
2843 (or (>= depth (allout-depth))
2844 (allout-ascend-to-depth depth))
2845 (allout-get-bullet))))
2846 (if (and sibling-bullet
2847 (string= allout-numbered-bullet sibling-bullet))
2848 (setq numbering sibling-bullet)))))
2849
2850 ;; Distinctive prior bullet?
2851 ((and prior-bullet
2852 (allout-distinctive-bullet prior-bullet)
2853 ;; Either non-numbered:
2854 (or (not (and allout-numbered-bullet
2855 (string= prior-bullet allout-numbered-bullet)))
2856 ;; or numbered, and not denumbering:
2857 (setq numbering (not denumbering)))
2858 ;; Here 'tis:
2859 prior-bullet))
2860
2861 ;; Else, standard bullet per depth:
2862 ((allout-bullet-for-depth depth)))))
2863
2864 (concat header-lead
2865 body
2866 bullet-char
2867 (if numbering
2868 (format "%d" (cond ((and index (numberp index)) index)
2869 (new (1+ (allout-sibling-index depth)))
2870 ((allout-sibling-index))))))
2871 )
2872 )
2873 ;;;_ > allout-open-topic (relative-depth &optional before offer-recent-bullet)
2874 (defun allout-open-topic (relative-depth &optional before offer-recent-bullet)
2875 "Open a new topic at depth DEPTH.
2876
2877 New topic is situated after current one, unless optional flag BEFORE
2878 is non-nil, or unless current line is completely empty - lacking even
2879 whitespace - in which case open is done on the current line.
2880
2881 When adding an offspring, it will be added immediately after the parent if
2882 the other offspring are exposed, or after the last child if the offspring
2883 are hidden. \(The intervening offspring will be exposed in the latter
2884 case.)
2885
2886 If OFFER-RECENT-BULLET is true, offer to use the bullet of the prior sibling.
2887
2888 Nuances:
2889
2890 - Creation of new topics is with respect to the visible topic
2891 containing the cursor, regardless of intervening concealed ones.
2892
2893 - New headers are generally created after/before the body of a
2894 topic. However, they are created right at cursor location if the
2895 cursor is on a blank line, even if that breaks the current topic
2896 body. This is intentional, to provide a simple means for
2897 deliberately dividing topic bodies.
2898
2899 - Double spacing of topic lists is preserved. Also, the first
2900 level two topic is created double-spaced (and so would be
2901 subsequent siblings, if that's left intact). Otherwise,
2902 single-spacing is used.
2903
2904 - Creation of sibling or nested topics is with respect to the topic
2905 you're starting from, even when creating backwards. This way you
2906 can easily create a sibling in front of the current topic without
2907 having to go to its preceding sibling, and then open forward
2908 from there."
2909
2910 (allout-beginning-of-current-line)
2911 (let* ((depth (+ (allout-current-depth) relative-depth))
2912 (opening-on-blank (if (looking-at "^\$")
2913 (not (setq before nil))))
2914 ;; bunch o vars set while computing ref-topic
2915 opening-numbered
2916 ref-depth
2917 ref-bullet
2918 (ref-topic (save-excursion
2919 (cond ((< relative-depth 0)
2920 (allout-ascend-to-depth depth))
2921 ((>= relative-depth 1) nil)
2922 (t (allout-back-to-current-heading)))
2923 (setq ref-depth (allout-recent-depth))
2924 (setq ref-bullet
2925 (if (> allout-recent-prefix-end 1)
2926 (allout-recent-bullet)
2927 ""))
2928 (setq opening-numbered
2929 (save-excursion
2930 (and allout-numbered-bullet
2931 (or (<= relative-depth 0)
2932 (allout-descend-to-depth depth))
2933 (if (allout-numbered-type-prefix)
2934 allout-numbered-bullet))))
2935 (point)))
2936 dbl-space
2937 doing-beginning)
2938
2939 (if (not opening-on-blank)
2940 ; Positioning and vertical
2941 ; padding - only if not
2942 ; opening-on-blank:
2943 (progn
2944 (goto-char ref-topic)
2945 (setq dbl-space ; Determine double space action:
2946 (or (and (<= relative-depth 0) ; not descending;
2947 (save-excursion
2948 ;; at b-o-b or preceded by a blank line?
2949 (or (> 0 (forward-line -1))
2950 (looking-at "^\\s-*$")
2951 (bobp)))
2952 (save-excursion
2953 ;; succeeded by a blank line?
2954 (allout-end-of-current-subtree)
2955 (looking-at "\n\n")))
2956 (and (= ref-depth 1)
2957 (or before
2958 (= depth 1)
2959 (save-excursion
2960 ;; Don't already have following
2961 ;; vertical padding:
2962 (not (allout-pre-next-prefix)))))))
2963
2964 ;; Position to prior heading, if inserting backwards, and not
2965 ;; going outwards:
2966 (if (and before (>= relative-depth 0))
2967 (progn (allout-back-to-current-heading)
2968 (setq doing-beginning (bobp))
2969 (if (not (bobp))
2970 (allout-previous-heading)))
2971 (if (and before (bobp))
2972 (open-line 1)))
2973
2974 (if (<= relative-depth 0)
2975 ;; Not going inwards, don't snug up:
2976 (if doing-beginning
2977 (if (not dbl-space)
2978 (open-line 1)
2979 (open-line 2))
2980 (if before
2981 (progn (end-of-line)
2982 (allout-pre-next-prefix)
2983 (while (and (= ?\n (following-char))
2984 (save-excursion
2985 (forward-char 1)
2986 (allout-hidden-p)))
2987 (forward-char 1))
2988 (if (not (looking-at "^$"))
2989 (open-line 1)))
2990 (allout-end-of-current-subtree)
2991 (if (looking-at "\n\n") (forward-char 1))))
2992 ;; Going inwards - double-space if first offspring is
2993 ;; double-spaced, otherwise snug up.
2994 (allout-end-of-entry)
2995 (if (eobp)
2996 (newline 1)
2997 (line-move 1))
2998 (allout-beginning-of-current-line)
2999 (backward-char 1)
3000 (if (bolp)
3001 ;; Blank lines between current header body and next
3002 ;; header - get to last substantive (non-white-space)
3003 ;; line in body:
3004 (progn (setq dbl-space t)
3005 (re-search-backward "[^ \t\n]" nil t)))
3006 (if (looking-at "\n\n")
3007 (setq dbl-space t))
3008 (if (save-excursion
3009 (allout-next-heading)
3010 (when (> (allout-recent-depth) ref-depth)
3011 ;; This is an offspring.
3012 (forward-line -1)
3013 (looking-at "^\\s-*$")))
3014 (progn (forward-line 1)
3015 (open-line 1)
3016 (forward-line 1)))
3017 (allout-end-of-current-line))
3018
3019 ;;(if doing-beginning (goto-char doing-beginning))
3020 (if (not (bobp))
3021 ;; We insert a newline char rather than using open-line to
3022 ;; avoid rear-stickiness inheritence of read-only property.
3023 (progn (if (and (not (> depth ref-depth))
3024 (not before))
3025 (open-line 1)
3026 (if (and (not dbl-space) (> depth ref-depth))
3027 (newline 1)
3028 (if dbl-space
3029 (open-line 1)
3030 (if (not before)
3031 (newline 1)))))
3032 (if (and dbl-space (not (> relative-depth 0)))
3033 (newline 1))
3034 (if (and (not (eobp))
3035 (not (bolp)))
3036 (forward-char 1))))
3037 ))
3038 (insert (concat (allout-make-topic-prefix opening-numbered t depth)
3039 " "))
3040
3041 (allout-rebullet-heading (and offer-recent-bullet ref-bullet)
3042 depth nil nil t)
3043 (if (> relative-depth 0)
3044 (save-excursion (goto-char ref-topic)
3045 (allout-show-children)))
3046 (end-of-line)
3047 )
3048 )
3049 ;;;_ > allout-open-subtopic (arg)
3050 (defun allout-open-subtopic (arg)
3051 "Open new topic header at deeper level than the current one.
3052
3053 Negative universal arg means to open deeper, but place the new topic
3054 prior to the current one."
3055 (interactive "p")
3056 (allout-open-topic 1 (> 0 arg) (< 1 arg)))
3057 ;;;_ > allout-open-sibtopic (arg)
3058 (defun allout-open-sibtopic (arg)
3059 "Open new topic header at same level as the current one.
3060
3061 Positive universal arg means to use the bullet of the prior sibling.
3062
3063 Negative universal arg means to place the new topic prior to the current
3064 one."
3065 (interactive "p")
3066 (allout-open-topic 0 (> 0 arg) (not (= 1 arg))))
3067 ;;;_ > allout-open-supertopic (arg)
3068 (defun allout-open-supertopic (arg)
3069 "Open new topic header at shallower level than the current one.
3070
3071 Negative universal arg means to open shallower, but place the new
3072 topic prior to the current one."
3073
3074 (interactive "p")
3075 (allout-open-topic -1 (> 0 arg) (< 1 arg)))
3076
3077 ;;;_ - Outline Alteration
3078 ;;;_ : Topic Modification
3079 ;;;_ = allout-former-auto-filler
3080 (defvar allout-former-auto-filler nil
3081 "Name of modal fill function being wrapped by `allout-auto-fill'.")
3082 ;;;_ > allout-auto-fill ()
3083 (defun allout-auto-fill ()
3084 "`allout-mode' autofill function.
3085
3086 Maintains outline hanging topic indentation if
3087 `allout-use-hanging-indents' is set."
3088 (let ((fill-prefix (if allout-use-hanging-indents
3089 ;; Check for topic header indentation:
3090 (save-excursion
3091 (beginning-of-line)
3092 (if (looking-at allout-regexp)
3093 ;; ... construct indentation to account for
3094 ;; length of topic prefix:
3095 (make-string (progn (allout-end-of-prefix)
3096 (current-column))
3097 ?\ )))))
3098 (use-auto-fill-function (or allout-outside-normal-auto-fill-function
3099 auto-fill-function
3100 'do-auto-fill)))
3101 (if (or allout-former-auto-filler allout-use-hanging-indents)
3102 (funcall use-auto-fill-function))))
3103 ;;;_ > allout-reindent-body (old-depth new-depth &optional number)
3104 (defun allout-reindent-body (old-depth new-depth &optional number)
3105 "Reindent body lines which were indented at OLD-DEPTH to NEW-DEPTH.
3106
3107 Optional arg NUMBER indicates numbering is being added, and it must
3108 be accommodated.
3109
3110 Note that refill of indented paragraphs is not done."
3111
3112 (save-excursion
3113 (allout-end-of-prefix)
3114 (let* ((new-margin (current-column))
3115 excess old-indent-begin old-indent-end
3116 ;; We want the column where the header-prefix text started
3117 ;; *before* the prefix was changed, so we infer it relative
3118 ;; to the new margin and the shift in depth:
3119 (old-margin (+ old-depth (- new-margin new-depth))))
3120
3121 ;; Process lines up to (but excluding) next topic header:
3122 (allout-unprotected
3123 (save-match-data
3124 (while
3125 (and (re-search-forward "\n\\(\\s-*\\)"
3126 nil
3127 t)
3128 ;; Register the indent data, before we reset the
3129 ;; match data with a subsequent `looking-at':
3130 (setq old-indent-begin (match-beginning 1)
3131 old-indent-end (match-end 1))
3132 (not (looking-at allout-regexp)))
3133 (if (> 0 (setq excess (- (- old-indent-end old-indent-begin)
3134 old-margin)))
3135 ;; Text starts left of old margin - don't adjust:
3136 nil
3137 ;; Text was hanging at or right of old left margin -
3138 ;; reindent it, preserving its existing indentation
3139 ;; beyond the old margin:
3140 (delete-region old-indent-begin old-indent-end)
3141 (indent-to (+ new-margin excess (current-column))))))))))
3142 ;;;_ > allout-rebullet-current-heading (arg)
3143 (defun allout-rebullet-current-heading (arg)
3144 "Solicit new bullet for current visible heading."
3145 (interactive "p")
3146 (let ((initial-col (current-column))
3147 (on-bullet (eq (point)(allout-current-bullet-pos)))
3148 (backwards (if (< arg 0)
3149 (setq arg (* arg -1)))))
3150 (while (> arg 0)
3151 (save-excursion (allout-back-to-current-heading)
3152 (allout-end-of-prefix)
3153 (allout-rebullet-heading t ;;; solicit
3154 nil ;;; depth
3155 nil ;;; number-control
3156 nil ;;; index
3157 t)) ;;; do-successors
3158 (setq arg (1- arg))
3159 (if (<= arg 0)
3160 nil
3161 (setq initial-col nil) ; Override positioning back to init col
3162 (if (not backwards)
3163 (allout-next-visible-heading 1)
3164 (allout-goto-prefix)
3165 (allout-next-visible-heading -1))))
3166 (message "Done.")
3167 (cond (on-bullet (goto-char (allout-current-bullet-pos)))
3168 (initial-col (move-to-column initial-col)))))
3169 ;;;_ > allout-rebullet-heading (&optional solicit ...)
3170 (defun allout-rebullet-heading (&optional solicit
3171 new-depth
3172 number-control
3173 index
3174 do-successors)
3175
3176 "Adjust bullet of current topic prefix.
3177
3178 All args are optional.
3179
3180 If SOLICIT is non-nil, then the choice of bullet is solicited from
3181 user. If it's a character, then that character is offered as the
3182 default, otherwise the one suited to the context \(according to
3183 distinction or depth) is offered. If non-nil, then the
3184 context-specific bullet is just used.
3185
3186 Second arg DEPTH forces the topic prefix to that depth, regardless
3187 of the topic's current depth.
3188
3189 Third arg NUMBER-CONTROL can force the prefix to or away from
3190 numbered form. It has effect only if `allout-numbered-bullet' is
3191 non-nil and soliciting was not explicitly invoked (via first arg).
3192 Its effect, numbering or denumbering, then depends on the setting
3193 of the forth arg, INDEX.
3194
3195 If NUMBER-CONTROL is non-nil and forth arg INDEX is nil, then the
3196 prefix of the topic is forced to be non-numbered. Null index and
3197 non-nil NUMBER-CONTROL forces denumbering. Non-nil INDEX (and
3198 non-nil NUMBER-CONTROL) forces a numbered-prefix form. If non-nil
3199 INDEX is a number, then that number is used for the numbered
3200 prefix. Non-nil and non-number means that the index for the
3201 numbered prefix will be derived by allout-make-topic-prefix.
3202
3203 Fifth arg DO-SUCCESSORS t means re-resolve count on succeeding
3204 siblings.
3205
3206 Cf vars `allout-stylish-prefixes', `allout-old-style-prefixes',
3207 and `allout-numbered-bullet', which all affect the behavior of
3208 this function."
3209
3210 (let* ((current-depth (allout-depth))
3211 (new-depth (or new-depth current-depth))
3212 (mb allout-recent-prefix-beginning)
3213 (me allout-recent-prefix-end)
3214 (current-bullet (buffer-substring (- me 1) me))
3215 (new-prefix (allout-make-topic-prefix current-bullet
3216 nil
3217 new-depth
3218 solicit
3219 number-control
3220 index)))
3221
3222 ;; Is new one is identical to old?
3223 (if (and (= current-depth new-depth)
3224 (string= current-bullet
3225 (substring new-prefix (1- (length new-prefix)))))
3226 ;; Nothing to do:
3227 t
3228
3229 ;; New prefix probably different from old:
3230 ; get rid of old one:
3231 (allout-unprotected (delete-region mb me))
3232 (goto-char mb)
3233 ; Dispense with number if
3234 ; numbered-bullet prefix:
3235 (if (and allout-numbered-bullet
3236 (string= allout-numbered-bullet current-bullet)
3237 (looking-at "[0-9]+"))
3238 (allout-unprotected
3239 (delete-region (match-beginning 0)(match-end 0))))
3240
3241 ; Put in new prefix:
3242 (allout-unprotected (insert new-prefix))
3243
3244 ;; Reindent the body if elected, margin changed, and not encrypted body:
3245 (if (and allout-reindent-bodies
3246 (not (= new-depth current-depth))
3247 (not (allout-encrypted-topic-p)))
3248 (allout-reindent-body current-depth new-depth))
3249
3250 ;; Recursively rectify successive siblings of orig topic if
3251 ;; caller elected for it:
3252 (if do-successors
3253 (save-excursion
3254 (while (allout-next-sibling new-depth nil)
3255 (setq index
3256 (cond ((numberp index) (1+ index))
3257 ((not number-control) (allout-sibling-index))))
3258 (if (allout-numbered-type-prefix)
3259 (allout-rebullet-heading nil ;;; solicit
3260 new-depth ;;; new-depth
3261 number-control;;; number-control
3262 index ;;; index
3263 nil))))) ;;;(dont!)do-successors
3264 ) ; (if (and (= current-depth new-depth)...))
3265 ) ; let* ((current-depth (allout-depth))...)
3266 ) ; defun
3267 ;;;_ > allout-rebullet-topic (arg)
3268 (defun allout-rebullet-topic (arg)
3269 "Rebullet the visible topic containing point and all contained subtopics.
3270
3271 Descends into invisible as well as visible topics, however.
3272
3273 With repeat count, shift topic depth by that amount."
3274 (interactive "P")
3275 (let ((start-col (current-column)))
3276 (save-excursion
3277 ;; Normalize arg:
3278 (cond ((null arg) (setq arg 0))
3279 ((listp arg) (setq arg (car arg))))
3280 ;; Fill the user in, in case we're shifting a big topic:
3281 (if (not (zerop arg)) (message "Shifting..."))
3282 (allout-back-to-current-heading)
3283 (if (<= (+ (allout-recent-depth) arg) 0)
3284 (error "Attempt to shift topic below level 1"))
3285 (allout-rebullet-topic-grunt arg)
3286 (if (not (zerop arg)) (message "Shifting... done.")))
3287 (move-to-column (max 0 (+ start-col arg)))))
3288 ;;;_ > allout-rebullet-topic-grunt (&optional relative-depth ...)
3289 (defun allout-rebullet-topic-grunt (&optional relative-depth
3290 starting-depth
3291 starting-point
3292 index
3293 do-successors)
3294 "Like `allout-rebullet-topic', but on nearest containing topic
3295 \(visible or not).
3296
3297 See `allout-rebullet-heading' for rebulleting behavior.
3298
3299 All arguments are optional.
3300
3301 First arg RELATIVE-DEPTH means to shift the depth of the entire
3302 topic that amount.
3303
3304 The rest of the args are for internal recursive use by the function
3305 itself. The are STARTING-DEPTH, STARTING-POINT, and INDEX."
3306
3307 (let* ((relative-depth (or relative-depth 0))
3308 (new-depth (allout-depth))
3309 (starting-depth (or starting-depth new-depth))
3310 (on-starting-call (null starting-point))
3311 (index (or index
3312 ;; Leave index null on starting call, so rebullet-heading
3313 ;; calculates it at what might be new depth:
3314 (and (or (zerop relative-depth)
3315 (not on-starting-call))
3316 (allout-sibling-index))))
3317 (moving-outwards (< 0 relative-depth))
3318 (starting-point (or starting-point (point))))
3319
3320 ;; Sanity check for excessive promotion done only on starting call:
3321 (and on-starting-call
3322 moving-outwards
3323 (> 0 (+ starting-depth relative-depth))
3324 (error "Attempt to shift topic out beyond level 1")) ;;; ====>
3325
3326 (cond ((= starting-depth new-depth)
3327 ;; We're at depth to work on this one:
3328 (allout-rebullet-heading nil ;;; solicit
3329 (+ starting-depth ;;; starting-depth
3330 relative-depth)
3331 nil ;;; number
3332 index ;;; index
3333 ;; Every contained topic will get hit,
3334 ;; and we have to get to outside ones
3335 ;; deliberately:
3336 nil) ;;; do-successors
3337 ;; ... and work on subsequent ones which are at greater depth:
3338 (setq index 0)
3339 (allout-next-heading)
3340 (while (and (not (eobp))
3341 (< starting-depth (allout-recent-depth)))
3342 (setq index (1+ index))
3343 (allout-rebullet-topic-grunt relative-depth ;;; relative-depth
3344 (1+ starting-depth);;;starting-depth
3345 starting-point ;;; starting-point
3346 index))) ;;; index
3347
3348 ((< starting-depth new-depth)
3349 ;; Rare case - subtopic more than one level deeper than parent.
3350 ;; Treat this one at an even deeper level:
3351 (allout-rebullet-topic-grunt relative-depth ;;; relative-depth
3352 new-depth ;;; starting-depth
3353 starting-point ;;; starting-point
3354 index))) ;;; index
3355
3356 (if on-starting-call
3357 (progn
3358 ;; Rectify numbering of former siblings of the adjusted topic,
3359 ;; if topic has changed depth
3360 (if (or do-successors
3361 (and (not (zerop relative-depth))
3362 (or (= (allout-recent-depth) starting-depth)
3363 (= (allout-recent-depth) (+ starting-depth
3364 relative-depth)))))
3365 (allout-rebullet-heading nil nil nil nil t))
3366 ;; Now rectify numbering of new siblings of the adjusted topic,
3367 ;; if depth has been changed:
3368 (progn (goto-char starting-point)
3369 (if (not (zerop relative-depth))
3370 (allout-rebullet-heading nil nil nil nil t)))))
3371 )
3372 )
3373 ;;;_ > allout-renumber-to-depth (&optional depth)
3374 (defun allout-renumber-to-depth (&optional depth)
3375 "Renumber siblings at current depth.
3376
3377 Affects superior topics if optional arg DEPTH is less than current depth.
3378
3379 Returns final depth."
3380
3381 ;; Proceed by level, processing subsequent siblings on each,
3382 ;; ascending until we get shallower than the start depth:
3383
3384 (let ((ascender (allout-depth))
3385 was-eobp)
3386 (while (and (not (eobp))
3387 (allout-depth)
3388 (>= (allout-recent-depth) depth)
3389 (>= ascender depth))
3390 ; Skip over all topics at
3391 ; lesser depths, which can not
3392 ; have been disturbed:
3393 (while (and (not (setq was-eobp (eobp)))
3394 (> (allout-recent-depth) ascender))
3395 (allout-next-heading))
3396 ; Prime ascender for ascension:
3397 (setq ascender (1- (allout-recent-depth)))
3398 (if (>= (allout-recent-depth) depth)
3399 (allout-rebullet-heading nil ;;; solicit
3400 nil ;;; depth
3401 nil ;;; number-control
3402 nil ;;; index
3403 t)) ;;; do-successors
3404 (if was-eobp (goto-char (point-max)))))
3405 (allout-recent-depth))
3406 ;;;_ > allout-number-siblings (&optional denumber)
3407 (defun allout-number-siblings (&optional denumber)
3408 "Assign numbered topic prefix to this topic and its siblings.
3409
3410 With universal argument, denumber - assign default bullet to this
3411 topic and its siblings.
3412
3413 With repeated universal argument (`^U^U'), solicit bullet for each
3414 rebulleting each topic at this level."
3415
3416 (interactive "P")
3417
3418 (save-excursion
3419 (allout-back-to-current-heading)
3420 (allout-beginning-of-level)
3421 (let ((depth (allout-recent-depth))
3422 (index (if (not denumber) 1))
3423 (use-bullet (equal '(16) denumber))
3424 (more t))
3425 (while more
3426 (allout-rebullet-heading use-bullet ;;; solicit
3427 depth ;;; depth
3428 t ;;; number-control
3429 index ;;; index
3430 nil) ;;; do-successors
3431 (if index (setq index (1+ index)))
3432 (setq more (allout-next-sibling depth nil))))))
3433 ;;;_ > allout-shift-in (arg)
3434 (defun allout-shift-in (arg)
3435 "Increase depth of current heading and any topics collapsed within it.
3436
3437 We disallow shifts that would result in the topic having a depth more than
3438 one level greater than the immediately previous topic, to avoid containment
3439 discontinuity. The first topic in the file can be adjusted to any positive
3440 depth, however."
3441 (interactive "p")
3442 (if (> arg 0)
3443 (save-excursion
3444 (allout-back-to-current-heading)
3445 (if (not (bobp))
3446 (let* ((current-depth (allout-recent-depth))
3447 (start-point (point))
3448 (predecessor-depth (progn
3449 (forward-char -1)
3450 (allout-goto-prefix)
3451 (if (< (point) start-point)
3452 (allout-recent-depth)
3453 0))))
3454 (if (and (> predecessor-depth 0)
3455 (> (+ current-depth arg)
3456 (1+ predecessor-depth)))
3457 (error (concat "Disallowed shift deeper than"
3458 " containing topic's children.")))))))
3459 (allout-rebullet-topic arg))
3460 ;;;_ > allout-shift-out (arg)
3461 (defun allout-shift-out (arg)
3462 "Decrease depth of current heading and any topics collapsed within it.
3463
3464 We disallow shifts that would result in the topic having a depth more than
3465 one level greater than the immediately previous topic, to avoid containment
3466 discontinuity. The first topic in the file can be adjusted to any positive
3467 depth, however."
3468 (interactive "p")
3469 (if (< arg 0)
3470 (allout-shift-in (* arg -1)))
3471 (allout-rebullet-topic (* arg -1)))
3472 ;;;_ : Surgery (kill-ring) functions with special provisions for outlines:
3473 ;;;_ > allout-kill-line (&optional arg)
3474 (defun allout-kill-line (&optional arg)
3475 "Kill line, adjusting subsequent lines suitably for outline mode."
3476
3477 (interactive "*P")
3478
3479 (if (or (not (allout-mode-p))
3480 (not (bolp))
3481 (not (looking-at allout-regexp)))
3482 ;; Just do a regular kill:
3483 (kill-line arg)
3484 ;; Ah, have to watch out for adjustments:
3485 (let* ((beg (point))
3486 (beg-hidden (allout-hidden-p))
3487 (end-hidden (save-excursion (allout-end-of-current-line)
3488 (allout-hidden-p)))
3489 (depth (allout-depth))
3490 (collapsed (allout-current-topic-collapsed-p)))
3491
3492 (if collapsed
3493 (put-text-property beg (1+ beg) 'allout-was-collapsed t)
3494 (remove-text-properties beg (1+ beg) '(allout-was-collapsed t)))
3495
3496 (if (and (not beg-hidden) (not end-hidden))
3497 (allout-unprotected (kill-line arg))
3498 (kill-line arg))
3499 ; Provide some feedback:
3500 (sit-for 0)
3501 (if allout-numbered-bullet
3502 (save-excursion ; Renumber subsequent topics if needed:
3503 (if (not (looking-at allout-regexp))
3504 (allout-next-heading))
3505 (allout-renumber-to-depth depth))))))
3506 ;;;_ > allout-kill-topic ()
3507 (defun allout-kill-topic ()
3508 "Kill topic together with subtopics.
3509
3510 Trailing whitespace is killed with a topic if that whitespace:
3511
3512 - would separate the topic from a subsequent sibling
3513 - would separate the topic from the end of buffer
3514 - would not be added to whitespace already separating the topic from the
3515 previous one.
3516
3517 Completely collapsed topics are marked as such, for re-collapse
3518 when yank with allout-yank into an outline as a heading."
3519
3520 ;; Some finagling is done to make complex topic kills appear faster
3521 ;; than they actually are. A redisplay is performed immediately
3522 ;; after the region is deleted, though the renumbering process
3523 ;; has yet to be performed. This means that there may appear to be
3524 ;; a lag *after* a kill has been performed.
3525
3526 (interactive)
3527 (let* ((collapsed (allout-current-topic-collapsed-p))
3528 (beg (prog1 (allout-back-to-current-heading) (beginning-of-line)))
3529 (depth (allout-recent-depth)))
3530 (allout-end-of-current-subtree)
3531 (if (and (/= (current-column) 0) (not (eobp)))
3532 (forward-char 1))
3533 (if (not (eobp))
3534 (if (and (looking-at "\n")
3535 (or (save-excursion
3536 (or (not (allout-next-heading))
3537 (= depth (allout-recent-depth))))
3538 (and (> (- beg (point-min)) 3)
3539 (string= (buffer-substring (- beg 2) beg) "\n\n"))))
3540 (forward-char 1)))
3541
3542 (if collapsed
3543 (put-text-property beg (1+ beg) 'allout-was-collapsed t)
3544 (remove-text-properties beg (1+ beg) '(allout-was-collapsed t)))
3545 (allout-unprotected (kill-region beg (point)))
3546 (sit-for 0)
3547 (save-excursion
3548 (allout-renumber-to-depth depth))))
3549 ;;;_ > allout-yank-processing ()
3550 (defun allout-yank-processing (&optional arg)
3551
3552 "Incidental allout-specific business to be done just after text yanks.
3553
3554 Does depth adjustment of yanked topics, when:
3555
3556 1 the stuff being yanked starts with a valid outline header prefix, and
3557 2 it is being yanked at the end of a line which consists of only a valid
3558 topic prefix.
3559
3560 Also, adjusts numbering of subsequent siblings when appropriate.
3561
3562 Depth adjustment alters the depth of all the topics being yanked
3563 the amount it takes to make the first topic have the depth of the
3564 header into which it's being yanked.
3565
3566 The point is left in front of yanked, adjusted topics, rather than
3567 at the end (and vice-versa with the mark). Non-adjusted yanks,
3568 however, are left exactly like normal, non-allout-specific yanks."
3569
3570 (interactive "*P")
3571 ; Get to beginning, leaving
3572 ; region around subject:
3573 (if (< (allout-mark-marker t) (point))
3574 (exchange-point-and-mark))
3575 (let* ((subj-beg (point))
3576 (into-bol (bolp))
3577 (subj-end (allout-mark-marker t))
3578 (was-collapsed (get-text-property subj-beg 'allout-was-collapsed))
3579 ;; 'resituate' if yanking an entire topic into topic header:
3580 (resituate (and (allout-e-o-prefix-p)
3581 (looking-at (concat "\\(" allout-regexp "\\)"))
3582 (allout-prefix-data (match-beginning 1)
3583 (match-end 1))))
3584 ;; `rectify-numbering' if resituating (where several topics may
3585 ;; be resituating) or yanking a topic into a topic slot (bol):
3586 (rectify-numbering (or resituate
3587 (and into-bol (looking-at allout-regexp)))))
3588 (if resituate
3589 ; The yanked stuff is a topic:
3590 (let* ((prefix-len (- (match-end 1) subj-beg))
3591 (subj-depth (allout-recent-depth))
3592 (prefix-bullet (allout-recent-bullet))
3593 (adjust-to-depth
3594 ;; Nil if adjustment unnecessary, otherwise depth to which
3595 ;; adjustment should be made:
3596 (save-excursion
3597 (and (goto-char subj-end)
3598 (eolp)
3599 (goto-char subj-beg)
3600 (and (looking-at allout-regexp)
3601 (progn
3602 (beginning-of-line)
3603 (not (= (point) subj-beg)))
3604 (looking-at allout-regexp)
3605 (allout-prefix-data (match-beginning 0)
3606 (match-end 0)))
3607 (allout-recent-depth))))
3608 (more t))
3609 (setq rectify-numbering allout-numbered-bullet)
3610 (if adjust-to-depth
3611 ; Do the adjustment:
3612 (progn
3613 (message "... yanking") (sit-for 0)
3614 (save-restriction
3615 (narrow-to-region subj-beg subj-end)
3616 ; Trim off excessive blank
3617 ; line at end, if any:
3618 (goto-char (point-max))
3619 (if (looking-at "^$")
3620 (allout-unprotected (delete-char -1)))
3621 ; Work backwards, with each
3622 ; shallowest level,
3623 ; successively excluding the
3624 ; last processed topic from
3625 ; the narrow region:
3626 (while more
3627 (allout-back-to-current-heading)
3628 ; go as high as we can in each bunch:
3629 (while (allout-ascend-to-depth (1- (allout-depth))))
3630 (save-excursion
3631 (allout-rebullet-topic-grunt (- adjust-to-depth
3632 subj-depth))
3633 (allout-depth))
3634 (if (setq more (not (bobp)))
3635 (progn (widen)
3636 (forward-char -1)
3637 (narrow-to-region subj-beg (point))))))
3638 (message "")
3639 ;; Preserve new bullet if it's a distinctive one, otherwise
3640 ;; use old one:
3641 (if (string-match (regexp-quote prefix-bullet)
3642 allout-distinctive-bullets-string)
3643 ; Delete from bullet of old to
3644 ; before bullet of new:
3645 (progn
3646 (beginning-of-line)
3647 (delete-region (point) subj-beg)
3648 (set-marker (allout-mark-marker t) subj-end)
3649 (goto-char subj-beg)
3650 (allout-end-of-prefix))
3651 ; Delete base subj prefix,
3652 ; leaving old one:
3653 (delete-region (point) (+ (point)
3654 prefix-len
3655 (- adjust-to-depth subj-depth)))
3656 ; and delete residual subj
3657 ; prefix digits and space:
3658 (while (looking-at "[0-9]") (delete-char 1))
3659 (if (looking-at " ") (delete-char 1))))
3660 (exchange-point-and-mark))))
3661 (if rectify-numbering
3662 (progn
3663 (save-excursion
3664 ; Give some preliminary feedback:
3665 (message "... reconciling numbers") (sit-for 0)
3666 ; ... and renumber, in case necessary:
3667 (goto-char subj-beg)
3668 (if (allout-goto-prefix)
3669 (allout-rebullet-heading nil ;;; solicit
3670 (allout-depth) ;;; depth
3671 nil ;;; number-control
3672 nil ;;; index
3673 t))
3674 (message ""))))
3675 (when (and (or into-bol resituate) was-collapsed)
3676 (remove-text-properties subj-beg (1+ subj-beg) '(allout-was-collapsed))
3677 (allout-hide-current-subtree))
3678 (if (not resituate)
3679 (exchange-point-and-mark))))
3680 ;;;_ > allout-yank (&optional arg)
3681 (defun allout-yank (&optional arg)
3682 "`allout-mode' yank, with depth and numbering adjustment of yanked topics.
3683
3684 Non-topic yanks work no differently than normal yanks.
3685
3686 If a topic is being yanked into a bare topic prefix, the depth of the
3687 yanked topic is adjusted to the depth of the topic prefix.
3688
3689 1 we're yanking in an `allout-mode' buffer
3690 2 the stuff being yanked starts with a valid outline header prefix, and
3691 3 it is being yanked at the end of a line which consists of only a valid
3692 topic prefix.
3693
3694 If these conditions hold then the depth of the yanked topics are all
3695 adjusted the amount it takes to make the first one at the depth of the
3696 header into which it's being yanked.
3697
3698 The point is left in front of yanked, adjusted topics, rather than
3699 at the end (and vice-versa with the mark). Non-adjusted yanks,
3700 however, (ones that don't qualify for adjustment) are handled
3701 exactly like normal yanks.
3702
3703 Numbering of yanked topics, and the successive siblings at the depth
3704 into which they're being yanked, is adjusted.
3705
3706 `allout-yank-pop' works with `allout-yank' just like normal `yank-pop'
3707 works with normal `yank' in non-outline buffers."
3708
3709 (interactive "*P")
3710 (setq this-command 'yank)
3711 (yank arg)
3712 (if (allout-mode-p)
3713 (allout-yank-processing))
3714 )
3715 ;;;_ > allout-yank-pop (&optional arg)
3716 (defun allout-yank-pop (&optional arg)
3717 "Yank-pop like `allout-yank' when popping to bare outline prefixes.
3718
3719 Adapts level of popped topics to level of fresh prefix.
3720
3721 Note - prefix changes to distinctive bullets will stick, if followed
3722 by pops to non-distinctive yanks. Bug..."
3723
3724 (interactive "*p")
3725 (setq this-command 'yank)
3726 (yank-pop arg)
3727 (if (allout-mode-p)
3728 (allout-yank-processing)))
3729
3730 ;;;_ - Specialty bullet functions
3731 ;;;_ : File Cross references
3732 ;;;_ > allout-resolve-xref ()
3733 (defun allout-resolve-xref ()
3734 "Pop to file associated with current heading, if it has an xref bullet.
3735
3736 \(Works according to setting of `allout-file-xref-bullet')."
3737 (interactive)
3738 (if (not allout-file-xref-bullet)
3739 (error
3740 "Outline cross references disabled - no `allout-file-xref-bullet'")
3741 (if (not (string= (allout-current-bullet) allout-file-xref-bullet))
3742 (error "Current heading lacks cross-reference bullet `%s'"
3743 allout-file-xref-bullet)
3744 (let (file-name)
3745 (save-excursion
3746 (let* ((text-start allout-recent-prefix-end)
3747 (heading-end (progn (end-of-line) (point))))
3748 (goto-char text-start)
3749 (setq file-name
3750 (if (re-search-forward "\\s-\\(\\S-*\\)" heading-end t)
3751 (buffer-substring (match-beginning 1) (match-end 1))))))
3752 (setq file-name (expand-file-name file-name))
3753 (if (or (file-exists-p file-name)
3754 (if (file-writable-p file-name)
3755 (y-or-n-p (format "%s not there, create one? "
3756 file-name))
3757 (error "%s not found and can't be created" file-name)))
3758 (condition-case failure
3759 (find-file-other-window file-name)
3760 ('error failure))
3761 (error "%s not found" file-name))
3762 )
3763 )
3764 )
3765 )
3766
3767 ;;;_ #6 Exposure Control
3768
3769 ;;;_ - Fundamental
3770 ;;;_ > allout-flag-region (from to flag)
3771 (defun allout-flag-region (from to flag)
3772 "Conceal text from FROM to TO if FLAG is non-nil, else reveal it.
3773
3774 Text is shown if flag is nil and hidden otherwise."
3775 ;; We use outline invisibility spec.
3776 (remove-overlays from to 'category 'allout-overlay-category)
3777 (when flag
3778 (let ((o (make-overlay from to)))
3779 (overlay-put o 'category 'allout-overlay-category)
3780 (when (featurep 'xemacs)
3781 (let ((props (symbol-plist 'allout-overlay-category)))
3782 (while props
3783 (overlay-put o (pop props) (pop props)))))))
3784 (run-hooks 'allout-view-change-hook))
3785 ;;;_ > allout-flag-current-subtree (flag)
3786 (defun allout-flag-current-subtree (flag)
3787 "Conceal currently-visible topic's subtree if FLAG non-nil, else reveal it."
3788
3789 (save-excursion
3790 (allout-back-to-current-heading)
3791 (end-of-line)
3792 (allout-flag-region (point)
3793 ;; Exposing must not leave trailing blanks hidden,
3794 ;; but can leave them exposed when hiding, so we
3795 ;; can use flag's inverse as the
3796 ;; include-trailing-blank cue:
3797 (allout-end-of-current-subtree (not flag))
3798 flag)))
3799
3800 ;;;_ - Topic-specific
3801 ;;;_ > allout-show-entry (&optional inclusive)
3802 (defun allout-show-entry (&optional inclusive)
3803 "Like `allout-show-current-entry', reveals entries nested in hidden topics.
3804
3805 This is a way to give restricted peek at a concealed locality without the
3806 expense of exposing its context, but can leave the outline with aberrant
3807 exposure. `allout-show-offshoot' should be used after the peek to rectify
3808 the exposure."
3809
3810 (interactive)
3811 (save-excursion
3812 (let (beg end)
3813 (allout-goto-prefix)
3814 (setq beg (if (allout-hidden-p) (1- (point)) (point)))
3815 (setq end (allout-pre-next-prefix))
3816 (allout-flag-region beg end nil)
3817 (list beg end))))
3818 ;;;_ > allout-show-children (&optional level strict)
3819 (defun allout-show-children (&optional level strict)
3820
3821 "If point is visible, show all direct subheadings of this heading.
3822
3823 Otherwise, do `allout-show-to-offshoot', and then show subheadings.
3824
3825 Optional LEVEL specifies how many levels below the current level
3826 should be shown, or all levels if t. Default is 1.
3827
3828 Optional STRICT means don't resort to -show-to-offshoot, no matter
3829 what. This is basically so -show-to-offshoot, which is called by
3830 this function, can employ the pure offspring-revealing capabilities of
3831 it.
3832
3833 Returns point at end of subtree that was opened, if any. (May get a
3834 point of non-opened subtree?)"
3835
3836 (interactive "p")
3837 (let ((start-point (point)))
3838 (if (and (not strict)
3839 (allout-hidden-p))
3840
3841 (progn (allout-show-to-offshoot) ; Point's concealed, open to
3842 ; expose it.
3843 ;; Then recurse, but with "strict" set so we don't
3844 ;; infinite regress:
3845 (allout-show-children level t))
3846
3847 (save-excursion
3848 (allout-beginning-of-current-line)
3849 (save-restriction
3850 (let* ((chart (allout-chart-subtree (or level 1)))
3851 (to-reveal (allout-chart-to-reveal chart (or level 1))))
3852 (goto-char start-point)
3853 (when (and strict (allout-hidden-p))
3854 ;; Concealed root would already have been taken care of,
3855 ;; unless strict was set.
3856 (allout-flag-region (point) (allout-snug-back) nil)
3857 (when allout-show-bodies
3858 (goto-char (car to-reveal))
3859 (allout-show-current-entry)))
3860 (while to-reveal
3861 (goto-char (car to-reveal))
3862 (allout-flag-region (save-excursion (allout-snug-back) (point))
3863 (progn (search-forward "\n" nil t)
3864 (1- (point)))
3865 nil)
3866 (when allout-show-bodies
3867 (goto-char (car to-reveal))
3868 (allout-show-current-entry))
3869 (setq to-reveal (cdr to-reveal)))))))
3870 ;; Compensate for `save-excursion's maintenance of point
3871 ;; within invisible text:
3872 (goto-char start-point)))
3873 ;;;_ > allout-show-to-offshoot ()
3874 (defun allout-show-to-offshoot ()
3875 "Like `allout-show-entry', but reveals all concealed ancestors, as well.
3876
3877 Useful for coherently exposing to a random point in a hidden region."
3878 (interactive)
3879 (save-excursion
3880 (let ((orig-pt (point))
3881 (orig-pref (allout-goto-prefix))
3882 (last-at (point))
3883 bag-it)
3884 (while (or bag-it (allout-hidden-p))
3885 (while (allout-hidden-p)
3886 ;; XXX We would use `(move-beginning-of-line 1)', but it gets
3887 ;; stuck on hidden newlines at column 80, as of GNU Emacs 22.0.50.
3888 (beginning-of-line)
3889 (if (allout-hidden-p) (forward-char -1)))
3890 (if (= last-at (setq last-at (point)))
3891 ;; Oops, we're not making any progress! Show the current
3892 ;; topic completely, and bag this try.
3893 (progn (beginning-of-line)
3894 (allout-show-current-subtree)
3895 (goto-char orig-pt)
3896 (setq bag-it t)
3897 (beep)
3898 (message "%s: %s"
3899 "allout-show-to-offshoot: "
3900 "Aberrant nesting encountered.")))
3901 (allout-show-children)
3902 (goto-char orig-pref))
3903 (goto-char orig-pt)))
3904 (if (allout-hidden-p)
3905 (allout-show-entry)))
3906 ;;;_ > allout-hide-current-entry ()
3907 (defun allout-hide-current-entry ()
3908 "Hide the body directly following this heading."
3909 (interactive)
3910 (allout-back-to-current-heading)
3911 (save-excursion
3912 (end-of-line)
3913 (allout-flag-region (point)
3914 (progn (allout-end-of-entry) (point))
3915 t)))
3916 ;;;_ > allout-show-current-entry (&optional arg)
3917 (defun allout-show-current-entry (&optional arg)
3918
3919 "Show body following current heading, or hide entry with universal argument."
3920
3921 (interactive "P")
3922 (if arg
3923 (allout-hide-current-entry)
3924 (save-excursion (allout-show-to-offshoot))
3925 (save-excursion
3926 (allout-flag-region (point)
3927 (progn (allout-end-of-entry t) (point))
3928 nil)
3929 )))
3930 ;;;_ > allout-show-current-subtree (&optional arg)
3931 (defun allout-show-current-subtree (&optional arg)
3932 "Show everything within the current topic. With a repeat-count,
3933 expose this topic and its siblings."
3934 (interactive "P")
3935 (save-excursion
3936 (if (<= (allout-current-depth) 0)
3937 ;; Outside any topics - try to get to the first:
3938 (if (not (allout-next-heading))
3939 (error "No topics")
3940 ;; got to first, outermost topic - set to expose it and siblings:
3941 (message "Above outermost topic - exposing all.")
3942 (allout-flag-region (point-min)(point-max) nil))
3943 (allout-beginning-of-current-line)
3944 (if (not arg)
3945 (allout-flag-current-subtree nil)
3946 (allout-beginning-of-level)
3947 (allout-expose-topic '(* :))))))
3948 ;;;_ > allout-current-topic-collapsed-p (&optional include-single-liners)
3949 (defun allout-current-topic-collapsed-p (&optional include-single-liners)
3950 "True if the currently visible containing topic is already collapsed.
3951
3952 If optional INCLUDE-SINGLE-LINERS is true, then include single-line
3953 topics \(which intrinsically can be considered both collapsed and
3954 not\), as collapsed. Otherwise they are considered uncollapsed."
3955 (save-excursion
3956 (and
3957 (= (progn (allout-back-to-current-heading)
3958 (move-end-of-line 1)
3959 (point))
3960 (allout-end-of-current-subtree))
3961 (or include-single-liners
3962 (progn (backward-char 1) (allout-hidden-p))))))
3963 ;;;_ > allout-hide-current-subtree (&optional just-close)
3964 (defun allout-hide-current-subtree (&optional just-close)
3965 "Close the current topic, or containing topic if this one is already closed.
3966
3967 If this topic is closed and it's a top level topic, close this topic
3968 and its siblings.
3969
3970 If optional arg JUST-CLOSE is non-nil, do not close the parent or
3971 siblings, even if the target topic is already closed."
3972
3973 (interactive)
3974 (let* ((from (point))
3975 (sibs-msg "Top-level topic already closed - closing siblings...")
3976 (current-exposed (not (allout-current-topic-collapsed-p t))))
3977 (cond (current-exposed (allout-flag-current-subtree t))
3978 (just-close nil)
3979 ((allout-up-current-level 1 t) (allout-hide-current-subtree))
3980 (t (goto-char 0)
3981 (message sibs-msg)
3982 (allout-expose-topic '(0 :))
3983 (message (concat sibs-msg " Done."))))
3984 (goto-char from)))
3985 ;;;_ > allout-show-current-branches ()
3986 (defun allout-show-current-branches ()
3987 "Show all subheadings of this heading, but not their bodies."
3988 (interactive)
3989 (beginning-of-line)
3990 (allout-show-children t))
3991 ;;;_ > allout-hide-current-leaves ()
3992 (defun allout-hide-current-leaves ()
3993 "Hide the bodies of the current topic and all its offspring."
3994 (interactive)
3995 (allout-back-to-current-heading)
3996 (allout-hide-region-body (point) (progn (allout-end-of-current-subtree)
3997 (point))))
3998
3999 ;;;_ - Region and beyond
4000 ;;;_ > allout-show-all ()
4001 (defun allout-show-all ()
4002 "Show all of the text in the buffer."
4003 (interactive)
4004 (message "Exposing entire buffer...")
4005 (allout-flag-region (point-min) (point-max) nil)
4006 (message "Exposing entire buffer... Done."))
4007 ;;;_ > allout-hide-bodies ()
4008 (defun allout-hide-bodies ()
4009 "Hide all of buffer except headings."
4010 (interactive)
4011 (allout-hide-region-body (point-min) (point-max)))
4012 ;;;_ > allout-hide-region-body (start end)
4013 (defun allout-hide-region-body (start end)
4014 "Hide all body lines in the region, but not headings."
4015 (save-excursion
4016 (save-restriction
4017 (narrow-to-region start end)
4018 (goto-char (point-min))
4019 (while (not (eobp))
4020 (end-of-line)
4021 (allout-flag-region (point) (allout-end-of-entry) t)
4022 (if (not (eobp))
4023 (forward-char
4024 (if (looking-at "\n\n")
4025 2 1)))))))
4026
4027 ;;;_ > allout-expose-topic (spec)
4028 (defun allout-expose-topic (spec)
4029 "Apply exposure specs to successive outline topic items.
4030
4031 Use the more convenient frontend, `allout-new-exposure', if you don't
4032 need evaluation of the arguments, or even better, the `allout-layout'
4033 variable-keyed mode-activation/auto-exposure feature of allout outline
4034 mode. See the respective documentation strings for more details.
4035
4036 Cursor is left at start position.
4037
4038 SPEC is either a number or a list.
4039
4040 Successive specs on a list are applied to successive sibling topics.
4041
4042 A simple spec \(either a number, one of a few symbols, or the null
4043 list) dictates the exposure for the corresponding topic.
4044
4045 Non-null lists recursively designate exposure specs for respective
4046 subtopics of the current topic.
4047
4048 The `:' repeat spec is used to specify exposure for any number of
4049 successive siblings, up to the trailing ones for which there are
4050 explicit specs following the `:'.
4051
4052 Simple (numeric and null-list) specs are interpreted as follows:
4053
4054 Numbers indicate the relative depth to open the corresponding topic.
4055 - negative numbers force the topic to be closed before opening to the
4056 absolute value of the number, so all siblings are open only to
4057 that level.
4058 - positive numbers open to the relative depth indicated by the
4059 number, but do not force already opened subtopics to be closed.
4060 - 0 means to close topic - hide all offspring.
4061 : - `repeat'
4062 apply prior element to all siblings at current level, *up to*
4063 those siblings that would be covered by specs following the `:'
4064 on the list. Ie, apply to all topics at level but the last
4065 ones. \(Only first of multiple colons at same level is
4066 respected - subsequent ones are discarded.)
4067 * - completely opens the topic, including bodies.
4068 + - shows all the sub headers, but not the bodies
4069 - - exposes the body of the corresponding topic.
4070
4071 Examples:
4072 \(allout-expose-topic '(-1 : 0))
4073 Close this and all following topics at current level, exposing
4074 only their immediate children, but close down the last topic
4075 at this current level completely.
4076 \(allout-expose-topic '(-1 () : 1 0))
4077 Close current topic so only the immediate subtopics are shown;
4078 show the children in the second to last topic, and completely
4079 close the last one.
4080 \(allout-expose-topic '(-2 : -1 *))
4081 Expose children and grandchildren of all topics at current
4082 level except the last two; expose children of the second to
4083 last and completely open the last one."
4084
4085 (interactive "xExposure spec: ")
4086 (if (not (listp spec))
4087 nil
4088 (let ((depth (allout-depth))
4089 (max-pos 0)
4090 prev-elem curr-elem
4091 stay)
4092 (while spec
4093 (setq prev-elem curr-elem
4094 curr-elem (car spec)
4095 spec (cdr spec))
4096 (cond ; Do current element:
4097 ((null curr-elem) nil)
4098 ((symbolp curr-elem)
4099 (cond ((eq curr-elem '*) (allout-show-current-subtree)
4100 (if (> allout-recent-end-of-subtree max-pos)
4101 (setq max-pos allout-recent-end-of-subtree)))
4102 ((eq curr-elem '+) (allout-show-current-branches)
4103 (if (> allout-recent-end-of-subtree max-pos)
4104 (setq max-pos allout-recent-end-of-subtree)))
4105 ((eq curr-elem '-) (allout-show-current-entry))
4106 ((eq curr-elem ':)
4107 (setq stay t)
4108 ;; Expand the `repeat' spec to an explicit version,
4109 ;; w.r.t. remaining siblings:
4110 (let ((residue ; = # of sibs not covered by remaining spec
4111 ;; Dang - could be nice to make use of the chart, sigh:
4112 (- (length (allout-chart-siblings))
4113 (length spec))))
4114 (if (< 0 residue)
4115 ;; Some residue - cover it with prev-elem:
4116 (setq spec (append (make-list residue prev-elem)
4117 spec)))))))
4118 ((numberp curr-elem)
4119 (if (and (>= 0 curr-elem) (not (allout-hidden-p)))
4120 (save-excursion (allout-hide-current-subtree t)
4121 (if (> 0 curr-elem)
4122 nil
4123 (if (> allout-recent-end-of-subtree max-pos)
4124 (setq max-pos
4125 allout-recent-end-of-subtree)))))
4126 (if (> (abs curr-elem) 0)
4127 (progn (allout-show-children (abs curr-elem))
4128 (if (> allout-recent-end-of-subtree max-pos)
4129 (setq max-pos allout-recent-end-of-subtree)))))
4130 ((listp curr-elem)
4131 (if (allout-descend-to-depth (1+ depth))
4132 (let ((got (allout-expose-topic curr-elem)))
4133 (if (and got (> got max-pos)) (setq max-pos got))))))
4134 (cond (stay (setq stay nil))
4135 ((listp (car spec)) nil)
4136 ((> max-pos (point))
4137 ;; Capitalize on max-pos state to get us nearer next sibling:
4138 (progn (goto-char (min (point-max) max-pos))
4139 (allout-next-heading)))
4140 ((allout-next-sibling depth))))
4141 max-pos)))
4142 ;;;_ > allout-old-expose-topic (spec &rest followers)
4143 (defun allout-old-expose-topic (spec &rest followers)
4144
4145 "Deprecated. Use `allout-expose-topic' \(with different schema
4146 format) instead.
4147
4148 Dictate wholesale exposure scheme for current topic, according to SPEC.
4149
4150 SPEC is either a number or a list. Optional successive args
4151 dictate exposure for subsequent siblings of current topic.
4152
4153 A simple spec (either a number, a special symbol, or the null list)
4154 dictates the overall exposure for a topic. Non null lists are
4155 composite specs whose first element dictates the overall exposure for
4156 a topic, with the subsequent elements in the list interpreted as specs
4157 that dictate the exposure for the successive offspring of the topic.
4158
4159 Simple (numeric and null-list) specs are interpreted as follows:
4160
4161 - Numbers indicate the relative depth to open the corresponding topic:
4162 - negative numbers force the topic to be close before opening to the
4163 absolute value of the number.
4164 - positive numbers just open to the relative depth indicated by the number.
4165 - 0 just closes
4166 - `*' completely opens the topic, including bodies.
4167 - `+' shows all the sub headers, but not the bodies
4168 - `-' exposes the body and immediate offspring of the corresponding topic.
4169
4170 If the spec is a list, the first element must be a number, which
4171 dictates the exposure depth of the topic as a whole. Subsequent
4172 elements of the list are nested SPECs, dictating the specific exposure
4173 for the corresponding offspring of the topic.
4174
4175 Optional FOLLOWERS arguments dictate exposure for succeeding siblings."
4176
4177 (interactive "xExposure spec: ")
4178 (let ((depth (allout-current-depth))
4179 max-pos)
4180 (cond ((null spec) nil)
4181 ((symbolp spec)
4182 (if (eq spec '*) (allout-show-current-subtree))
4183 (if (eq spec '+) (allout-show-current-branches))
4184 (if (eq spec '-) (allout-show-current-entry)))
4185 ((numberp spec)
4186 (if (>= 0 spec)
4187 (save-excursion (allout-hide-current-subtree t)
4188 (end-of-line)
4189 (if (or (not max-pos)
4190 (> (point) max-pos))
4191 (setq max-pos (point)))
4192 (if (> 0 spec)
4193 (setq spec (* -1 spec)))))
4194 (if (> spec 0)
4195 (allout-show-children spec)))
4196 ((listp spec)
4197 ;(let ((got (allout-old-expose-topic (car spec))))
4198 ; (if (and got (or (not max-pos) (> got max-pos)))
4199 ; (setq max-pos got)))
4200 (let ((new-depth (+ (allout-current-depth) 1))
4201 got)
4202 (setq max-pos (allout-old-expose-topic (car spec)))
4203 (setq spec (cdr spec))
4204 (if (and spec
4205 (allout-descend-to-depth new-depth)
4206 (not (allout-hidden-p)))
4207 (progn (setq got (apply 'allout-old-expose-topic spec))
4208 (if (and got (or (not max-pos) (> got max-pos)))
4209 (setq max-pos got)))))))
4210 (while (and followers
4211 (progn (if (and max-pos (< (point) max-pos))
4212 (progn (goto-char max-pos)
4213 (setq max-pos nil)))
4214 (end-of-line)
4215 (allout-next-sibling depth)))
4216 (allout-old-expose-topic (car followers))
4217 (setq followers (cdr followers)))
4218 max-pos))
4219 ;;;_ > allout-new-exposure '()
4220 (defmacro allout-new-exposure (&rest spec)
4221 "Literal frontend for `allout-expose-topic', doesn't evaluate arguments.
4222 Some arguments that would need to be quoted in `allout-expose-topic'
4223 need not be quoted in `allout-new-exposure'.
4224
4225 Cursor is left at start position.
4226
4227 Use this instead of obsolete `allout-exposure'.
4228
4229 Examples:
4230 \(allout-new-exposure (-1 () () () 1) 0)
4231 Close current topic at current level so only the immediate
4232 subtopics are shown, except also show the children of the
4233 third subtopic; and close the next topic at the current level.
4234 \(allout-new-exposure : -1 0)
4235 Close all topics at current level to expose only their
4236 immediate children, except for the last topic at the current
4237 level, in which even its immediate children are hidden.
4238 \(allout-new-exposure -2 : -1 *)
4239 Expose children and grandchildren of first topic at current
4240 level, and expose children of subsequent topics at current
4241 level *except* for the last, which should be opened completely."
4242 (list 'save-excursion
4243 '(if (not (or (allout-goto-prefix)
4244 (allout-next-heading)))
4245 (error "allout-new-exposure: Can't find any outline topics"))
4246 (list 'allout-expose-topic (list 'quote spec))))
4247
4248 ;;;_ #7 Systematic outline presentation - copying, printing, flattening
4249
4250 ;;;_ - Mapping and processing of topics
4251 ;;;_ ( See also Subtree Charting, in Navigation code.)
4252 ;;;_ > allout-stringify-flat-index (flat-index)
4253 (defun allout-stringify-flat-index (flat-index &optional context)
4254 "Convert list representing section/subsection/... to document string.
4255
4256 Optional arg CONTEXT indicates interior levels to include."
4257 (let ((delim ".")
4258 result
4259 numstr
4260 (context-depth (or (and context 2) 1)))
4261 ;; Take care of the explicit context:
4262 (while (> context-depth 0)
4263 (setq numstr (int-to-string (car flat-index))
4264 flat-index (cdr flat-index)
4265 result (if flat-index
4266 (cons delim (cons numstr result))
4267 (cons numstr result))
4268 context-depth (if flat-index (1- context-depth) 0)))
4269 (setq delim " ")
4270 ;; Take care of the indentation:
4271 (if flat-index
4272 (progn
4273 (while flat-index
4274 (setq result
4275 (cons delim
4276 (cons (make-string
4277 (1+ (truncate (if (zerop (car flat-index))
4278 1
4279 (log10 (car flat-index)))))
4280 ? )
4281 result)))
4282 (setq flat-index (cdr flat-index)))
4283 ;; Dispose of single extra delim:
4284 (setq result (cdr result))))
4285 (apply 'concat result)))
4286 ;;;_ > allout-stringify-flat-index-plain (flat-index)
4287 (defun allout-stringify-flat-index-plain (flat-index)
4288 "Convert list representing section/subsection/... to document string."
4289 (let ((delim ".")
4290 result)
4291 (while flat-index
4292 (setq result (cons (int-to-string (car flat-index))
4293 (if result
4294 (cons delim result))))
4295 (setq flat-index (cdr flat-index)))
4296 (apply 'concat result)))
4297 ;;;_ > allout-stringify-flat-index-indented (flat-index)
4298 (defun allout-stringify-flat-index-indented (flat-index)
4299 "Convert list representing section/subsection/... to document string."
4300 (let ((delim ".")
4301 result
4302 numstr)
4303 ;; Take care of the explicit context:
4304 (setq numstr (int-to-string (car flat-index))
4305 flat-index (cdr flat-index)
4306 result (if flat-index
4307 (cons delim (cons numstr result))
4308 (cons numstr result)))
4309 (setq delim " ")
4310 ;; Take care of the indentation:
4311 (if flat-index
4312 (progn
4313 (while flat-index
4314 (setq result
4315 (cons delim
4316 (cons (make-string
4317 (1+ (truncate (if (zerop (car flat-index))
4318 1
4319 (log10 (car flat-index)))))
4320 ? )
4321 result)))
4322 (setq flat-index (cdr flat-index)))
4323 ;; Dispose of single extra delim:
4324 (setq result (cdr result))))
4325 (apply 'concat result)))
4326 ;;;_ > allout-listify-exposed (&optional start end format)
4327 (defun allout-listify-exposed (&optional start end format)
4328
4329 "Produce a list representing exposed topics in current region.
4330
4331 This list can then be used by `allout-process-exposed' to manipulate
4332 the subject region.
4333
4334 Optional START and END indicate bounds of region.
4335
4336 optional arg, FORMAT, designates an alternate presentation form for
4337 the prefix:
4338
4339 list - Present prefix as numeric section.subsection..., starting with
4340 section indicated by the list, innermost nesting first.
4341 `indent' \(symbol) - Convert header prefixes to all white space,
4342 except for distinctive bullets.
4343
4344 The elements of the list produced are lists that represents a topic
4345 header and body. The elements of that list are:
4346
4347 - a number representing the depth of the topic,
4348 - a string representing the header-prefix, including trailing whitespace and
4349 bullet.
4350 - a string representing the bullet character,
4351 - and a series of strings, each containing one line of the exposed
4352 portion of the topic entry."
4353
4354 (interactive "r")
4355 (save-excursion
4356 (let*
4357 ;; state vars:
4358 (strings prefix result depth new-depth out gone-out bullet beg
4359 next done)
4360
4361 (goto-char start)
4362 (beginning-of-line)
4363 ;; Goto initial topic, and register preceeding stuff, if any:
4364 (if (> (allout-goto-prefix) start)
4365 ;; First topic follows beginning point - register preliminary stuff:
4366 (setq result (list (list 0 "" nil
4367 (buffer-substring start (1- (point)))))))
4368 (while (and (not done)
4369 (not (eobp)) ; Loop until we've covered the region.
4370 (not (> (point) end)))
4371 (setq depth (allout-recent-depth) ; Current topics depth,
4372 bullet (allout-recent-bullet) ; ... bullet,
4373 prefix (allout-recent-prefix)
4374 beg (progn (allout-end-of-prefix t) (point))) ; and beginning.
4375 (setq done ; The boundary for the current topic:
4376 (not (allout-next-visible-heading 1)))
4377 (setq new-depth (allout-recent-depth))
4378 (setq gone-out out
4379 out (< new-depth depth))
4380 (beginning-of-line)
4381 (setq next (point))
4382 (goto-char beg)
4383 (setq strings nil)
4384 (while (> next (point)) ; Get all the exposed text in
4385 (setq strings
4386 (cons (buffer-substring
4387 beg
4388 ;To hidden text or end of line:
4389 (progn
4390 (end-of-line)
4391 (allout-back-to-visible-text)))
4392 strings))
4393 (when (< (point) next) ; Resume from after hid text, if any.
4394 (line-move 1))
4395 (setq beg (point)))
4396 ;; Accumulate list for this topic:
4397 (setq strings (nreverse strings))
4398 (setq result
4399 (cons
4400 (if format
4401 (let ((special (if (string-match
4402 (regexp-quote bullet)
4403 allout-distinctive-bullets-string)
4404 bullet)))
4405 (cond ((listp format)
4406 (list depth
4407 (if allout-abbreviate-flattened-numbering
4408 (allout-stringify-flat-index format
4409 gone-out)
4410 (allout-stringify-flat-index-plain
4411 format))
4412 strings
4413 special))
4414 ((eq format 'indent)
4415 (if special
4416 (list depth
4417 (concat (make-string (1+ depth) ? )
4418 (substring prefix -1))
4419 strings)
4420 (list depth
4421 (make-string depth ? )
4422 strings)))
4423 (t (error "allout-listify-exposed: %s %s"
4424 "invalid format" format))))
4425 (list depth prefix strings))
4426 result))
4427 ;; Reasses format, if any:
4428 (if (and format (listp format))
4429 (cond ((= new-depth depth)
4430 (setq format (cons (1+ (car format))
4431 (cdr format))))
4432 ((> new-depth depth) ; descending - assume by 1:
4433 (setq format (cons 1 format)))
4434 (t
4435 ; Pop the residue:
4436 (while (< new-depth depth)
4437 (setq format (cdr format))
4438 (setq depth (1- depth)))
4439 ; And increment the current one:
4440 (setq format
4441 (cons (1+ (or (car format)
4442 -1))
4443 (cdr format)))))))
4444 ;; Put the list with first at front, to last at back:
4445 (nreverse result))))
4446 ;;;_ > my-region-active-p ()
4447 (defmacro my-region-active-p ()
4448 (if (fboundp 'region-active-p)
4449 '(region-active-p)
4450 'mark-active))
4451 ;;;_ > allout-process-exposed (&optional func from to frombuf
4452 ;;; tobuf format)
4453 (defun allout-process-exposed (&optional func from to frombuf tobuf
4454 format start-num)
4455 "Map function on exposed parts of current topic; results to another buffer.
4456
4457 All args are options; default values itemized below.
4458
4459 Apply FUNCTION to exposed portions FROM position TO position in buffer
4460 FROMBUF to buffer TOBUF. Sixth optional arg, FORMAT, designates an
4461 alternate presentation form:
4462
4463 `flat' - Present prefix as numeric section.subsection..., starting with
4464 section indicated by the start-num, innermost nesting first.
4465 X`flat-indented' - Prefix is like `flat' for first topic at each
4466 X level, but subsequent topics have only leaf topic
4467 X number, padded with blanks to line up with first.
4468 `indent' \(symbol) - Convert header prefixes to all white space,
4469 except for distinctive bullets.
4470
4471 Defaults:
4472 FUNCTION: `allout-insert-listified'
4473 FROM: region start, if region active, else start of buffer
4474 TO: region end, if region active, else end of buffer
4475 FROMBUF: current buffer
4476 TOBUF: buffer name derived: \"*current-buffer-name exposed*\"
4477 FORMAT: nil"
4478
4479 ; Resolve arguments,
4480 ; defaulting if necessary:
4481 (if (not func) (setq func 'allout-insert-listified))
4482 (if (not (and from to))
4483 (if (my-region-active-p)
4484 (setq from (region-beginning) to (region-end))
4485 (setq from (point-min) to (point-max))))
4486 (if frombuf
4487 (if (not (bufferp frombuf))
4488 ;; Specified but not a buffer - get it:
4489 (let ((got (get-buffer frombuf)))
4490 (if (not got)
4491 (error (concat "allout-process-exposed: source buffer "
4492 frombuf
4493 " not found."))
4494 (setq frombuf got))))
4495 ;; not specified - default it:
4496 (setq frombuf (current-buffer)))
4497 (if tobuf
4498 (if (not (bufferp tobuf))
4499 (setq tobuf (get-buffer-create tobuf)))
4500 ;; not specified - default it:
4501 (setq tobuf (concat "*" (buffer-name frombuf) " exposed*")))
4502 (if (listp format)
4503 (nreverse format))
4504
4505 (let* ((listified
4506 (progn (set-buffer frombuf)
4507 (allout-listify-exposed from to format))))
4508 (set-buffer tobuf)
4509 (mapcar func listified)
4510 (pop-to-buffer tobuf)))
4511
4512 ;;;_ - Copy exposed
4513 ;;;_ > allout-insert-listified (listified)
4514 (defun allout-insert-listified (listified)
4515 "Insert contents of listified outline portion in current buffer.
4516
4517 LISTIFIED is a list representing each topic header and body:
4518
4519 \`(depth prefix text)'
4520
4521 or \`(depth prefix text bullet-plus)'
4522
4523 If `bullet-plus' is specified, it is inserted just after the entire prefix."
4524 (setq listified (cdr listified))
4525 (let ((prefix (prog1
4526 (car listified)
4527 (setq listified (cdr listified))))
4528 (text (prog1
4529 (car listified)
4530 (setq listified (cdr listified))))
4531 (bullet-plus (car listified)))
4532 (insert prefix)
4533 (if bullet-plus (insert (concat " " bullet-plus)))
4534 (while text
4535 (insert (car text))
4536 (if (setq text (cdr text))
4537 (insert "\n")))
4538 (insert "\n")))
4539 ;;;_ > allout-copy-exposed-to-buffer (&optional arg tobuf format)
4540 (defun allout-copy-exposed-to-buffer (&optional arg tobuf format)
4541 "Duplicate exposed portions of current outline to another buffer.
4542
4543 Other buffer has current buffers name with \" exposed\" appended to it.
4544
4545 With repeat count, copy the exposed parts of only the current topic.
4546
4547 Optional second arg TOBUF is target buffer name.
4548
4549 Optional third arg FORMAT, if non-nil, symbolically designates an
4550 alternate presentation format for the outline:
4551
4552 `flat' - Convert topic header prefixes to numeric
4553 section.subsection... identifiers.
4554 `indent' - Convert header prefixes to all white space, except for
4555 distinctive bullets.
4556 `indent-flat' - The best of both - only the first of each level has
4557 the full path, the rest have only the section number
4558 of the leaf, preceded by the right amount of indentation."
4559
4560 (interactive "P")
4561 (if (not tobuf)
4562 (setq tobuf (get-buffer-create (concat "*" (buffer-name) " exposed*"))))
4563 (let* ((start-pt (point))
4564 (beg (if arg (allout-back-to-current-heading) (point-min)))
4565 (end (if arg (allout-end-of-current-subtree) (point-max)))
4566 (buf (current-buffer))
4567 (start-list ()))
4568 (if (eq format 'flat)
4569 (setq format (if arg (save-excursion
4570 (goto-char beg)
4571 (allout-topic-flat-index))
4572 '(1))))
4573 (save-excursion (set-buffer tobuf)(erase-buffer))
4574 (allout-process-exposed 'allout-insert-listified
4575 beg
4576 end
4577 (current-buffer)
4578 tobuf
4579 format start-list)
4580 (goto-char (point-min))
4581 (pop-to-buffer buf)
4582 (goto-char start-pt)))
4583 ;;;_ > allout-flatten-exposed-to-buffer (&optional arg tobuf)
4584 (defun allout-flatten-exposed-to-buffer (&optional arg tobuf)
4585 "Present numeric outline of outline's exposed portions in another buffer.
4586
4587 The resulting outline is not compatible with outline mode - use
4588 `allout-copy-exposed-to-buffer' if you want that.
4589
4590 Use `allout-indented-exposed-to-buffer' for indented presentation.
4591
4592 With repeat count, copy the exposed portions of only current topic.
4593
4594 Other buffer has current buffer's name with \" exposed\" appended to
4595 it, unless optional second arg TOBUF is specified, in which case it is
4596 used verbatim."
4597 (interactive "P")
4598 (allout-copy-exposed-to-buffer arg tobuf 'flat))
4599 ;;;_ > allout-indented-exposed-to-buffer (&optional arg tobuf)
4600 (defun allout-indented-exposed-to-buffer (&optional arg tobuf)
4601 "Present indented outline of outline's exposed portions in another buffer.
4602
4603 The resulting outline is not compatible with outline mode - use
4604 `allout-copy-exposed-to-buffer' if you want that.
4605
4606 Use `allout-flatten-exposed-to-buffer' for numeric sectional presentation.
4607
4608 With repeat count, copy the exposed portions of only current topic.
4609
4610 Other buffer has current buffer's name with \" exposed\" appended to
4611 it, unless optional second arg TOBUF is specified, in which case it is
4612 used verbatim."
4613 (interactive "P")
4614 (allout-copy-exposed-to-buffer arg tobuf 'indent))
4615
4616 ;;;_ - LaTeX formatting
4617 ;;;_ > allout-latex-verb-quote (string &optional flow)
4618 (defun allout-latex-verb-quote (string &optional flow)
4619 "Return copy of STRING for literal reproduction across LaTeX processing.
4620 Expresses the original characters \(including carriage returns) of the
4621 string across LaTeX processing."
4622 (mapconcat (function
4623 (lambda (char)
4624 (cond ((memq char '(?\\ ?$ ?% ?# ?& ?{ ?} ?_ ?^ ?- ?*))
4625 (concat "\\char" (number-to-string char) "{}"))
4626 ((= char ?\n) "\\\\")
4627 (t (char-to-string char)))))
4628 string
4629 ""))
4630 ;;;_ > allout-latex-verbatim-quote-curr-line ()
4631 (defun allout-latex-verbatim-quote-curr-line ()
4632 "Express line for exact \(literal) representation across LaTeX processing.
4633
4634 Adjust line contents so it is unaltered \(from the original line)
4635 across LaTeX processing, within the context of a `verbatim'
4636 environment. Leaves point at the end of the line."
4637 (beginning-of-line)
4638 (let ((beg (point))
4639 (end (progn (end-of-line)(point))))
4640 (goto-char beg)
4641 (while (re-search-forward "\\\\"
4642 ;;"\\\\\\|\\{\\|\\}\\|\\_\\|\\$\\|\\\"\\|\\&\\|\\^\\|\\-\\|\\*\\|#"
4643 end ; bounded by end-of-line
4644 1) ; no matches, move to end & return nil
4645 (goto-char (match-beginning 0))
4646 (insert "\\")
4647 (setq end (1+ end))
4648 (goto-char (1+ (match-end 0))))))
4649 ;;;_ > allout-insert-latex-header (buffer)
4650 (defun allout-insert-latex-header (buffer)
4651 "Insert initial LaTeX commands at point in BUFFER."
4652 ;; Much of this is being derived from the stuff in appendix of E in
4653 ;; the TeXBook, pg 421.
4654 (set-buffer buffer)
4655 (let ((doc-style (format "\n\\documentstyle{%s}\n"
4656 "report"))
4657 (page-numbering (if allout-number-pages
4658 "\\pagestyle{empty}\n"
4659 ""))
4660 (titlecmd (format "\\newcommand{\\titlecmd}[1]{{%s #1}}\n"
4661 allout-title-style))
4662 (labelcmd (format "\\newcommand{\\labelcmd}[1]{{%s #1}}\n"
4663 allout-label-style))
4664 (headlinecmd (format "\\newcommand{\\headlinecmd}[1]{{%s #1}}\n"
4665 allout-head-line-style))
4666 (bodylinecmd (format "\\newcommand{\\bodylinecmd}[1]{{%s #1}}\n"
4667 allout-body-line-style))
4668 (setlength (format "%s%s%s%s"
4669 "\\newlength{\\stepsize}\n"
4670 "\\setlength{\\stepsize}{"
4671 allout-indent
4672 "}\n"))
4673 (oneheadline (format "%s%s%s%s%s%s%s"
4674 "\\newcommand{\\OneHeadLine}[3]{%\n"
4675 "\\noindent%\n"
4676 "\\hspace*{#2\\stepsize}%\n"
4677 "\\labelcmd{#1}\\hspace*{.2cm}"
4678 "\\headlinecmd{#3}\\\\["
4679 allout-line-skip
4680 "]\n}\n"))
4681 (onebodyline (format "%s%s%s%s%s%s"
4682 "\\newcommand{\\OneBodyLine}[2]{%\n"
4683 "\\noindent%\n"
4684 "\\hspace*{#1\\stepsize}%\n"
4685 "\\bodylinecmd{#2}\\\\["
4686 allout-line-skip
4687 "]\n}\n"))
4688 (begindoc "\\begin{document}\n\\begin{center}\n")
4689 (title (format "%s%s%s%s"
4690 "\\titlecmd{"
4691 (allout-latex-verb-quote (if allout-title
4692 (condition-case nil
4693 (eval allout-title)
4694 ('error "<unnamed buffer>"))
4695 "Unnamed Outline"))
4696 "}\n"
4697 "\\end{center}\n\n"))
4698 (hsize "\\hsize = 7.5 true in\n")
4699 (hoffset "\\hoffset = -1.5 true in\n")
4700 (vspace "\\vspace{.1cm}\n\n"))
4701 (insert (concat doc-style
4702 page-numbering
4703 titlecmd
4704 labelcmd
4705 headlinecmd
4706 bodylinecmd
4707 setlength
4708 oneheadline
4709 onebodyline
4710 begindoc
4711 title
4712 hsize
4713 hoffset
4714 vspace)
4715 )))
4716 ;;;_ > allout-insert-latex-trailer (buffer)
4717 (defun allout-insert-latex-trailer (buffer)
4718 "Insert concluding LaTeX commands at point in BUFFER."
4719 (set-buffer buffer)
4720 (insert "\n\\end{document}\n"))
4721 ;;;_ > allout-latexify-one-item (depth prefix bullet text)
4722 (defun allout-latexify-one-item (depth prefix bullet text)
4723 "Insert LaTeX commands for formatting one outline item.
4724
4725 Args are the topics numeric DEPTH, the header PREFIX lead string, the
4726 BULLET string, and a list of TEXT strings for the body."
4727 (let* ((head-line (if text (car text)))
4728 (body-lines (cdr text))
4729 (curr-line)
4730 body-content bop)
4731 ; Do the head line:
4732 (insert (concat "\\OneHeadLine{\\verb\1 "
4733 (allout-latex-verb-quote bullet)
4734 "\1}{"
4735 depth
4736 "}{\\verb\1 "
4737 (if head-line
4738 (allout-latex-verb-quote head-line)
4739 "")
4740 "\1}\n"))
4741 (if (not body-lines)
4742 nil
4743 ;;(insert "\\beginlines\n")
4744 (insert "\\begin{verbatim}\n")
4745 (while body-lines
4746 (setq curr-line (car body-lines))
4747 (if (and (not body-content)
4748 (not (string-match "^\\s-*$" curr-line)))
4749 (setq body-content t))
4750 ; Mangle any occurrences of
4751 ; "\end{verbatim}" in text,
4752 ; it's special:
4753 (if (and body-content
4754 (setq bop (string-match "\\end{verbatim}" curr-line)))
4755 (setq curr-line (concat (substring curr-line 0 bop)
4756 ">"
4757 (substring curr-line bop))))
4758 ;;(insert "|" (car body-lines) "|")
4759 (insert curr-line)
4760 (allout-latex-verbatim-quote-curr-line)
4761 (insert "\n")
4762 (setq body-lines (cdr body-lines)))
4763 (if body-content
4764 (setq body-content nil)
4765 (forward-char -1)
4766 (insert "\\ ")
4767 (forward-char 1))
4768 ;;(insert "\\endlines\n")
4769 (insert "\\end{verbatim}\n")
4770 )))
4771 ;;;_ > allout-latexify-exposed (arg &optional tobuf)
4772 (defun allout-latexify-exposed (arg &optional tobuf)
4773 "Format current topics exposed portions to TOBUF for LaTeX processing.
4774 TOBUF defaults to a buffer named the same as the current buffer, but
4775 with \"*\" prepended and \" latex-formed*\" appended.
4776
4777 With repeat count, copy the exposed portions of entire buffer."
4778
4779 (interactive "P")
4780 (if (not tobuf)
4781 (setq tobuf
4782 (get-buffer-create (concat "*" (buffer-name) " latexified*"))))
4783 (let* ((start-pt (point))
4784 (beg (if arg (point-min) (allout-back-to-current-heading)))
4785 (end (if arg (point-max) (allout-end-of-current-subtree)))
4786 (buf (current-buffer)))
4787 (set-buffer tobuf)
4788 (erase-buffer)
4789 (allout-insert-latex-header tobuf)
4790 (goto-char (point-max))
4791 (allout-process-exposed 'allout-latexify-one-item
4792 beg
4793 end
4794 buf
4795 tobuf)
4796 (goto-char (point-max))
4797 (allout-insert-latex-trailer tobuf)
4798 (goto-char (point-min))
4799 (pop-to-buffer buf)
4800 (goto-char start-pt)))
4801
4802 ;;;_ #8 Encryption
4803 ;;;_ > allout-toggle-current-subtree-encryption (&optional fetch-pass)
4804 (defun allout-toggle-current-subtree-encryption (&optional fetch-pass)
4805 "Encrypt clear or decrypt encoded text of visibly-containing topic's contents.
4806
4807 Optional FETCH-PASS universal argument provokes key-pair encryption with
4808 single universal argument. With doubled universal argument \(value = 16),
4809 it forces prompting for the passphrase regardless of availability from the
4810 passphrase cache. With no universal argument, the appropriate passphrase
4811 is obtained from the cache, if available, else from the user.
4812
4813 Currently only GnuPG encryption is supported.
4814
4815 \**NOTE WELL** that the encrypted text must be ascii-armored. For gnupg
4816 encryption, include the option ``armor'' in your ~/.gnupg/gpg.conf file.
4817
4818 Both symmetric-key and key-pair encryption is implemented. Symmetric is
4819 the default, use a single \(x4) universal argument for keypair mode.
4820
4821 Encrypted topic's bullet is set to a `~' to signal that the contents of the
4822 topic \(body and subtopics, but not heading) is pending encryption or
4823 encrypted. `*' asterisk immediately after the bullet signals that the body
4824 is encrypted, its' absence means the topic is meant to be encrypted but is
4825 not. When a file with topics pending encryption is saved, topics pending
4826 encryption are encrypted. See allout-encrypt-unencrypted-on-saves for
4827 auto-encryption specifics.
4828
4829 \**NOTE WELL** that automatic encryption that happens during saves will
4830 default to symmetric encryption - you must manually \(re)encrypt key-pair
4831 encrypted topics if you want them to continue to use the key-pair cipher.
4832
4833 Level-1 topics, with prefix consisting solely of an `*' asterisk, cannot be
4834 encrypted. If you want to encrypt the contents of a top-level topic, use
4835 \\[allout-shift-in] to increase its depth.
4836
4837 Passphrase Caching
4838
4839 The encryption passphrase is solicited if not currently available in the
4840 passphrase cache from a recent encryption action.
4841
4842 The solicited passphrase is retained for reuse in a buffer-specific cache
4843 for some set period of time \(default, 60 seconds), after which the string
4844 is nulled. The passphrase cache timeout is customized by setting
4845 `pgg-passphrase-cache-expiry'.
4846
4847 Symmetric Passphrase Hinting and Verification
4848
4849 If the file previously had no associated passphrase, or had a different
4850 passphrase than specified, the user is prompted to repeat the new one for
4851 corroboration. A random string encrypted by the new passphrase is set on
4852 the buffer-specific variable `allout-passphrase-verifier-string', for
4853 confirmation of the passphrase when next obtained, before encrypting or
4854 decrypting anything with it. This helps avoid mistakenly shifting between
4855 keys.
4856
4857 If allout customization var `allout-passphrase-verifier-handling' is
4858 non-nil, an entry for `allout-passphrase-verifier-string' and its value is
4859 added to an Emacs 'local variables' section at the end of the file, which
4860 is created if necessary. That setting is for retention of the passphrase
4861 verifier across emacs sessions.
4862
4863 Similarly, `allout-passphrase-hint-string' stores a user-provided reminder
4864 about their passphrase, and `allout-passphrase-hint-handling' specifies
4865 when the hint is presented, or if passphrase hints are disabled. If
4866 enabled \(see the `allout-passphrase-hint-handling' docstring for details),
4867 the hint string is stored in the local-variables section of the file, and
4868 solicited whenever the passphrase is changed."
4869 (interactive "P")
4870 (save-excursion
4871 (allout-back-to-current-heading)
4872 (allout-toggle-subtree-encryption fetch-pass)
4873 )
4874 )
4875 ;;;_ > allout-toggle-subtree-encryption (&optional fetch-pass)
4876 (defun allout-toggle-subtree-encryption (&optional fetch-pass)
4877 "Encrypt clear text or decrypt encoded topic contents \(body and subtopics.)
4878
4879 Optional FETCH-PASS universal argument provokes key-pair encryption with
4880 single universal argument. With doubled universal argument \(value = 16),
4881 it forces prompting for the passphrase regardless of availability from the
4882 passphrase cache. With no universal argument, the appropriate passphrase
4883 is obtained from the cache, if available, else from the user.
4884
4885 Currently only GnuPG encryption is supported.
4886
4887 \**NOTE WELL** that the encrypted text must be ascii-armored. For gnupg
4888 encryption, include the option ``armor'' in your ~/.gnupg/gpg.conf file.
4889
4890 See `allout-toggle-current-subtree-encryption' for more details."
4891
4892 (interactive "P")
4893 (save-excursion
4894 (allout-end-of-prefix t)
4895
4896 (if (= (allout-recent-depth) 1)
4897 (error (concat "Cannot encrypt or decrypt level 1 topics -"
4898 " shift it in to make it encryptable")))
4899
4900 (let* ((allout-buffer (current-buffer))
4901 ;; Asses location:
4902 (after-bullet-pos (point))
4903 (was-encrypted
4904 (progn (if (= (point-max) after-bullet-pos)
4905 (error "no body to encrypt"))
4906 (allout-encrypted-topic-p)))
4907 (was-collapsed (if (not (search-forward "\n" nil t))
4908 nil
4909 (backward-char 1)
4910 (allout-hidden-p)))
4911 (subtree-beg (1+ (point)))
4912 (subtree-end (allout-end-of-subtree))
4913 (subject-text (buffer-substring-no-properties subtree-beg
4914 subtree-end))
4915 (subtree-end-char (char-after (1- subtree-end)))
4916 (subtree-trailing-char (char-after subtree-end))
4917 ;; kluge - result-text needs to be nil, but we also want to
4918 ;; check for the error condition
4919 (result-text (if (or (string= "" subject-text)
4920 (string= "\n" subject-text))
4921 (error "No topic contents to %scrypt"
4922 (if was-encrypted "de" "en"))
4923 nil))
4924 ;; Assess key parameters:
4925 (key-info (or
4926 ;; detect the type by which it is already encrypted
4927 (and was-encrypted
4928 (allout-encrypted-key-info subject-text))
4929 (and (member fetch-pass '(4 (4)))
4930 '(keypair nil))
4931 '(symmetric nil)))
4932 (for-key-type (car key-info))
4933 (for-key-identity (cadr key-info))
4934 (fetch-pass (and fetch-pass (member fetch-pass '(16 (16))))))
4935
4936 (setq result-text
4937 (allout-encrypt-string subject-text was-encrypted
4938 (current-buffer)
4939 for-key-type for-key-identity fetch-pass))
4940
4941 ;; Replace the subtree with the processed product.
4942 (allout-unprotected
4943 (progn
4944 (set-buffer allout-buffer)
4945 (delete-region subtree-beg subtree-end)
4946 (insert result-text)
4947 (if was-collapsed
4948 (allout-flag-region (1- subtree-beg) (point) t))
4949 ;; adjust trailing-blank-lines to preserve topic spacing:
4950 (if (not was-encrypted)
4951 (if (and (= subtree-end-char ?\n)
4952 (= subtree-trailing-char ?\n))
4953 (insert subtree-trailing-char)))
4954 ;; Ensure that the item has an encrypted-entry bullet:
4955 (if (not (string= (buffer-substring-no-properties
4956 (1- after-bullet-pos) after-bullet-pos)
4957 allout-topic-encryption-bullet))
4958 (progn (goto-char (1- after-bullet-pos))
4959 (delete-char 1)
4960 (insert allout-topic-encryption-bullet)))
4961 (if was-encrypted
4962 ;; Remove the is-encrypted bullet qualifier:
4963 (progn (goto-char after-bullet-pos)
4964 (delete-char 1))
4965 ;; Add the is-encrypted bullet qualifier:
4966 (goto-char after-bullet-pos)
4967 (insert "*"))
4968 )
4969 )
4970 )
4971 )
4972 )
4973 ;;;_ > allout-encrypt-string (text decrypt allout-buffer key-type for-key
4974 ;;; fetch-pass &optional retried verifying
4975 ;;; passphrase)
4976 (defun allout-encrypt-string (text decrypt allout-buffer key-type for-key
4977 fetch-pass &optional retried verifying
4978 passphrase)
4979 "Encrypt or decrypt message TEXT.
4980
4981 If DECRYPT is true (default false), then decrypt instead of encrypt.
4982
4983 FETCH-PASS (default false) forces fresh prompting for the passphrase.
4984
4985 KEY-TYPE indicates whether to use a 'symmetric or 'keypair cipher.
4986
4987 FOR-KEY is human readable identification of the first of the user's
4988 eligible secret keys a keypair decryption targets, or else nil.
4989
4990 Optional RETRIED is for internal use - conveys the number of failed keys
4991 that have been solicited in sequence leading to this current call.
4992
4993 Optional PASSPHRASE enables explicit delivery of the decryption passphrase,
4994 for verification purposes.
4995
4996 Returns the resulting string, or nil if the transformation fails."
4997
4998 (require 'pgg)
4999
5000 (if (not (fboundp 'pgg-encrypt-symmetric))
5001 (error "Allout encryption depends on a newer version of pgg"))
5002
5003 (let* ((scheme (upcase
5004 (format "%s" (or pgg-scheme pgg-default-scheme "GPG"))))
5005 (for-key (and (equal key-type 'keypair)
5006 (or for-key
5007 (split-string (read-string
5008 (format "%s message recipients: "
5009 scheme))
5010 "[ \t,]+"))))
5011 (target-prompt-id (if (equal key-type 'keypair)
5012 (if (= (length for-key) 1)
5013 (car for-key) for-key)
5014 (buffer-name allout-buffer)))
5015 (target-cache-id (format "%s-%s"
5016 key-type
5017 (if (equal key-type 'keypair)
5018 target-prompt-id
5019 (or (buffer-file-name allout-buffer)
5020 target-prompt-id))))
5021 result-text status)
5022
5023 (if (and fetch-pass (not passphrase))
5024 ;; Force later fetch by evicting passphrase from the cache.
5025 (pgg-remove-passphrase-from-cache target-cache-id t))
5026
5027 (catch 'encryption-failed
5028
5029 ;; Obtain the passphrase if we don't already have one and we're not
5030 ;; doing a keypair encryption:
5031 (if (not (or passphrase
5032 (and (equal key-type 'keypair)
5033 (not decrypt))))
5034
5035 (setq passphrase (allout-obtain-passphrase for-key
5036 target-cache-id
5037 target-prompt-id
5038 key-type
5039 allout-buffer
5040 retried fetch-pass)))
5041 (with-temp-buffer
5042
5043 (insert text)
5044
5045 (cond
5046
5047 ;; symmetric:
5048 ((equal key-type 'symmetric)
5049 (setq status
5050 (if decrypt
5051
5052 (pgg-decrypt (point-min) (point-max) passphrase)
5053
5054 (pgg-encrypt-symmetric (point-min) (point-max)
5055 passphrase)))
5056
5057 (if status
5058 (pgg-situate-output (point-min) (point-max))
5059 ;; failed - handle passphrase caching
5060 (if verifying
5061 (throw 'encryption-failed nil)
5062 (pgg-remove-passphrase-from-cache target-cache-id t)
5063 (error "Symmetric-cipher encryption failed - %s"
5064 "try again with different passphrase."))))
5065
5066 ;; encrypt 'keypair:
5067 ((not decrypt)
5068
5069 (setq status
5070
5071 (pgg-encrypt for-key
5072 nil (point-min) (point-max) passphrase))
5073
5074 (if status
5075 (pgg-situate-output (point-min) (point-max))
5076 (error (pgg-remove-passphrase-from-cache target-cache-id t)
5077 (error "encryption failed"))))
5078
5079 ;; decrypt 'keypair:
5080 (t
5081
5082 (setq status
5083 (pgg-decrypt (point-min) (point-max) passphrase))
5084
5085 (if status
5086 (pgg-situate-output (point-min) (point-max))
5087 (error (pgg-remove-passphrase-from-cache target-cache-id t)
5088 (error "decryption failed"))))
5089 )
5090
5091 (setq result-text
5092 (buffer-substring 1 (- (point-max) (if decrypt 0 1))))
5093
5094 ;; validate result - non-empty
5095 (cond ((not result-text)
5096 (if verifying
5097 nil
5098 ;; transform was fruitless, retry w/new passphrase.
5099 (pgg-remove-passphrase-from-cache target-cache-id t)
5100 (allout-encrypt-string text allout-buffer decrypt nil
5101 (if retried (1+ retried) 1)
5102 passphrase)))
5103
5104 ;; Barf if encryption yields extraordinary control chars:
5105 ((and (not decrypt)
5106 (string-match "[\C-a\C-k\C-o-\C-z\C-@]"
5107 result-text))
5108 (error (concat "encryption produced unusable"
5109 " non-armored text - reconfigure!")))
5110
5111 ;; valid result and just verifying or non-symmetric:
5112 ((or verifying (not (equal key-type 'symmetric)))
5113 (if (or verifying decrypt)
5114 (pgg-add-passphrase-to-cache target-cache-id
5115 passphrase t))
5116 result-text)
5117
5118 ;; valid result and regular symmetric - "register"
5119 ;; passphrase with mnemonic aids/cache.
5120 (t
5121 (set-buffer allout-buffer)
5122 (if passphrase
5123 (pgg-add-passphrase-to-cache target-cache-id
5124 passphrase t))
5125 (allout-update-passphrase-mnemonic-aids for-key passphrase
5126 allout-buffer)
5127 result-text)
5128 )
5129 )
5130 )
5131 )
5132 )
5133 ;;;_ > allout-obtain-passphrase (for-key cache-id prompt-id key-type
5134 ;;; allout-buffer retried fetch-pass)
5135 (defun allout-obtain-passphrase (for-key cache-id prompt-id key-type
5136 allout-buffer retried fetch-pass)
5137 "Obtain passphrase for a key from the cache or else from the user.
5138
5139 When obtaining from the user, symmetric-cipher passphrases are verified
5140 against either, if available and enabled, a random string that was
5141 encrypted against the passphrase, or else against repeated entry by the
5142 user for corroboration.
5143
5144 FOR-KEY is the key for which the passphrase is being obtained.
5145
5146 CACHE-ID is the cache id of the key for the passphrase.
5147
5148 PROMPT-ID is the id for use when prompting the user.
5149
5150 KEY-TYPE is either 'symmetric or 'keypair.
5151
5152 ALLOUT-BUFFER is the buffer containing the entry being en/decrypted.
5153
5154 RETRIED is the number of this attempt to obtain this passphrase.
5155
5156 FETCH-PASS causes the passphrase to be solicited from the user, regardless
5157 of the availability of a cached copy."
5158
5159 (if (not (equal key-type 'symmetric))
5160 ;; do regular passphrase read on non-symmetric passphrase:
5161 (pgg-read-passphrase (format "%s passphrase%s: "
5162 (upcase (format "%s" (or pgg-scheme
5163 pgg-default-scheme
5164 "GPG")))
5165 (if prompt-id
5166 (format " for %s" prompt-id)
5167 ""))
5168 cache-id t)
5169
5170 ;; Symmetric hereon:
5171
5172 (save-excursion
5173 (set-buffer allout-buffer)
5174 (let* ((hint (if (and (not (string= allout-passphrase-hint-string ""))
5175 (or (equal allout-passphrase-hint-handling 'always)
5176 (and (equal allout-passphrase-hint-handling
5177 'needed)
5178 retried)))
5179 (format " [%s]" allout-passphrase-hint-string)
5180 ""))
5181 (retry-message (if retried (format " (%s retry)" retried) ""))
5182 (prompt-sans-hint (format "'%s' symmetric passphrase%s: "
5183 prompt-id retry-message))
5184 (full-prompt (format "'%s' symmetric passphrase%s%s: "
5185 prompt-id hint retry-message))
5186 (prompt full-prompt)
5187 (verifier-string (allout-get-encryption-passphrase-verifier))
5188
5189 (cached (and (not fetch-pass)
5190 (pgg-read-passphrase-from-cache cache-id t)))
5191 (got-pass (or cached
5192 (pgg-read-passphrase full-prompt cache-id t)))
5193
5194 confirmation)
5195
5196 (if (not got-pass)
5197 nil
5198
5199 ;; Duplicate our handle on the passphrase so it's not clobbered by
5200 ;; deactivate-passwd memory clearing:
5201 (setq got-pass (format "%s" got-pass))
5202
5203 (cond (verifier-string
5204 (save-window-excursion
5205 (if (allout-encrypt-string verifier-string 'decrypt
5206 allout-buffer 'symmetric
5207 for-key nil 0 'verifying
5208 got-pass)
5209 (setq confirmation (format "%s" got-pass))))
5210
5211 (if (and (not confirmation)
5212 (if (yes-or-no-p
5213 (concat "Passphrase differs from established"
5214 " - use new one instead? "))
5215 ;; deactivate password for subsequent
5216 ;; confirmation:
5217 (progn
5218 (pgg-remove-passphrase-from-cache cache-id t)
5219 (setq prompt prompt-sans-hint)
5220 nil)
5221 t))
5222 (progn (pgg-remove-passphrase-from-cache cache-id t)
5223 (error "Wrong passphrase."))))
5224 ;; No verifier string - force confirmation by repetition of
5225 ;; (new) passphrase:
5226 ((or fetch-pass (not cached))
5227 (pgg-remove-passphrase-from-cache cache-id t))))
5228 ;; confirmation vs new input - doing pgg-read-passphrase will do the
5229 ;; right thing, in either case:
5230 (if (not confirmation)
5231 (setq confirmation
5232 (pgg-read-passphrase (concat prompt
5233 " ... confirm spelling: ")
5234 cache-id t)))
5235 (prog1
5236 (if (equal got-pass confirmation)
5237 confirmation
5238 (if (yes-or-no-p (concat "spelling of original and"
5239 " confirmation differ - retry? "))
5240 (progn (setq retried (if retried (1+ retried) 1))
5241 (pgg-remove-passphrase-from-cache cache-id t)
5242 ;; recurse to this routine:
5243 (pgg-read-passphrase prompt-sans-hint cache-id t))
5244 (pgg-remove-passphrase-from-cache cache-id t)
5245 (error "Confirmation failed.")))
5246 ;; reduce opportunity for memory cherry-picking by zeroing duplicate:
5247 (dotimes (i (length got-pass))
5248 (aset got-pass i 0))
5249 )
5250 )
5251 )
5252 )
5253 )
5254 ;;;_ > allout-encrypted-topic-p ()
5255 (defun allout-encrypted-topic-p ()
5256 "True if the current topic is encryptable and encrypted."
5257 (save-excursion
5258 (allout-end-of-prefix t)
5259 (and (string= (buffer-substring-no-properties (1- (point)) (point))
5260 allout-topic-encryption-bullet)
5261 (looking-at "\\*"))
5262 )
5263 )
5264 ;;;_ > allout-encrypted-key-info (text)
5265 ;; XXX gpg-specific, alas
5266 (defun allout-encrypted-key-info (text)
5267 "Return a pair of the key type and identity of a recipient's secret key.
5268
5269 The key type is one of 'symmetric or 'keypair.
5270
5271 if 'keypair, and some of the user's secret keys are among those for which
5272 the message was encoded, return the identity of the first. otherwise,
5273 return nil for the second item of the pair.
5274
5275 An error is raised if the text is not encrypted."
5276 (require 'pgg-parse)
5277 (save-excursion
5278 (with-temp-buffer
5279 (insert text)
5280 (let* ((parsed-armor (pgg-parse-armor-region (point-min) (point-max)))
5281 (type (if (pgg-gpg-symmetric-key-p parsed-armor)
5282 'symmetric
5283 'keypair))
5284 secret-keys first-secret-key for-key-owner)
5285 (if (equal type 'keypair)
5286 (setq secret-keys (pgg-gpg-lookup-all-secret-keys)
5287 first-secret-key (pgg-gpg-select-matching-key parsed-armor
5288 secret-keys)
5289 for-key-owner (and first-secret-key
5290 (pgg-gpg-lookup-key-owner
5291 first-secret-key))))
5292 (list type (pgg-gpg-key-id-from-key-owner for-key-owner))
5293 )
5294 )
5295 )
5296 )
5297 ;;;_ > allout-create-encryption-passphrase-verifier (passphrase)
5298 (defun allout-create-encryption-passphrase-verifier (passphrase)
5299 "Encrypt random message for later validation of symmetric key's passphrase."
5300 ;; use 20 random ascii characters, across the entire ascii range.
5301 (random t)
5302 (let ((spew (make-string 20 ?\0)))
5303 (dotimes (i (length spew))
5304 (aset spew i (1+ (random 254))))
5305 (allout-encrypt-string spew nil (current-buffer) 'symmetric
5306 nil nil 0 passphrase))
5307 )
5308 ;;;_ > allout-update-passphrase-mnemonic-aids (for-key passphrase
5309 ;;; outline-buffer)
5310 (defun allout-update-passphrase-mnemonic-aids (for-key passphrase
5311 outline-buffer)
5312 "Update passphrase verifier and hint strings if necessary.
5313
5314 See `allout-passphrase-verifier-string' and `allout-passphrase-hint-string'
5315 settings.
5316
5317 PASSPHRASE is the passphrase being mnemonicized
5318
5319 OUTLINE-BUFFER is the buffer of the outline being adjusted.
5320
5321 These are used to help the user keep track of the passphrase they use for
5322 symmetric encryption in the file.
5323
5324 Behavior is governed by `allout-passphrase-verifier-handling',
5325 `allout-passphrase-hint-handling', and also, controlling whether the values
5326 are preserved on Emacs local file variables,
5327 `allout-enable-file-variable-adjustment'."
5328
5329 ;; If passphrase doesn't agree with current verifier:
5330 ;; - adjust the verifier
5331 ;; - if passphrase hint handling is enabled, adjust the passphrase hint
5332 ;; - if file var settings are enabled, adjust the file vars
5333
5334 (let* ((new-verifier-needed (not (allout-verify-passphrase
5335 for-key passphrase outline-buffer)))
5336 (new-verifier-string
5337 (if new-verifier-needed
5338 ;; Collapse to a single line and enclose in string quotes:
5339 (subst-char-in-string
5340 ?\n ?\C-a (allout-create-encryption-passphrase-verifier
5341 passphrase))))
5342 new-hint)
5343 (when new-verifier-string
5344 ;; do the passphrase hint first, since it's interactive
5345 (when (and allout-passphrase-hint-handling
5346 (not (equal allout-passphrase-hint-handling 'disabled)))
5347 (setq new-hint
5348 (read-from-minibuffer "Passphrase hint to jog your memory: "
5349 allout-passphrase-hint-string))
5350 (when (not (string= new-hint allout-passphrase-hint-string))
5351 (setq allout-passphrase-hint-string new-hint)
5352 (allout-adjust-file-variable "allout-passphrase-hint-string"
5353 allout-passphrase-hint-string)))
5354 (when allout-passphrase-verifier-handling
5355 (setq allout-passphrase-verifier-string new-verifier-string)
5356 (allout-adjust-file-variable "allout-passphrase-verifier-string"
5357 allout-passphrase-verifier-string))
5358 )
5359 )
5360 )
5361 ;;;_ > allout-get-encryption-passphrase-verifier ()
5362 (defun allout-get-encryption-passphrase-verifier ()
5363 "Return text of the encrypt passphrase verifier, unmassaged, or nil if none.
5364
5365 Derived from value of `allout-passphrase-verifier-string'."
5366
5367 (let ((verifier-string (and (boundp 'allout-passphrase-verifier-string)
5368 allout-passphrase-verifier-string)))
5369 (if verifier-string
5370 ;; Return it uncollapsed
5371 (subst-char-in-string ?\C-a ?\n verifier-string))
5372 )
5373 )
5374 ;;;_ > allout-verify-passphrase (key passphrase allout-buffer)
5375 (defun allout-verify-passphrase (key passphrase allout-buffer)
5376 "True if passphrase successfully decrypts verifier, nil otherwise.
5377
5378 \"Otherwise\" includes absence of passphrase verifier."
5379 (save-excursion
5380 (set-buffer allout-buffer)
5381 (and (boundp 'allout-passphrase-verifier-string)
5382 allout-passphrase-verifier-string
5383 (allout-encrypt-string (allout-get-encryption-passphrase-verifier)
5384 'decrypt allout-buffer 'symmetric
5385 key nil 0 'verifying passphrase)
5386 t)))
5387 ;;;_ > allout-next-topic-pending-encryption (&optional except-mark)
5388 (defun allout-next-topic-pending-encryption (&optional except-mark)
5389 "Return the point of the next topic pending encryption, or nil if none.
5390
5391 EXCEPT-MARK identifies a point whose containing topics should be excluded
5392 from encryption. This supports 'except-current mode of
5393 `allout-encrypt-unencrypted-on-saves'.
5394
5395 Such a topic has the allout-topic-encryption-bullet without an
5396 immediately following '*' that would mark the topic as being encrypted. It
5397 must also have content."
5398 (let (done got content-beg)
5399 (while (not done)
5400
5401 (if (not (re-search-forward
5402 (format "\\(\\`\\|\n\\)%s *%s[^*]"
5403 (regexp-quote allout-header-prefix)
5404 (regexp-quote allout-topic-encryption-bullet))
5405 nil t))
5406 (setq got nil
5407 done t)
5408 (goto-char (setq got (match-beginning 0)))
5409 (if (looking-at "\n")
5410 (forward-char 1))
5411 (setq got (point)))
5412
5413 (cond ((not got)
5414 (setq done t))
5415
5416 ((not (search-forward "\n"))
5417 (setq got nil
5418 done t))
5419
5420 ((eobp)
5421 (setq got nil
5422 done t))
5423
5424 (t
5425 (setq content-beg (point))
5426 (backward-char 1)
5427 (allout-end-of-subtree)
5428 (if (or (<= (point) content-beg)
5429 (and except-mark
5430 (<= content-beg except-mark)
5431 (>= (point) except-mark)))
5432 ;; Continue looking
5433 (setq got nil)
5434 ;; Got it!
5435 (setq done t)))
5436 )
5437 )
5438 (if got
5439 (goto-char got))
5440 )
5441 )
5442 ;;;_ > allout-encrypt-decrypted (&optional except-mark)
5443 (defun allout-encrypt-decrypted (&optional except-mark)
5444 "Encrypt topics pending encryption except those containing exemption point.
5445
5446 EXCEPT-MARK identifies a point whose containing topics should be excluded
5447 from encryption. This supports 'except-current mode of
5448 `allout-encrypt-unencrypted-on-saves'.
5449
5450 If a topic that is currently being edited was encrypted, we return a list
5451 containing the location of the topic and the location of the cursor just
5452 before the topic was encrypted. This can be used, eg, to decrypt the topic
5453 and exactly resituate the cursor if this is being done as part of a file
5454 save. See `allout-encrypt-unencrypted-on-saves' for more info."
5455
5456 (interactive "p")
5457 (save-excursion
5458 (let* ((current-mark (point-marker))
5459 (current-mark-position (marker-position current-mark))
5460 was-modified
5461 bo-subtree
5462 editing-topic editing-point)
5463 (goto-char (point-min))
5464 (while (allout-next-topic-pending-encryption except-mark)
5465 (setq was-modified (buffer-modified-p))
5466 (when (save-excursion
5467 (and (boundp 'allout-encrypt-unencrypted-on-saves)
5468 allout-encrypt-unencrypted-on-saves
5469 (setq bo-subtree (re-search-forward "$"))
5470 (not (allout-hidden-p))
5471 (>= current-mark (point))
5472 (allout-end-of-current-subtree)
5473 (<= current-mark (point))))
5474 (setq editing-topic (point)
5475 ;; we had to wait for this 'til now so prior topics are
5476 ;; encrypted, any relevant text shifts are in place:
5477 editing-point (- current-mark-position
5478 (count-trailing-whitespace-region
5479 bo-subtree current-mark-position))))
5480 (allout-toggle-subtree-encryption)
5481 (if (not was-modified)
5482 (set-buffer-modified-p nil))
5483 )
5484 (if (not was-modified)
5485 (set-buffer-modified-p nil))
5486 (if editing-topic (list editing-topic editing-point))
5487 )
5488 )
5489 )
5490
5491 ;;;_ #9 miscellaneous
5492 ;;;_ > allout-mark-topic ()
5493 (defun allout-mark-topic ()
5494 "Put the region around topic currently containing point."
5495 (interactive)
5496 (beginning-of-line)
5497 (allout-goto-prefix)
5498 (push-mark (point))
5499 (allout-end-of-current-subtree)
5500 (exchange-point-and-mark))
5501 ;;;_ > outlineify-sticky ()
5502 ;; outlinify-sticky is correct spelling; provide this alias for sticklers:
5503 ;;;###autoload
5504 (defalias 'outlinify-sticky 'outlineify-sticky)
5505 ;;;###autoload
5506 (defun outlineify-sticky (&optional arg)
5507 "Activate outline mode and establish file var so it is started subsequently.
5508
5509 See doc-string for `allout-layout' and `allout-init' for details on
5510 setup for auto-startup."
5511
5512 (interactive "P")
5513
5514 (allout-mode t)
5515
5516 (save-excursion
5517 (goto-char (point-min))
5518 (if (looking-at allout-regexp)
5519 t
5520 (allout-open-topic 2)
5521 (insert (concat "Dummy outline topic header - see"
5522 "`allout-mode' docstring: `^Hm'."))
5523 (allout-adjust-file-variable
5524 "allout-layout" (or allout-layout '(-1 : 0))))))
5525 ;;;_ > allout-file-vars-section-data ()
5526 (defun allout-file-vars-section-data ()
5527 "Return data identifying the file-vars section, or nil if none.
5528
5529 Returns list `(beginning-point prefix-string suffix-string)'."
5530 ;; minimally gleaned from emacs 21.4 files.el hack-local-variables function.
5531 (let (beg prefix suffix)
5532 (save-excursion
5533 (goto-char (point-max))
5534 (search-backward "\n\^L" (max (- (point-max) 3000) (point-min)) 'move)
5535 (if (let ((case-fold-search t))
5536 (not (search-forward "Local Variables:" nil t)))
5537 nil
5538 (setq beg (- (point) 16))
5539 (setq suffix (buffer-substring-no-properties
5540 (point)
5541 (progn (if (search-forward "\n" nil t)
5542 (forward-char -1))
5543 (point))))
5544 (setq prefix (buffer-substring-no-properties
5545 (progn (if (search-backward "\n" nil t)
5546 (forward-char 1))
5547 (point))
5548 beg))
5549 (list beg prefix suffix))
5550 )
5551 )
5552 )
5553 ;;;_ > allout-adjust-file-variable (varname value)
5554 (defun allout-adjust-file-variable (varname value)
5555 "Adjust the setting of an emacs file variable named VARNAME to VALUE.
5556
5557 This activity is inhibited if either `enable-local-variables'
5558 `allout-enable-file-variable-adjustment' are nil.
5559
5560 When enabled, an entry for the variable is created if not already present,
5561 or changed if established with a different value. The section for the file
5562 variables, itself, is created if not already present. When created, the
5563 section lines \(including the section line) exist as second-level topics in
5564 a top-level topic at the end of the file.
5565
5566 enable-local-variables must be true for any of this to happen."
5567 (if (not (and enable-local-variables
5568 allout-enable-file-variable-adjustment))
5569 nil
5570 (save-excursion
5571 (let ((section-data (allout-file-vars-section-data))
5572 beg prefix suffix)
5573 (if section-data
5574 (setq beg (car section-data)
5575 prefix (cadr section-data)
5576 suffix (car (cddr section-data)))
5577 ;; create the section
5578 (goto-char (point-max))
5579 (open-line 1)
5580 (allout-open-topic 0)
5581 (end-of-line)
5582 (insert "Local emacs vars.\n")
5583 (allout-open-topic 1)
5584 (setq beg (point)
5585 suffix ""
5586 prefix (buffer-substring-no-properties (progn
5587 (beginning-of-line)
5588 (point))
5589 beg))
5590 (goto-char beg)
5591 (insert "Local variables:\n")
5592 (allout-open-topic 0)
5593 (insert "End:\n")
5594 )
5595 ;; look for existing entry or create one, leaving point for insertion
5596 ;; of new value:
5597 (goto-char beg)
5598 (allout-show-to-offshoot)
5599 (if (search-forward (concat "\n" prefix varname ":") nil t)
5600 (let* ((value-beg (point))
5601 (line-end (progn (if (search-forward "\n" nil t)
5602 (forward-char -1))
5603 (point)))
5604 (value-end (- line-end (length suffix))))
5605 (if (> value-end value-beg)
5606 (delete-region value-beg value-end)))
5607 (end-of-line)
5608 (open-line 1)
5609 (forward-line 1)
5610 (insert (concat prefix varname ":")))
5611 (insert (format " %S%s" value suffix))
5612 )
5613 )
5614 )
5615 )
5616 ;;;_ > solicit-char-in-string (prompt string &optional do-defaulting)
5617 (defun solicit-char-in-string (prompt string &optional do-defaulting)
5618 "Solicit (with first arg PROMPT) choice of a character from string STRING.
5619
5620 Optional arg DO-DEFAULTING indicates to accept empty input (CR)."
5621
5622 (let ((new-prompt prompt)
5623 got)
5624
5625 (while (not got)
5626 (message "%s" new-prompt)
5627
5628 ;; We do our own reading here, so we can circumvent, eg, special
5629 ;; treatment for `?' character. (Oughta use minibuffer keymap instead.)
5630 (setq got
5631 (char-to-string (let ((cursor-in-echo-area nil)) (read-char))))
5632
5633 (setq got
5634 (cond ((string-match (regexp-quote got) string) got)
5635 ((and do-defaulting (string= got "\r"))
5636 ;; Return empty string to default:
5637 "")
5638 ((string= got "\C-g") (signal 'quit nil))
5639 (t
5640 (setq new-prompt (concat prompt
5641 got
5642 " ...pick from: "
5643 string
5644 ""))
5645 nil))))
5646 ;; got something out of loop - return it:
5647 got)
5648 )
5649 ;;;_ > regexp-sans-escapes (string)
5650 (defun regexp-sans-escapes (regexp &optional successive-backslashes)
5651 "Return a copy of REGEXP with all character escapes stripped out.
5652
5653 Representations of actual backslashes - '\\\\\\\\' - are left as a
5654 single backslash.
5655
5656 Optional arg SUCCESSIVE-BACKSLASHES is used internally for recursion."
5657
5658 (if (string= regexp "")
5659 ""
5660 ;; Set successive-backslashes to number if current char is
5661 ;; backslash, or else to nil:
5662 (setq successive-backslashes
5663 (if (= (aref regexp 0) ?\\)
5664 (if successive-backslashes (1+ successive-backslashes) 1)
5665 nil))
5666 (if (or (not successive-backslashes) (= 2 successive-backslashes))
5667 ;; Include first char:
5668 (concat (substring regexp 0 1)
5669 (regexp-sans-escapes (substring regexp 1)))
5670 ;; Exclude first char, but maintain count:
5671 (regexp-sans-escapes (substring regexp 1) successive-backslashes))))
5672 ;;;_ > count-trailing-whitespace-region (beg end)
5673 (defun count-trailing-whitespace-region (beg end)
5674 "Return number of trailing whitespace chars between BEG and END.
5675
5676 If BEG is bigger than END we return 0."
5677 (if (> beg end)
5678 0
5679 (save-excursion
5680 (goto-char beg)
5681 (let ((count 0))
5682 (while (re-search-forward "[ ][ ]*$" end t)
5683 (goto-char (1+ (match-beginning 0)))
5684 (setq count (1+ count)))
5685 count))))
5686 ;;;_ > allout-mark-marker to accommodate divergent emacsen:
5687 (defun allout-mark-marker (&optional force buffer)
5688 "Accommodate the different signature for `mark-marker' across Emacsen.
5689
5690 XEmacs takes two optional args, while mainline GNU Emacs does not,
5691 so pass them along when appropriate."
5692 (if (featurep 'xemacs)
5693 (apply 'mark-marker force buffer)
5694 (mark-marker)))
5695 ;;;_ > subst-char-in-string if necessary
5696 (if (not (fboundp 'subst-char-in-string))
5697 (defun subst-char-in-string (fromchar tochar string &optional inplace)
5698 "Replace FROMCHAR with TOCHAR in STRING each time it occurs.
5699 Unless optional argument INPLACE is non-nil, return a new string."
5700 (let ((i (length string))
5701 (newstr (if inplace string (copy-sequence string))))
5702 (while (> i 0)
5703 (setq i (1- i))
5704 (if (eq (aref newstr i) fromchar)
5705 (aset newstr i tochar)))
5706 newstr)))
5707 ;;;_ > wholenump if necessary
5708 (if (not (fboundp 'wholenump))
5709 (defalias 'wholenump 'natnump))
5710 ;;;_ > remove-overlays if necessary
5711 (if (not (fboundp 'remove-overlays))
5712 (defun remove-overlays (&optional beg end name val)
5713 "Clear BEG and END of overlays whose property NAME has value VAL.
5714 Overlays might be moved and/or split.
5715 BEG and END default respectively to the beginning and end of buffer."
5716 (unless beg (setq beg (point-min)))
5717 (unless end (setq end (point-max)))
5718 (if (< end beg)
5719 (setq beg (prog1 end (setq end beg))))
5720 (save-excursion
5721 (dolist (o (overlays-in beg end))
5722 (when (eq (overlay-get o name) val)
5723 ;; Either push this overlay outside beg...end
5724 ;; or split it to exclude beg...end
5725 ;; or delete it entirely (if it is contained in beg...end).
5726 (if (< (overlay-start o) beg)
5727 (if (> (overlay-end o) end)
5728 (progn
5729 (move-overlay (copy-overlay o)
5730 (overlay-start o) beg)
5731 (move-overlay o end (overlay-end o)))
5732 (move-overlay o (overlay-start o) beg))
5733 (if (> (overlay-end o) end)
5734 (move-overlay o end (overlay-end o))
5735 (delete-overlay o)))))))
5736 )
5737 ;;;_ > copy-overlay if necessary - xemacs ~ 21.4
5738 (if (not (fboundp 'copy-overlay))
5739 (defun copy-overlay (o)
5740 "Return a copy of overlay O."
5741 (let ((o1 (make-overlay (overlay-start o) (overlay-end o)
5742 ;; FIXME: there's no easy way to find the
5743 ;; insertion-type of the two markers.
5744 (overlay-buffer o)))
5745 (props (overlay-properties o)))
5746 (while props
5747 (overlay-put o1 (pop props) (pop props)))
5748 o1)))
5749 ;;;_ > add-to-invisibility-spec if necessary - xemacs ~ 21.4
5750 (if (not (fboundp 'add-to-invisibility-spec))
5751 (defun add-to-invisibility-spec (element)
5752 "Add ELEMENT to `buffer-invisibility-spec'.
5753 See documentation for `buffer-invisibility-spec' for the kind of elements
5754 that can be added."
5755 (if (eq buffer-invisibility-spec t)
5756 (setq buffer-invisibility-spec (list t)))
5757 (setq buffer-invisibility-spec
5758 (cons element buffer-invisibility-spec))))
5759 ;;;_ > remove-from-invisibility-spec if necessary - xemacs ~ 21.4
5760 (if (not (fboundp 'remove-from-invisibility-spec))
5761 (defun remove-from-invisibility-spec (element)
5762 "Remove ELEMENT from `buffer-invisibility-spec'."
5763 (if (consp buffer-invisibility-spec)
5764 (setq buffer-invisibility-spec (delete element
5765 buffer-invisibility-spec)))))
5766 ;;;_ > move-beginning-of-line if necessary - older emacs, xemacs
5767 (if (not (fboundp 'move-beginning-of-line))
5768 (defun move-beginning-of-line (arg)
5769 "Move point to beginning of current line as displayed.
5770 \(This disregards invisible newlines such as those
5771 which are part of the text that an image rests on.)
5772
5773 With argument ARG not nil or 1, move forward ARG - 1 lines first.
5774 If point reaches the beginning or end of buffer, it stops there.
5775 To ignore intangibility, bind `inhibit-point-motion-hooks' to t."
5776 (interactive "p")
5777 (or arg (setq arg 1))
5778 (if (/= arg 1)
5779 (condition-case nil (line-move (1- arg)) (error nil)))
5780
5781 (let ((orig (point)))
5782 ;; Move to beginning-of-line, ignoring fields and invisibles.
5783 (skip-chars-backward "^\n")
5784 (while (and (not (bobp)) (line-move-invisible-p (1- (point))))
5785 (goto-char (if (featurep 'xemacs)
5786 (previous-property-change (point))
5787 (previous-char-property-change (point))))
5788 (skip-chars-backward "^\n"))
5789 (vertical-motion 0)
5790 (if (/= orig (point))
5791 (goto-char orig))))
5792 )
5793 ;;;_ > move-end-of-line if necessary - older emacs, xemacs
5794 (if (not (fboundp 'move-end-of-line))
5795 (defun move-end-of-line (arg)
5796 "Move point to end of current line as displayed.
5797 \(This disregards invisible newlines such as those
5798 which are part of the text that an image rests on.)
5799
5800 With argument ARG not nil or 1, move forward ARG - 1 lines first.
5801 If point reaches the beginning or end of buffer, it stops there.
5802 To ignore intangibility, bind `inhibit-point-motion-hooks' to t."
5803 (interactive "p")
5804 (or arg (setq arg 1))
5805 (let ((orig (point))
5806 done)
5807 (while (not done)
5808 (let ((newpos
5809 (save-excursion
5810 (let ((goal-column 0))
5811 (and (condition-case nil
5812 (or (line-move arg) t)
5813 (error nil))
5814 (not (bobp))
5815 (progn
5816 (while (and (not (bobp)) (line-move-invisible-p (1- (point))))
5817 (goto-char (previous-char-property-change (point))))
5818 (backward-char 1)))
5819 (point)))))
5820 (goto-char newpos)
5821 (if (and (> (point) newpos)
5822 (eq (preceding-char) ?\n))
5823 (backward-char 1)
5824 (if (and (> (point) newpos) (not (eobp))
5825 (not (eq (following-char) ?\n)))
5826 ;; If we skipped something intangible
5827 ;; and now we're not really at eol,
5828 ;; keep going.
5829 (setq arg 1)
5830 (setq done t)))))
5831 (if (/= orig (point))
5832 (goto-char orig))))
5833 )
5834 ;;;_ > line-move-invisible-p if necessary
5835 (if (not (fboundp 'line-move-invisible-p))
5836 (defun line-move-invisible-p (pos)
5837 "Return non-nil if the character after POS is currently invisible."
5838 (let ((prop
5839 (get-char-property pos 'invisible)))
5840 (if (eq buffer-invisibility-spec t)
5841 prop
5842 (or (memq prop buffer-invisibility-spec)
5843 (assq prop buffer-invisibility-spec))))))
5844
5845
5846 ;;;_ #10 Unfinished
5847 ;;;_ > allout-bullet-isearch (&optional bullet)
5848 (defun allout-bullet-isearch (&optional bullet)
5849 "Isearch \(regexp) for topic with bullet BULLET."
5850 (interactive)
5851 (if (not bullet)
5852 (setq bullet (solicit-char-in-string
5853 "ISearch for topic with bullet: "
5854 (regexp-sans-escapes allout-bullets-string))))
5855
5856 (let ((isearch-regexp t)
5857 (isearch-string (concat "^"
5858 allout-header-prefix
5859 "[ \t]*"
5860 bullet)))
5861 (isearch-repeat 'forward)
5862 (isearch-mode t)))
5863
5864 ;;;_ #11 Provide
5865 (provide 'allout)
5866
5867 ;;;_* Local emacs vars.
5868 ;; The following `allout-layout' local variable setting:
5869 ;; - closes all topics from the first topic to just before the third-to-last,
5870 ;; - shows the children of the third to last (config vars)
5871 ;; - and the second to last (code section),
5872 ;; - and closes the last topic (this local-variables section).
5873 ;;Local variables:
5874 ;;allout-layout: (0 : -1 -1 0)
5875 ;;End:
5876
5877 ;; arch-tag: cf38fbc3-c044-450f-8bff-afed8ba5681c
5878 ;;; allout.el ends here