Fix up display of the *Minibuf-0* buffer in the mini window.
[emacs.git] / lisp / allout.el
blob6e544716247844d6bf79d5b2c400e38cccd282b6
1 ;;; allout.el --- extensive outline mode for use alone and with other modes
3 ;; Copyright (C) 1992-1994, 2001-2012 Free Software Foundation, Inc.
5 ;; Author: Ken Manheimer <ken dot manheimer at gmail...>
6 ;; Maintainer: Ken Manheimer <ken dot manheimer at gmail...>
7 ;; Created: Dec 1991 -- first release to usenet
8 ;; Version: 2.3
9 ;; Keywords: outlines, wp, languages, PGP, GnuPG
10 ;; Website: http://myriadicity.net/software-and-systems/craft/emacs-allout
12 ;; This file is part of GNU Emacs.
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 3 of the License, or
17 ;; (at your option) any later version.
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.
24 ;; You should have received a copy of the GNU General Public License
25 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
27 ;;; Commentary:
29 ;; Allout outline minor mode provides extensive outline formatting and
30 ;; and manipulation beyond standard emacs outline mode. Some features:
32 ;; - Classic outline-mode topic-oriented navigation and exposure adjustment
33 ;; - Topic-oriented editing including coherent topic and subtopic
34 ;; creation, promotion, demotion, cut/paste across depths, etc.
35 ;; - Incremental search with dynamic exposure and reconcealment of text
36 ;; - Customizable bullet format -- enables programming-language specific
37 ;; outlining, for code-folding editing. (Allout code itself is to try it;
38 ;; formatted as an outline -- do ESC-x eval-buffer in allout.el; but
39 ;; emacs local file variables need to be enabled when the
40 ;; file was visited -- see `enable-local-variables'.)
41 ;; - Configurable per-file initial exposure settings
42 ;; - Symmetric-key and key-pair topic encryption. Encryption is via the
43 ;; Emacs 'epg' library. See allout-toggle-current-subtree-encryption
44 ;; docstring.
45 ;; - Automatic topic-number maintenance
46 ;; - "Hot-spot" operation, for single-keystroke maneuvering and
47 ;; exposure control (see the allout-mode docstring)
48 ;; - Easy rendering of exposed portions into numbered, latex, indented, etc
49 ;; outline styles
50 ;; - Careful attention to whitespace -- enabling blank lines between items
51 ;; and maintenance of hanging indentation (in paragraph auto-fill and
52 ;; across topic promotion and demotion) of topic bodies consistent with
53 ;; indentation of their topic header.
55 ;; and more.
57 ;; See the `allout-mode' function's docstring for an introduction to the
58 ;; mode.
60 ;; Directions to the latest development version and helpful notes are
61 ;; available at http://myriadicity.net/Sundry/EmacsAllout .
63 ;; The outline menubar additions provide quick reference to many of the
64 ;; features. See the docstring of the variables `allout-layout' and
65 ;; `allout-auto-activation' for details on automatic activation of
66 ;; `allout-mode' as a minor mode. (`allout-init' is deprecated in favor of
67 ;; a purely customization-based method.)
69 ;; Note -- the lines beginning with `;;;_' are outline topic headers.
70 ;; Customize `allout-auto-activation' to enable, then revisit this
71 ;; buffer to give it a whirl.
73 ;; ken manheimer (ken dot manheimer at gmail dot com)
75 ;;; Code:
77 ;;;_* Dependency loads
78 (require 'overlay)
79 (eval-when-compile
80 ;; Most of the requires here are for stuff covered by autoloads, which
81 ;; byte-compiling doesn't trigger.
82 (require 'epg)
83 (require 'epa)
84 (require 'overlay)
85 ;; `cl' is required for `assert'. `assert' is not covered by a standard
86 ;; autoload, but it is a macro, so that eval-when-compile is sufficient
87 ;; to byte-compile it in, or to do the require when the buffer evalled.
88 (require 'cl)
91 ;;;_* USER CUSTOMIZATION VARIABLES:
93 ;;;_ > defgroup allout, allout-keybindings
94 (defgroup allout nil
95 "Extensive outline minor-mode, for use stand-alone and with other modes.
97 See Allout Auto Activation for automatic activation."
98 :prefix "allout-"
99 :group 'outlines)
100 (defgroup allout-keybindings nil
101 "Allout outline mode keyboard bindings configuration."
102 :group 'allout)
104 ;;;_ + Layout, Mode, and Topic Header Configuration
106 (defvar allout-command-prefix) ; defined below
108 ;;;_ > allout-keybindings incidentals:
109 ;;;_ : internal key binding stuff - in this section for load-order.
110 ;;;_ = allout-mode-map
111 (defvar allout-mode-map 'allout-mode-map
112 "Keybindings place-holder for (allout) outline minor mode.
114 Do NOT set the value of this variable. Instead, customize
115 `allout-command-prefix', `allout-prefixed-keybindings', and
116 `allout-unprefixed-keybindings'.")
117 ;;;_ = allout-mode-map-value
118 (defvar allout-mode-map-value nil
119 "Keymap for allout outline minor mode.
121 Do NOT set the value of this variable. Instead, customize
122 `allout-command-prefix', `allout-prefixed-keybindings', and
123 `allout-unprefixed-keybindings'.")
124 ;;;_ = make allout-mode-map-value an alias for allout-mode-map:
125 ;; this needs to be revised when the value is changed, sigh.
126 (defalias 'allout-mode-map allout-mode-map-value)
127 ;;;_ > allout-compose-and-institute-keymap (&optional varname value)
128 (defun allout-compose-and-institute-keymap (&optional varname value)
129 "Create the allout keymap according to the keybinding specs, and set it.
131 Useful standalone or to effect customizations of the
132 respective allout-mode keybinding variables, `allout-command-prefix',
133 `allout-prefixed-keybindings', and `allout-unprefixed-keybindings'"
134 ;; Set the customization variable, if any:
135 (when varname
136 (set-default varname value))
137 (let ((map (make-sparse-keymap)))
138 (when (boundp 'allout-prefixed-keybindings)
139 ;; tolerate first definitions of the variables:
140 (dolist (entry allout-prefixed-keybindings)
141 (define-key map
142 ;; XXX vector vs non-vector key descriptions?
143 (vconcat allout-command-prefix
144 (car (read-from-string (car entry))))
145 (cadr entry))))
146 (when (boundp 'allout-unprefixed-keybindings)
147 (dolist (entry allout-unprefixed-keybindings)
148 (define-key map (car (read-from-string (car entry))) (cadr entry))))
149 (substitute-key-definition 'beginning-of-line 'allout-beginning-of-line
150 map global-map)
151 (substitute-key-definition 'move-beginning-of-line 'allout-beginning-of-line
152 map global-map)
153 (substitute-key-definition 'end-of-line 'allout-end-of-line
154 map global-map)
155 (substitute-key-definition 'move-end-of-line 'allout-end-of-line
156 map global-map)
157 (allout-institute-keymap map)))
158 ;;;_ > allout-institute-keymap (map)
159 (defun allout-institute-keymap (map)
160 "Associate allout-mode bindings with allout as a minor mode."
161 ;; Architecture:
162 ;; allout-mode-map var is a keymap by virtue of being a defalias for
163 ;; allout-mode-map-value, which has the actual keymap value.
164 ;; allout-mode-map's symbol value is just 'allout-mode-map, so it can be
165 ;; used in minor-mode-map-alist to indirect to the actual
166 ;; allout-mode-map-var value, which can be adjusted and reassigned.
168 ;; allout-mode-map-value for keymap reference in various places:
169 (setq allout-mode-map-value map)
170 ;; the function value keymap of allout-mode-map is used in
171 ;; minor-mode-map-alist - update it:
172 (fset allout-mode-map allout-mode-map-value))
173 ;;;_ * initialize the mode map:
174 ;; ensure that allout-mode-map has some setting even if allout-mode hasn't
175 ;; been invoked:
176 (allout-compose-and-institute-keymap)
177 ;;;_ = allout-command-prefix
178 (defcustom allout-command-prefix "\C-c "
179 "Key sequence to be used as prefix for outline mode command key bindings.
181 Default is '\C-c<space>'; just '\C-c' is more short-and-sweet, if you're
182 willing to let allout use a bunch of \C-c keybindings."
183 :type 'string
184 :group 'allout-keybindings
185 :set 'allout-compose-and-institute-keymap)
186 ;;;_ = allout-keybindings-binding
187 (define-widget 'allout-keybindings-binding 'lazy
188 "Structure of allout keybindings customization items."
189 :type '(repeat
190 (list (string :tag "Key" :value "[(meta control shift ?f)]")
191 (function :tag "Function name"
192 :value allout-forward-current-level))))
193 ;;;_ = allout-prefixed-keybindings
194 (defcustom allout-prefixed-keybindings
195 '(("[(control ?n)]" allout-next-visible-heading)
196 ("[(control ?p)]" allout-previous-visible-heading)
197 ("[(control ?u)]" allout-up-current-level)
198 ("[(control ?f)]" allout-forward-current-level)
199 ("[(control ?b)]" allout-backward-current-level)
200 ("[(control ?a)]" allout-beginning-of-current-entry)
201 ("[(control ?e)]" allout-end-of-entry)
202 ("[(control ?i)]" allout-show-children)
203 ("[(control ?s)]" allout-show-current-subtree)
204 ("[(control ?t)]" allout-toggle-current-subtree-exposure)
205 ;; Let user customize if they want to preempt describe-prefix-bindings ^h use.
206 ;; ("[(control ?h)]" allout-hide-current-subtree)
207 ("[?h]" allout-hide-current-subtree)
208 ("[(control ?o)]" allout-show-current-entry)
209 ("[?!]" allout-show-all)
210 ("[?x]" allout-toggle-current-subtree-encryption)
211 ("[? ]" allout-open-sibtopic)
212 ("[?.]" allout-open-subtopic)
213 ("[?,]" allout-open-supertopic)
214 ("[?']" allout-shift-in)
215 ("[?>]" allout-shift-in)
216 ("[?<]" allout-shift-out)
217 ("[(control ?m)]" allout-rebullet-topic)
218 ("[?*]" allout-rebullet-current-heading)
219 ("[?#]" allout-number-siblings)
220 ("[(control ?k)]" allout-kill-topic)
221 ("[(meta ?k)]" allout-copy-topic-as-kill)
222 ("[?@]" allout-resolve-xref)
223 ("[?=?c]" allout-copy-exposed-to-buffer)
224 ("[?=?i]" allout-indented-exposed-to-buffer)
225 ("[?=?t]" allout-latexify-exposed)
226 ("[?=?p]" allout-flatten-exposed-to-buffer)
228 "Allout-mode key bindings that are prefixed with `allout-command-prefix'.
230 See `allout-unprefixed-keybindings' for the list of keybindings
231 that are not prefixed.
233 Use vector format for the keys:
234 - put literal keys after a '?' question mark, eg: '?a', '?.'
235 - enclose control, shift, or meta-modified keys as sequences within
236 parentheses, with the literal key, as above, preceded by the name(s)
237 of the modifiers, eg: [(control ?a)]
238 See the existing keys for examples.
240 Functions can be bound to multiple keys, but binding keys to
241 multiple functions will not work - the last binding for a key
242 prevails."
243 :version "24.1"
244 :type 'allout-keybindings-binding
245 :group 'allout-keybindings
246 :set 'allout-compose-and-institute-keymap
248 ;;;_ = allout-unprefixed-keybindings
249 (defcustom allout-unprefixed-keybindings
250 '(("[(control ?k)]" allout-kill-line)
251 ("[(meta ?k)]" allout-copy-line-as-kill)
252 ("[(control ?y)]" allout-yank)
253 ("[(meta ?y)]" allout-yank-pop)
255 "Allout-mode functions bound to keys without any added prefix.
257 This is in contrast to the majority of allout-mode bindings on
258 `allout-prefixed-bindings', whose bindings are created with a
259 preceding command key.
261 Use vector format for the keys:
262 - put literal keys after a '?' question mark, eg: '?a', '?.'
263 - enclose control, shift, or meta-modified keys as sequences within
264 parentheses, with the literal key, as above, preceded by the name(s)
265 of the modifiers, eg: [(control ?a)]
266 See the existing keys for examples."
267 :version "24.1"
268 :type 'allout-keybindings-binding
269 :group 'allout-keybindings
270 :set 'allout-compose-and-institute-keymap
273 ;;;_ > allout-auto-activation-helper (var value)
274 ;;;###autoload
275 (defun allout-auto-activation-helper (var value)
276 "Institute `allout-auto-activation'.
278 Intended to be used as the `allout-auto-activation' :set function."
279 (set-default var value)
280 (allout-setup))
281 ;;;_ > allout-setup ()
282 ;;;###autoload
283 (defun allout-setup ()
284 "Do fundamental Emacs session for allout auto-activation.
286 Establishes allout processing as part of visiting a file if
287 `allout-auto-activation' is non-nil, or removes it otherwise.
289 The proper way to use this is through customizing the setting of
290 `allout-auto-activation'."
291 (if (not allout-auto-activation)
292 (remove-hook 'find-file-hook 'allout-find-file-hook)
293 (add-hook 'find-file-hook 'allout-find-file-hook)))
294 ;;;_ = allout-auto-activation
295 ;;;###autoload
296 (defcustom allout-auto-activation nil
297 "Configure allout outline mode auto-activation.
299 Control whether and how allout outline mode is automatically
300 activated when files are visited with non-nil buffer-specific
301 file variable `allout-layout'.
303 When allout-auto-activation is \"On\" (t), allout mode is
304 activated in buffers with non-nil `allout-layout', and the
305 specified layout is applied.
307 With value \"ask\", auto-mode-activation is enabled, and endorsement for
308 performing auto-layout is asked of the user each time.
310 With value \"activate\", only auto-mode-activation is enabled.
311 Auto-layout is not.
313 With value nil, inhibit any automatic allout-mode activation."
314 :set 'allout-auto-activation-helper
315 ;; FIXME: Using strings here is unusual and less efficient than symbols.
316 :type '(choice (const :tag "On" t)
317 (const :tag "Ask about layout" "ask")
318 (const :tag "Mode only" "activate")
319 (const :tag "Off" nil))
320 :group 'allout)
321 (allout-setup)
322 ;;;_ = allout-default-layout
323 (defcustom allout-default-layout '(-2 : 0)
324 "Default allout outline layout specification.
326 This setting specifies the outline exposure to use when
327 `allout-layout' has the local value `t'. This docstring describes the
328 layout specifications.
330 A list value specifies a default layout for the current buffer,
331 to be applied upon activation of `allout-mode'. Any non-nil
332 value will automatically trigger `allout-mode', provided
333 `allout-auto-activation' has been customized to enable it.
335 The types of elements in the layout specification are:
337 INTEGER -- dictate the relative depth to open the corresponding topic(s),
338 where:
339 -- negative numbers force the topic to be closed before opening
340 to the absolute value of the number, so all siblings are open
341 only to that level.
342 -- positive numbers open to the relative depth indicated by the
343 number, but do not force already opened subtopics to be closed.
344 -- 0 means to close topic -- hide all subitems.
345 : -- repeat spec -- apply the preceding element to all siblings at
346 current level, *up to* those siblings that would be covered by specs
347 following the `:' on the list. Ie, apply to all topics at level but
348 trailing ones accounted for by trailing specs. (Only the first of
349 multiple colons at the same level is honored -- later ones are ignored.)
350 * -- completely exposes the topic, including bodies
351 + -- exposes all subtopics, but not the bodies
352 - -- exposes the body of the corresponding topic, but not subtopics
353 LIST -- a nested layout spec, to be applied intricately to its
354 corresponding item(s)
356 Examples:
357 (-2 : 0)
358 Collapse the top-level topics to show their children and
359 grandchildren, but completely collapse the final top-level topic.
360 (-1 () : 1 0)
361 Close the first topic so only the immediate subtopics are shown,
362 leave the subsequent topics exposed as they are until the second
363 second to last topic, which is exposed at least one level, and
364 completely close the last topic.
365 (-2 : -1 *)
366 Expose children and grandchildren of all topics at current
367 level except the last two; expose children of the second to
368 last and completely expose the last one, including its subtopics.
370 See `allout-expose-topic' for more about the exposure process.
372 Also, allout's mode-specific provisions will make topic prefixes default
373 to the comment-start string, if any, of the language of the file. This
374 is modulo the setting of `allout-use-mode-specific-leader', which see."
375 :type 'allout-layout-type
376 :group 'allout)
377 ;;;_ : allout-layout-type
378 (define-widget 'allout-layout-type 'lazy
379 "Allout layout format customization basic building blocks."
380 :type '(repeat
381 (choice (integer :tag "integer (<= zero is strict)")
382 (const :tag ": (repeat prior)" :)
383 (const :tag "* (completely expose)" *)
384 (const :tag "+ (expose all offspring, headlines only)" +)
385 (const :tag "- (expose topic body but not offspring)" -)
386 (allout-layout-type :tag "<Nested layout>"))))
388 ;;;_ = allout-inhibit-auto-fill
389 (defcustom allout-inhibit-auto-fill nil
390 "If non-nil, auto-fill will be inhibited in the allout buffers.
392 You can customize this setting to set it for all allout buffers, or set it
393 in individual buffers if you want to inhibit auto-fill only in particular
394 buffers. (You could use a function on `allout-mode-hook' to inhibit
395 auto-fill according, eg, to the major mode.)
397 If you don't set this and auto-fill-mode is enabled, allout will use the
398 value that `normal-auto-fill-function', if any, when allout mode starts, or
399 else allout's special hanging-indent maintaining auto-fill function,
400 `allout-auto-fill'."
401 :type 'boolean
402 :group 'allout)
403 (make-variable-buffer-local 'allout-inhibit-auto-fill)
404 ;;;_ = allout-inhibit-auto-fill-on-headline
405 (defcustom allout-inhibit-auto-fill-on-headline nil
406 "If non-nil, auto-fill will be inhibited while on topic's header line."
407 :version "24.1"
408 :type 'boolean
409 :group 'allout)
410 (make-variable-buffer-local 'allout-inhibit-auto-fill-on-headline)
411 ;;;_ = allout-use-hanging-indents
412 (defcustom allout-use-hanging-indents t
413 "If non-nil, topic body text auto-indent defaults to indent of the header.
414 Ie, it is indented to be just past the header prefix. This is
415 relevant mostly for use with `indented-text-mode', or other situations
416 where auto-fill occurs."
417 :type 'boolean
418 :group 'allout)
419 (make-variable-buffer-local 'allout-use-hanging-indents)
420 ;;;###autoload
421 (put 'allout-use-hanging-indents 'safe-local-variable
422 (if (fboundp 'booleanp) 'booleanp (lambda (x) (member x '(t nil)))))
423 ;;;_ = allout-reindent-bodies
424 (defcustom allout-reindent-bodies (if allout-use-hanging-indents
425 'text)
426 "Non-nil enables auto-adjust of topic body hanging indent with depth shifts.
428 When active, topic body lines that are indented even with or beyond
429 their topic header are reindented to correspond with depth shifts of
430 the header.
432 A value of t enables reindent in non-programming-code buffers, ie
433 those that do not have the variable `comment-start' set. A value of
434 `force' enables reindent whether or not `comment-start' is set."
435 :type '(choice (const nil) (const t) (const text) (const force))
436 :group 'allout)
438 (make-variable-buffer-local 'allout-reindent-bodies)
439 ;;;###autoload
440 (put 'allout-reindent-bodies 'safe-local-variable
441 (lambda (x) (memq x '(nil t text force))))
443 ;;;_ = allout-show-bodies
444 (defcustom allout-show-bodies nil
445 "If non-nil, show entire body when exposing a topic, rather than
446 just the header."
447 :type 'boolean
448 :group 'allout)
449 (make-variable-buffer-local 'allout-show-bodies)
450 ;;;###autoload
451 (put 'allout-show-bodies 'safe-local-variable
452 (if (fboundp 'booleanp) 'booleanp (lambda (x) (member x '(t nil)))))
454 ;;;_ = allout-beginning-of-line-cycles
455 (defcustom allout-beginning-of-line-cycles t
456 "If non-nil, \\[allout-beginning-of-line] will cycle through smart-placement options.
458 Cycling only happens on when the command is repeated, not when it
459 follows a different command.
461 Smart-placement means that repeated calls to this function will
462 advance as follows:
464 - if the cursor is on a non-headline body line and not on the first column:
465 then it goes to the first column
466 - if the cursor is on the first column of a non-headline body line:
467 then it goes to the start of the headline within the item body
468 - if the cursor is on the headline and not the start of the headline:
469 then it goes to the start of the headline
470 - if the cursor is on the start of the headline:
471 then it goes to the bullet character (for hotspot navigation)
472 - if the cursor is on the bullet character:
473 then it goes to the first column of that line (the headline)
474 - if the cursor is on the first column of the headline:
475 then it goes to the start of the headline within the item body.
477 In this fashion, you can use the beginning-of-line command to do
478 its normal job and then, when repeated, advance through the
479 entry, cycling back to start.
481 If this configuration variable is nil, then the cursor is just
482 advanced to the beginning of the line and remains there on
483 repeated calls."
484 :type 'boolean :group 'allout)
485 ;;;_ = allout-end-of-line-cycles
486 (defcustom allout-end-of-line-cycles t
487 "If non-nil, \\[allout-end-of-line] will cycle through smart-placement options.
489 Cycling only happens on when the command is repeated, not when it
490 follows a different command.
492 Smart placement means that repeated calls to this function will
493 advance as follows:
495 - if the cursor is not on the end-of-line,
496 then it goes to the end-of-line
497 - if the cursor is on the end-of-line but not the end-of-entry,
498 then it goes to the end-of-entry, exposing it if necessary
499 - if the cursor is on the end-of-entry,
500 then it goes to the end of the head line
502 In this fashion, you can use the end-of-line command to do its
503 normal job and then, when repeated, advance through the entry,
504 cycling back to start.
506 If this configuration variable is nil, then the cursor is just
507 advanced to the end of the line and remains there on repeated
508 calls."
509 :type 'boolean :group 'allout)
511 ;;;_ = allout-header-prefix
512 (defcustom allout-header-prefix "."
513 ;; this string is treated as literal match. it will be `regexp-quote'd, so
514 ;; one cannot use regular expressions to match varying header prefixes.
515 "Leading string which helps distinguish topic headers.
517 Outline topic header lines are identified by a leading topic
518 header prefix, which mostly have the value of this var at their front.
519 Level 1 topics are exceptions. They consist of only a single
520 character, which is typically set to the `allout-primary-bullet'."
521 :type 'string
522 :group 'allout)
523 (make-variable-buffer-local 'allout-header-prefix)
524 ;;;###autoload
525 (put 'allout-header-prefix 'safe-local-variable 'stringp)
526 ;;;_ = allout-primary-bullet
527 (defcustom allout-primary-bullet "*"
528 "Bullet used for top-level outline topics.
530 Outline topic header lines are identified by a leading topic header
531 prefix, which is concluded by bullets that includes the value of this
532 var and the respective allout-*-bullets-string vars.
534 The value of an asterisk (`*') provides for backwards compatibility
535 with the original Emacs outline mode. See `allout-plain-bullets-string'
536 and `allout-distinctive-bullets-string' for the range of available
537 bullets."
538 :type 'string
539 :group 'allout)
540 (make-variable-buffer-local 'allout-primary-bullet)
541 ;;;###autoload
542 (put 'allout-primary-bullet 'safe-local-variable 'stringp)
543 ;;;_ = allout-plain-bullets-string
544 (defcustom allout-plain-bullets-string ".,"
545 "The bullets normally used in outline topic prefixes.
547 See `allout-distinctive-bullets-string' for the other kind of
548 bullets.
550 DO NOT include the close-square-bracket, `]', as a bullet.
552 Outline mode has to be reactivated in order for changes to the value
553 of this var to take effect."
554 :type 'string
555 :group 'allout)
556 (make-variable-buffer-local 'allout-plain-bullets-string)
557 ;;;###autoload
558 (put 'allout-plain-bullets-string 'safe-local-variable 'stringp)
559 ;;;_ = allout-distinctive-bullets-string
560 (defcustom allout-distinctive-bullets-string "*+-=>()[{}&!?#%\"X@$~_\\:;^"
561 "Persistent outline header bullets used to distinguish special topics.
563 These bullets are distinguish topics with particular character.
564 They are not used by default in the topic creation routines, but
565 are offered as options when you modify topic creation with a
566 universal argument (\\[universal-argument]), or during rebulleting (\\[allout-rebullet-current-heading]).
568 Distinctive bullets are not cycled when topics are shifted or
569 otherwise automatically rebulleted, so their marking is
570 persistent until deliberately changed. Their significance is
571 purely by convention, however. Some conventions suggest
572 themselves:
574 `(' - open paren -- an aside or incidental point
575 `?' - question mark -- uncertain or outright question
576 `!' - exclamation point/bang -- emphatic
577 `[' - open square bracket -- meta-note, about item instead of item's subject
578 `\"' - double quote -- a quotation or other citation
579 `=' - equal sign -- an assignment, some kind of definition
580 `^' - carat -- relates to something above
582 Some are more elusive, but their rationale may be recognizable:
584 `+' - plus -- pending consideration, completion
585 `_' - underscore -- done, completed
586 `&' - ampersand -- addendum, furthermore
588 \(Some other non-plain bullets have special meaning to the
589 software. By default:
591 `~' marks encryptable topics -- see `allout-topic-encryption-bullet'
592 `#' marks auto-numbered bullets -- see `allout-numbered-bullet'.)
594 See `allout-plain-bullets-string' for the standard, alternating
595 bullets.
597 You must run `set-allout-regexp' in order for outline mode to
598 adopt changes of this value.
600 DO NOT include the close-square-bracket, `]', on either of the bullet
601 strings."
602 :type 'string
603 :group 'allout)
604 (make-variable-buffer-local 'allout-distinctive-bullets-string)
605 ;;;###autoload
606 (put 'allout-distinctive-bullets-string 'safe-local-variable 'stringp)
608 ;;;_ = allout-use-mode-specific-leader
609 (defcustom allout-use-mode-specific-leader t
610 "When non-nil, use mode-specific topic-header prefixes.
612 Allout outline mode will use the mode-specific `allout-mode-leaders' or
613 comment-start string, if any, to lead the topic prefix string, so topic
614 headers look like comments in the programming language. It will also use
615 the comment-start string, with an '_' appended, for `allout-primary-bullet'.
617 String values are used as literals, not regular expressions, so
618 do not escape any regular-expression characters.
620 Value t means to first check for assoc value in `allout-mode-leaders'
621 alist, then use comment-start string, if any, then use default (`.').
622 \(See note about use of comment-start strings, below.)
624 Set to the symbol for either of `allout-mode-leaders' or
625 `comment-start' to use only one of them, respectively.
627 Value nil means to always use the default (`.') and leave
628 `allout-primary-bullet' unaltered.
630 comment-start strings that do not end in spaces are tripled in
631 the header-prefix, and an `_' underscore is tacked on the end, to
632 distinguish them from regular comment strings. comment-start
633 strings that do end in spaces are not tripled, but an underscore
634 is substituted for the space. [This presumes that the space is
635 for appearance, not comment syntax. You can use
636 `allout-mode-leaders' to override this behavior, when
637 undesired.]"
638 :type '(choice (const t) (const nil) string
639 (const allout-mode-leaders)
640 (const comment-start))
641 :group 'allout)
642 ;;;###autoload
643 (put 'allout-use-mode-specific-leader 'safe-local-variable
644 (lambda (x) (or (memq x '(t nil allout-mode-leaders comment-start))
645 (stringp x))))
646 ;;;_ = allout-mode-leaders
647 (defvar allout-mode-leaders '()
648 "Specific allout-prefix leading strings per major modes.
650 Use this if the mode's comment-start string isn't what you
651 prefer, or if the mode lacks a comment-start string. See
652 `allout-use-mode-specific-leader' for more details.
654 If you're constructing a string that will comment-out outline
655 structuring so it can be included in program code, append an extra
656 character, like an \"_\" underscore, to distinguish the lead string
657 from regular comments that start at the beginning-of-line.")
659 ;;;_ = allout-old-style-prefixes
660 (defcustom allout-old-style-prefixes nil
661 "When non-nil, use only old-and-crusty `outline-mode' `*' topic prefixes.
663 Non-nil restricts the topic creation and modification
664 functions to asterix-padded prefixes, so they look exactly
665 like the original Emacs-outline style prefixes.
667 Whatever the setting of this variable, both old and new style prefixes
668 are always respected by the topic maneuvering functions."
669 :type 'boolean
670 :group 'allout)
671 (make-variable-buffer-local 'allout-old-style-prefixes)
672 ;;;###autoload
673 (put 'allout-old-style-prefixes 'safe-local-variable
674 (if (fboundp 'booleanp) 'booleanp (lambda (x) (member x '(t nil)))))
675 ;;;_ = allout-stylish-prefixes -- alternating bullets
676 (defcustom allout-stylish-prefixes t
677 "Do fancy stuff with topic prefix bullets according to level, etc.
679 Non-nil enables topic creation, modification, and repositioning
680 functions to vary the topic bullet char (the char that marks the topic
681 depth) just preceding the start of the topic text) according to level.
682 Otherwise, only asterisks (`*') and distinctive bullets are used.
684 This is how an outline can look (but sans indentation) with stylish
685 prefixes:
687 * Top level
688 .* A topic
689 . + One level 3 subtopic
690 . . One level 4 subtopic
691 . . A second 4 subtopic
692 . + Another level 3 subtopic
693 . #1 A numbered level 4 subtopic
694 . #2 Another
695 . ! Another level 4 subtopic with a different distinctive bullet
696 . #4 And another numbered level 4 subtopic
698 This would be an outline with stylish prefixes inhibited (but the
699 numbered and other distinctive bullets retained):
701 * Top level
702 .* A topic
703 . * One level 3 subtopic
704 . * One level 4 subtopic
705 . * A second 4 subtopic
706 . * Another level 3 subtopic
707 . #1 A numbered level 4 subtopic
708 . #2 Another
709 . ! Another level 4 subtopic with a different distinctive bullet
710 . #4 And another numbered level 4 subtopic
712 Stylish and constant prefixes (as well as old-style prefixes) are
713 always respected by the topic maneuvering functions, regardless of
714 this variable setting.
716 The setting of this var is not relevant when `allout-old-style-prefixes'
717 is non-nil."
718 :type 'boolean
719 :group 'allout)
720 (make-variable-buffer-local 'allout-stylish-prefixes)
721 ;;;###autoload
722 (put 'allout-stylish-prefixes 'safe-local-variable
723 (if (fboundp 'booleanp) 'booleanp (lambda (x) (member x '(t nil)))))
725 ;;;_ = allout-numbered-bullet
726 (defcustom allout-numbered-bullet "#"
727 "String designating bullet of topics that have auto-numbering; nil for none.
729 Topics having this bullet have automatic maintenance of a sibling
730 sequence-number tacked on, just after the bullet. Conventionally set
731 to \"#\", you can set it to a bullet of your choice. A nil value
732 disables numbering maintenance."
733 :type '(choice (const nil) string)
734 :group 'allout)
735 (make-variable-buffer-local 'allout-numbered-bullet)
736 ;;;###autoload
737 (put 'allout-numbered-bullet 'safe-local-variable
738 (if (fboundp 'string-or-null-p)
739 'string-or-null-p
740 (lambda (x) (or (stringp x) (null x)))))
741 ;;;_ = allout-file-xref-bullet
742 (defcustom allout-file-xref-bullet "@"
743 "Bullet signifying file cross-references, for `allout-resolve-xref'.
745 Set this var to the bullet you want to use for file cross-references."
746 :type '(choice (const nil) string)
747 :group 'allout)
748 ;;;###autoload
749 (put 'allout-file-xref-bullet 'safe-local-variable
750 (if (fboundp 'string-or-null-p)
751 'string-or-null-p
752 (lambda (x) (or (stringp x) (null x)))))
753 ;;;_ = allout-presentation-padding
754 (defcustom allout-presentation-padding 2
755 "Presentation-format white-space padding factor, for greater indent."
756 :type 'integer
757 :group 'allout)
759 (make-variable-buffer-local 'allout-presentation-padding)
760 ;;;###autoload
761 (put 'allout-presentation-padding 'safe-local-variable 'integerp)
763 ;;;_ = allout-flattened-numbering-abbreviation
764 (define-obsolete-variable-alias 'allout-abbreviate-flattened-numbering
765 'allout-flattened-numbering-abbreviation "24.1")
766 (defcustom allout-flattened-numbering-abbreviation nil
767 "If non-nil, `allout-flatten-exposed-to-buffer' abbreviates topic
768 numbers to minimal amount with some context. Otherwise, entire
769 numbers are always used."
770 :version "24.1"
771 :type 'boolean
772 :group 'allout)
774 ;;;_ + LaTeX formatting
775 ;;;_ - allout-number-pages
776 (defcustom allout-number-pages nil
777 "Non-nil turns on page numbering for LaTeX formatting of an outline."
778 :type 'boolean
779 :group 'allout)
780 ;;;_ - allout-label-style
781 (defcustom allout-label-style "\\large\\bf"
782 "Font and size of labels for LaTeX formatting of an outline."
783 :type 'string
784 :group 'allout)
785 ;;;_ - allout-head-line-style
786 (defcustom allout-head-line-style "\\large\\sl "
787 "Font and size of entries for LaTeX formatting of an outline."
788 :type 'string
789 :group 'allout)
790 ;;;_ - allout-body-line-style
791 (defcustom allout-body-line-style " "
792 "Font and size of entries for LaTeX formatting of an outline."
793 :type 'string
794 :group 'allout)
795 ;;;_ - allout-title-style
796 (defcustom allout-title-style "\\Large\\bf"
797 "Font and size of titles for LaTeX formatting of an outline."
798 :type 'string
799 :group 'allout)
800 ;;;_ - allout-title
801 (defcustom allout-title '(or buffer-file-name (buffer-name))
802 "Expression to be evaluated to determine the title for LaTeX
803 formatted copy."
804 :type 'sexp
805 :group 'allout)
806 ;;;_ - allout-line-skip
807 (defcustom allout-line-skip ".05cm"
808 "Space between lines for LaTeX formatting of an outline."
809 :type 'string
810 :group 'allout)
811 ;;;_ - allout-indent
812 (defcustom allout-indent ".3cm"
813 "LaTeX formatted depth-indent spacing."
814 :type 'string
815 :group 'allout)
817 ;;;_ + Topic encryption
818 ;;;_ = allout-encryption group
819 (defgroup allout-encryption nil
820 "Settings for topic encryption features of allout outliner."
821 :group 'allout)
822 ;;;_ = allout-topic-encryption-bullet
823 (defcustom allout-topic-encryption-bullet "~"
824 "Bullet signifying encryption of the entry's body."
825 :type '(choice (const nil) string)
826 :version "22.1"
827 :group 'allout-encryption)
828 ;;;_ = allout-encrypt-unencrypted-on-saves
829 (defcustom allout-encrypt-unencrypted-on-saves t
830 "If non-nil, topics pending encryption are encrypted during buffer saves.
832 This prevents file-system exposure of un-encrypted contents of
833 items marked for encryption.
835 When non-nil, if the topic currently being edited is decrypted,
836 it will be encrypted for saving but automatically decrypted
837 before any subsequent user interaction, so it is once again clear
838 text for editing though the file system copy is encrypted.
840 \(Auto-saves are handled differently. Buffers with plain-text
841 exposed encrypted topics are exempted from auto saves until all
842 such topics are encrypted.)"
844 :type 'boolean
845 :version "23.1"
846 :group 'allout-encryption)
847 (make-variable-buffer-local 'allout-encrypt-unencrypted-on-saves)
848 (defvar allout-auto-save-temporarily-disabled nil
849 "True while topic encryption is pending and auto-saving was active.
851 The value of `buffer-saved-size' at the time of decryption is used,
852 for restoring when all encryptions are established.")
853 (defvar allout-just-did-undo nil
854 "True just after undo commands, until allout-post-command-business.")
855 (make-variable-buffer-local 'allout-just-did-undo)
857 ;;;_ + Developer
858 ;;;_ = allout-developer group
859 (defgroup allout-developer nil
860 "Allout settings developers care about, including topic encryption and more."
861 :group 'allout)
862 ;;;_ = allout-run-unit-tests-on-load
863 (defcustom allout-run-unit-tests-on-load nil
864 "When non-nil, unit tests will be run at end of loading the allout module.
866 Generally, allout code developers are the only ones who'll want to set this.
868 \(If set, this makes it an even better practice to exercise changes by
869 doing byte-compilation with a repeat count, so the file is loaded after
870 compilation.)
872 See `allout-run-unit-tests' to see what's run."
873 :type 'boolean
874 :group 'allout-developer)
876 ;;;_ + Miscellaneous customization
878 ;;;_ = allout-enable-file-variable-adjustment
879 (defcustom allout-enable-file-variable-adjustment t
880 "If non-nil, some allout outline actions edit Emacs local file var text.
882 This can range from changes to existing entries, addition of new ones,
883 and creation of a new local variables section when necessary.
885 Emacs file variables adjustments are also inhibited if `enable-local-variables'
886 is nil.
888 Operations potentially causing edits include allout encryption routines.
889 For details, see `allout-toggle-current-subtree-encryption's docstring."
890 :type 'boolean
891 :group 'allout)
892 (make-variable-buffer-local 'allout-enable-file-variable-adjustment)
894 ;;;_* CODE -- no user customizations below.
896 ;;;_ #1 Internal Outline Formatting and Configuration
897 ;;;_ : Version
898 ;;;_ = allout-version
899 (defvar allout-version "2.3"
900 "Version of currently loaded outline package. (allout.el)")
901 ;;;_ > allout-version
902 (defun allout-version (&optional here)
903 "Return string describing the loaded outline version."
904 (interactive "P")
905 (let ((msg (concat "Allout Outline Mode v " allout-version)))
906 (if here (insert msg))
907 (message "%s" msg)
908 msg))
909 ;;;_ : Mode activation (defined here because it's referenced early)
910 ;;;_ = allout-mode
911 (defvar allout-mode nil "Allout outline mode minor-mode flag.")
912 (make-variable-buffer-local 'allout-mode)
913 ;;;_ = allout-layout nil
914 (defvar allout-layout nil ; LEAVE GLOBAL VALUE NIL -- see docstring.
915 "Buffer-specific setting for allout layout.
917 In buffers where this is non-nil (and if `allout-auto-activation'
918 has been customized to enable this behavior), `allout-mode' will be
919 automatically activated. The layout dictated by the value will be used to
920 set the initial exposure when `allout-mode' is activated.
922 \*You should not setq-default this variable non-nil unless you want every
923 visited file to be treated as an allout file.*
925 The value would typically be set by a file local variable. For
926 example, the following lines at the bottom of an Emacs Lisp file:
928 ;;;Local variables:
929 ;;;allout-layout: (0 : -1 -1 0)
930 ;;;End:
932 dictate activation of `allout-mode' mode when the file is visited
933 \(presuming proper `allout-auto-activation' customization),
934 followed by the equivalent of `(allout-expose-topic 0 : -1 -1 0)'.
935 \(This is the layout used for the allout.el source file.)
937 `allout-default-layout' describes the specification format.
938 `allout-layout' can additionally have the value `t', in which
939 case the value of `allout-default-layout' is used.")
940 (make-variable-buffer-local 'allout-layout)
941 ;;;###autoload
942 (put 'allout-layout 'safe-local-variable
943 (lambda (x) (or (numberp x) (listp x) (memq x '(: * + -)))))
945 ;;;_ : Topic header format
946 ;;;_ = allout-regexp
947 (defvar allout-regexp ""
948 "Regular expression to match the beginning of a heading line.
950 Any line whose beginning matches this regexp is considered a
951 heading. This var is set according to the user configuration vars
952 by `set-allout-regexp'.")
953 (make-variable-buffer-local 'allout-regexp)
954 ;;;_ = allout-bullets-string
955 (defvar allout-bullets-string ""
956 "A string dictating the valid set of outline topic bullets.
958 This var should *not* be set by the user -- it is set by `set-allout-regexp',
959 and is produced from the elements of `allout-plain-bullets-string'
960 and `allout-distinctive-bullets-string'.")
961 (make-variable-buffer-local 'allout-bullets-string)
962 ;;;_ = allout-bullets-string-len
963 (defvar allout-bullets-string-len 0
964 "Length of current buffers' `allout-plain-bullets-string'.")
965 (make-variable-buffer-local 'allout-bullets-string-len)
966 ;;;_ = allout-depth-specific-regexp
967 (defvar allout-depth-specific-regexp ""
968 "Regular expression to match a heading line prefix for a particular depth.
970 This expression is used to search for depth-specific topic
971 headers at depth 2 and greater. Use `allout-depth-one-regexp'
972 for to seek topics at depth one.
974 This var is set according to the user configuration vars by
975 `set-allout-regexp'. It is prepared with format strings for two
976 decimal numbers, which should each be one less than the depth of the
977 topic prefix to be matched.")
978 (make-variable-buffer-local 'allout-depth-specific-regexp)
979 ;;;_ = allout-depth-one-regexp
980 (defvar allout-depth-one-regexp ""
981 "Regular expression to match a heading line prefix for depth one.
983 This var is set according to the user configuration vars by
984 `set-allout-regexp'. It is prepared with format strings for two
985 decimal numbers, which should each be one less than the depth of the
986 topic prefix to be matched.")
987 (make-variable-buffer-local 'allout-depth-one-regexp)
988 ;;;_ = allout-line-boundary-regexp
989 (defvar allout-line-boundary-regexp ()
990 "`allout-regexp' prepended with a newline for the search target.
992 This is properly set by `set-allout-regexp'.")
993 (make-variable-buffer-local 'allout-line-boundary-regexp)
994 ;;;_ = allout-bob-regexp
995 (defvar allout-bob-regexp ()
996 "Like `allout-line-boundary-regexp', for headers at beginning of buffer.")
997 (make-variable-buffer-local 'allout-bob-regexp)
998 ;;;_ = allout-header-subtraction
999 (defvar allout-header-subtraction (1- (length allout-header-prefix))
1000 "Allout-header prefix length to subtract when computing topic depth.")
1001 (make-variable-buffer-local 'allout-header-subtraction)
1002 ;;;_ = allout-plain-bullets-string-len
1003 (defvar allout-plain-bullets-string-len (length allout-plain-bullets-string)
1004 "Length of `allout-plain-bullets-string', updated by `set-allout-regexp'.")
1005 (make-variable-buffer-local 'allout-plain-bullets-string-len)
1007 ;;;_ = allout-doublecheck-at-and-shallower
1008 (defconst allout-doublecheck-at-and-shallower 3
1009 "Validate apparent topics of this depth and shallower as being non-aberrant.
1011 Verified with `allout-aberrant-container-p'. The usefulness of
1012 this check is limited to shallow depths, because the
1013 determination of aberrance is according to the mistaken item
1014 being followed by a legitimate item of excessively greater depth.
1016 The classic example of a mistaken item, for a standard allout
1017 outline configuration, is a body line that begins with an '...'
1018 ellipsis. This happens to contain a legitimate depth-2 header
1019 prefix, constituted by two '..' dots at the beginning of the
1020 line. The only thing that can distinguish it *in principle* from
1021 a legitimate one is if the following real header is at a depth
1022 that is discontinuous from the depth of 2 implied by the
1023 ellipsis, ie depth 4 or more. As the depth being tested gets
1024 greater, the likelihood of this kind of disqualification is
1025 lower, and the usefulness of this test is lower.
1027 Extending the depth of the doublecheck increases the amount it is
1028 applied, increasing the cost of the test - on casual estimation,
1029 for outlines with many deep topics, geometrically (O(n)?).
1030 Taken together with decreasing likelihood that the test will be
1031 useful at greater depths, more modest doublecheck limits are more
1032 suitably economical.")
1033 ;;;_ X allout-reset-header-lead (header-lead)
1034 (defun allout-reset-header-lead (header-lead)
1035 "Reset the leading string used to identify topic headers."
1036 (interactive "sNew lead string: ")
1037 (setq allout-header-prefix header-lead)
1038 (setq allout-header-subtraction (1- (length allout-header-prefix)))
1039 (set-allout-regexp))
1040 ;;;_ X allout-lead-with-comment-string (header-lead)
1041 (defun allout-lead-with-comment-string (&optional header-lead)
1042 "Set the topic-header leading string to specified string.
1044 Useful for encapsulating outline structure in programming
1045 language comments. Returns the leading string."
1047 (interactive "P")
1048 (if (not (stringp header-lead))
1049 (setq header-lead (read-string
1050 "String prefix for topic headers: ")))
1051 (setq allout-reindent-bodies nil)
1052 (allout-reset-header-lead header-lead)
1053 header-lead)
1054 ;;;_ > allout-infer-header-lead-and-primary-bullet ()
1055 (defun allout-infer-header-lead-and-primary-bullet ()
1056 "Determine appropriate `allout-header-prefix' and `allout-primary-bullet'.
1058 Works according to settings of:
1060 `comment-start'
1061 `allout-header-prefix' (default)
1062 `allout-use-mode-specific-leader'
1063 and `allout-mode-leaders'.
1065 Apply this via (re)activation of `allout-mode', rather than
1066 invoking it directly."
1067 (let* ((use-leader (and (boundp 'allout-use-mode-specific-leader)
1068 (if (or (stringp allout-use-mode-specific-leader)
1069 (memq allout-use-mode-specific-leader
1070 '(allout-mode-leaders
1071 comment-start
1072 t)))
1073 allout-use-mode-specific-leader
1074 ;; Oops -- garbled value, equate with effect of t:
1075 t)))
1076 (leader
1077 (cond
1078 ((not use-leader) nil)
1079 ;; Use the explicitly designated leader:
1080 ((stringp use-leader) use-leader)
1081 (t (or (and (memq use-leader '(t allout-mode-leaders))
1082 ;; Get it from outline mode leaders?
1083 (cdr (assq major-mode allout-mode-leaders)))
1084 ;; ... didn't get from allout-mode-leaders...
1085 (and (memq use-leader '(t comment-start))
1086 comment-start
1087 ;; Use comment-start, maybe tripled, and with
1088 ;; underscore:
1089 (concat
1090 (if (string= " "
1091 (substring comment-start
1092 (1- (length comment-start))))
1093 ;; Use comment-start, sans trailing space:
1094 (substring comment-start 0 -1)
1095 (concat comment-start comment-start comment-start))
1096 ;; ... and append underscore, whichever:
1097 "_")))))))
1098 (if (not leader)
1100 (setq allout-header-prefix leader)
1101 (if (not allout-old-style-prefixes)
1102 ;; setting allout-primary-bullet makes the top level topics use --
1103 ;; actually, be -- the special prefix:
1104 (setq allout-primary-bullet leader))
1105 allout-header-prefix)))
1106 (defalias 'allout-infer-header-lead
1107 'allout-infer-header-lead-and-primary-bullet)
1108 ;;;_ > allout-infer-body-reindent ()
1109 (defun allout-infer-body-reindent ()
1110 "Determine proper setting for `allout-reindent-bodies'.
1112 Depends on default setting of `allout-reindent-bodies' (which see)
1113 and presence of setting for `comment-start', to tell whether the
1114 file is programming code."
1115 (if (and allout-reindent-bodies
1116 comment-start
1117 (not (eq 'force allout-reindent-bodies)))
1118 (setq allout-reindent-bodies nil)))
1119 ;;;_ > set-allout-regexp ()
1120 (defun set-allout-regexp ()
1121 "Generate proper topic-header regexp form for outline functions.
1123 Works with respect to `allout-plain-bullets-string' and
1124 `allout-distinctive-bullets-string'.
1126 Also refresh various data structures that hinge on the regexp."
1128 (interactive)
1129 ;; Derive allout-bullets-string from user configured components:
1130 (setq allout-bullets-string "")
1131 (let ((strings (list 'allout-plain-bullets-string
1132 'allout-distinctive-bullets-string
1133 'allout-primary-bullet))
1134 cur-string
1135 cur-len
1136 cur-char
1137 index)
1138 (while strings
1139 (setq index 0)
1140 (setq cur-len (length (setq cur-string (symbol-value (car strings)))))
1141 (while (< index cur-len)
1142 (setq cur-char (aref cur-string index))
1143 (setq allout-bullets-string
1144 (concat allout-bullets-string
1145 (cond
1146 ; Single dash would denote a
1147 ; sequence, repeated denotes
1148 ; a dash:
1149 ((eq cur-char ?-) "--")
1150 ; literal close-square-bracket
1151 ; doesn't work right in the
1152 ; expr, exclude it:
1153 ((eq cur-char ?\]) "")
1154 (t (regexp-quote (char-to-string cur-char))))))
1155 (setq index (1+ index)))
1156 (setq strings (cdr strings)))
1158 ;; Derive next for repeated use in allout-pending-bullet:
1159 (setq allout-plain-bullets-string-len (length allout-plain-bullets-string))
1160 (setq allout-header-subtraction (1- (length allout-header-prefix)))
1162 (let (new-part old-part formfeed-part)
1163 (setq new-part (concat "\\("
1164 (regexp-quote allout-header-prefix)
1165 "[ \t]*"
1166 ;; already regexp-quoted in a custom way:
1167 "[" allout-bullets-string "]"
1168 "\\)")
1169 old-part (concat "\\("
1170 (regexp-quote allout-primary-bullet)
1171 "\\|"
1172 (regexp-quote allout-header-prefix)
1173 "\\)"
1175 " ?[^" allout-primary-bullet "]")
1176 formfeed-part "\\(\^L\\)"
1178 allout-regexp (concat new-part
1179 "\\|"
1180 old-part
1181 "\\|"
1182 formfeed-part)
1184 allout-line-boundary-regexp (concat "\n" new-part
1185 "\\|"
1186 "\n" old-part
1187 "\\|"
1188 "\n" formfeed-part)
1190 allout-bob-regexp (concat "\\`" new-part
1191 "\\|"
1192 "\\`" old-part
1193 "\\|"
1194 "\\`" formfeed-part
1197 (setq allout-depth-specific-regexp
1198 (concat "\\(^\\|\\`\\)"
1199 "\\("
1201 ;; new-style spacers-then-bullet string:
1202 "\\("
1203 (allout-format-quote (regexp-quote allout-header-prefix))
1204 " \\{%s\\}"
1205 "[" (allout-format-quote allout-bullets-string) "]"
1206 "\\)"
1208 ;; old-style all-bullets string, if primary not multi-char:
1209 (if (< 0 allout-header-subtraction)
1211 (concat "\\|\\("
1212 (allout-format-quote
1213 (regexp-quote allout-primary-bullet))
1214 (allout-format-quote
1215 (regexp-quote allout-primary-bullet))
1216 (allout-format-quote
1217 (regexp-quote allout-primary-bullet))
1218 "\\{%s\\}"
1219 ;; disqualify greater depths:
1220 "[^"
1221 (allout-format-quote allout-primary-bullet)
1222 "]\\)"
1224 "\\)"
1226 (setq allout-depth-one-regexp
1227 (concat "\\(^\\|\\`\\)"
1228 "\\("
1230 "\\("
1231 (regexp-quote allout-header-prefix)
1232 ;; disqualify any bullet char following any amount of
1233 ;; intervening whitespace:
1234 " *"
1235 (concat "[^ " allout-bullets-string "]")
1236 "\\)"
1237 (if (< 0 allout-header-subtraction)
1238 ;; Need not support anything like the old
1239 ;; bullet style if the prefix is multi-char.
1241 (concat "\\|"
1242 (regexp-quote allout-primary-bullet)
1243 ;; disqualify deeper primary-bullet sequences:
1244 "[^" allout-primary-bullet "]"))
1245 "\\)"
1246 ))))
1247 ;;;_ : Menu bar
1248 (defvar allout-mode-exposure-menu)
1249 (defvar allout-mode-editing-menu)
1250 (defvar allout-mode-navigation-menu)
1251 (defvar allout-mode-misc-menu)
1252 (defun produce-allout-mode-menubar-entries ()
1253 (require 'easymenu)
1254 (easy-menu-define allout-mode-exposure-menu
1255 allout-mode-map-value
1256 "Allout outline exposure menu."
1257 '("Exposure"
1258 ["Show Entry" allout-show-current-entry t]
1259 ["Show Children" allout-show-children t]
1260 ["Show Subtree" allout-show-current-subtree t]
1261 ["Hide Subtree" allout-hide-current-subtree t]
1262 ["Hide Leaves" allout-hide-current-leaves t]
1263 "----"
1264 ["Show All" allout-show-all t]))
1265 (easy-menu-define allout-mode-editing-menu
1266 allout-mode-map-value
1267 "Allout outline editing menu."
1268 '("Headings"
1269 ["Open Sibling" allout-open-sibtopic t]
1270 ["Open Subtopic" allout-open-subtopic t]
1271 ["Open Supertopic" allout-open-supertopic t]
1272 "----"
1273 ["Shift Topic In" allout-shift-in t]
1274 ["Shift Topic Out" allout-shift-out t]
1275 ["Rebullet Topic" allout-rebullet-topic t]
1276 ["Rebullet Heading" allout-rebullet-current-heading t]
1277 ["Number Siblings" allout-number-siblings t]
1278 "----"
1279 ["Toggle Topic Encryption"
1280 allout-toggle-current-subtree-encryption
1281 (> (allout-current-depth) 1)]))
1282 (easy-menu-define allout-mode-navigation-menu
1283 allout-mode-map-value
1284 "Allout outline navigation menu."
1285 '("Navigation"
1286 ["Next Visible Heading" allout-next-visible-heading t]
1287 ["Previous Visible Heading"
1288 allout-previous-visible-heading t]
1289 "----"
1290 ["Up Level" allout-up-current-level t]
1291 ["Forward Current Level" allout-forward-current-level t]
1292 ["Backward Current Level"
1293 allout-backward-current-level t]
1294 "----"
1295 ["Beginning of Entry"
1296 allout-beginning-of-current-entry t]
1297 ["End of Entry" allout-end-of-entry t]
1298 ["End of Subtree" allout-end-of-current-subtree t]))
1299 (easy-menu-define allout-mode-misc-menu
1300 allout-mode-map-value
1301 "Allout outlines miscellaneous bindings."
1302 '("Misc"
1303 ["Version" allout-version t]
1304 "----"
1305 ["Duplicate Exposed" allout-copy-exposed-to-buffer t]
1306 ["Duplicate Exposed, numbered"
1307 allout-flatten-exposed-to-buffer t]
1308 ["Duplicate Exposed, indented"
1309 allout-indented-exposed-to-buffer t]
1310 "----"
1311 ["Set Header Lead" allout-reset-header-lead t]
1312 ["Set New Exposure" allout-expose-topic t])))
1313 ;;;_ : Allout Modal-Variables Utilities
1314 ;;;_ = allout-mode-prior-settings
1315 (defvar allout-mode-prior-settings nil
1316 "Internal `allout-mode' use; settings to be resumed on mode deactivation.
1318 See `allout-add-resumptions' and `allout-do-resumptions'.")
1319 (make-variable-buffer-local 'allout-mode-prior-settings)
1320 ;;;_ > allout-add-resumptions (&rest pairs)
1321 (defun allout-add-resumptions (&rest pairs)
1322 "Set name/value PAIRS.
1324 Old settings are preserved for later resumption using `allout-do-resumptions'.
1326 The new values are set as a buffer local. On resumption, the prior buffer
1327 scope of the variable is restored along with its value. If it was a void
1328 buffer-local value, then it is left as nil on resumption.
1330 The pairs are lists whose car is the name of the variable and car of the
1331 cdr is the new value: '(some-var some-value)'. The pairs can actually be
1332 triples, where the third element qualifies the disposition of the setting,
1333 as described further below.
1335 If the optional third element is the symbol 'extend, then the new value
1336 created by `cons'ing the second element of the pair onto the front of the
1337 existing value.
1339 If the optional third element is the symbol 'append, then the new value is
1340 extended from the existing one by `append'ing a list containing the second
1341 element of the pair onto the end of the existing value.
1343 Extension, and resumptions in general, should not be used for hook
1344 functions -- use the 'local mode of `add-hook' for that, instead.
1346 The settings are stored on `allout-mode-prior-settings'."
1347 (while pairs
1348 (let* ((pair (pop pairs))
1349 (name (car pair))
1350 (value (cadr pair))
1351 (qualifier (if (> (length pair) 2)
1352 (caddr pair)))
1353 prior-value)
1354 (if (not (symbolp name))
1355 (error "Pair's name, %S, must be a symbol, not %s"
1356 name (type-of name)))
1357 (setq prior-value (condition-case nil
1358 (symbol-value name)
1359 (void-variable nil)))
1360 (when (not (assoc name allout-mode-prior-settings))
1361 ;; Not already added as a resumption, create the prior setting entry.
1362 (if (local-variable-p name (current-buffer))
1363 ;; is already local variable -- preserve the prior value:
1364 (push (list name prior-value) allout-mode-prior-settings)
1365 ;; wasn't local variable, indicate so for resumption by killing
1366 ;; local value, and make it local:
1367 (push (list name) allout-mode-prior-settings)
1368 (make-local-variable name)))
1369 (if qualifier
1370 (cond ((eq qualifier 'extend)
1371 (if (not (listp prior-value))
1372 (error "extension of non-list prior value attempted")
1373 (set name (cons value prior-value))))
1374 ((eq qualifier 'append)
1375 (if (not (listp prior-value))
1376 (error "appending of non-list prior value attempted")
1377 (set name (append prior-value (list value)))))
1378 (t (error "unrecognized setting qualifier `%s' encountered"
1379 qualifier)))
1380 (set name value)))))
1381 ;;;_ > allout-do-resumptions ()
1382 (defun allout-do-resumptions ()
1383 "Resume all name/value settings registered by `allout-add-resumptions'.
1385 This is used when concluding allout-mode, to resume selected variables to
1386 their settings before allout-mode was started."
1388 (while allout-mode-prior-settings
1389 (let* ((pair (pop allout-mode-prior-settings))
1390 (name (car pair))
1391 (value-cell (cdr pair)))
1392 (if (not value-cell)
1393 ;; Prior value was global:
1394 (kill-local-variable name)
1395 ;; Prior value was explicit:
1396 (set name (car value-cell))))))
1397 ;;;_ : Mode-specific incidentals
1398 ;;;_ > allout-unprotected (expr)
1399 (defmacro allout-unprotected (expr)
1400 "Enable internal outline operations to alter invisible text."
1401 `(let ((inhibit-read-only (if (not buffer-read-only) t))
1402 (inhibit-field-text-motion t))
1403 ,expr))
1404 ;;;_ = allout-mode-hook
1405 (defvar allout-mode-hook nil
1406 "Hook run when allout mode starts.")
1407 ;;;_ = allout-mode-deactivate-hook
1408 (defvar allout-mode-deactivate-hook nil
1409 "Hook run when allout mode ends.")
1410 (define-obsolete-variable-alias 'allout-mode-deactivate-hook
1411 'allout-mode-off-hook "24.1")
1412 ;;;_ = allout-exposure-category
1413 (defvar allout-exposure-category nil
1414 "Symbol for use as allout invisible-text overlay category.")
1416 ;;;_ = allout-exposure-change-functions
1417 (defcustom allout-exposure-change-functions nil
1418 "Abnormal hook run after allout outline subtree exposure changes.
1419 It is run at the conclusion of `allout-flag-region'.
1421 Functions on the hook must take three arguments:
1423 - FROM -- integer indicating the point at the start of the change.
1424 - TO -- integer indicating the point of the end of the change.
1425 - FLAG -- change mode: nil for exposure, otherwise concealment.
1427 This hook might be invoked multiple times by a single command."
1428 :type 'hook
1429 :group 'allout
1430 :version "24.2")
1432 (define-obsolete-variable-alias 'allout-exposure-change-hook
1433 'allout-exposure-change-functions "24.2")
1435 ;;;_ = allout-structure-added-functions
1436 (defcustom allout-structure-added-functions nil
1437 "Abnormal hook run after adding items to an Allout outline.
1438 Functions on the hook should take two arguments:
1440 - NEW-START -- integer indicating position of start of the first new item.
1441 - NEW-END -- integer indicating position of end of the last new item.
1443 This hook might be invoked multiple times by a single command."
1444 :type 'hook
1445 :group 'allout
1446 :version "24.2")
1448 (define-obsolete-variable-alias 'allout-structure-added-hook
1449 'allout-structure-added-functions "24.2")
1451 ;;;_ = allout-structure-deleted-functions
1452 (defcustom allout-structure-deleted-functions nil
1453 "Abnormal hook run after deleting subtrees from an Allout outline.
1454 Functions on the hook must take two arguments:
1456 - DEPTH -- integer indicating the depth of the subtree that was deleted.
1457 - REMOVED-FROM -- integer indicating the point where the subtree was removed.
1459 Some edits that remove or invalidate items may be missed by this hook:
1460 specifically edits that native allout routines do not control.
1462 This hook might be invoked multiple times by a single command."
1463 :type 'hook
1464 :group 'allout
1465 :version "24.2")
1467 (define-obsolete-variable-alias 'allout-structure-deleted-hook
1468 'allout-structure-deleted-functions "24.2")
1470 ;;;_ = allout-structure-shifted-functions
1471 (defcustom allout-structure-shifted-functions nil
1472 "Abnormal hook run after shifting items in an Allout outline.
1473 Functions on the hook should take two arguments:
1475 - DEPTH-CHANGE -- integer indicating depth increase, negative for decrease
1476 - START -- integer indicating the start point of the shifted parent item.
1478 Some edits that shift items can be missed by this hook: specifically edits
1479 that native allout routines do not control.
1481 This hook might be invoked multiple times by a single command."
1482 :type 'hook
1483 :group 'allout
1484 :version "24.2")
1486 (define-obsolete-variable-alias 'allout-structure-shifted-hook
1487 'allout-structure-shifted-functions "24.2")
1489 ;;;_ = allout-after-copy-or-kill-hook
1490 (defcustom allout-after-copy-or-kill-hook nil
1491 "Normal hook run after copying outline text.."
1492 :type 'hook
1493 :group 'allout
1494 :version "24.2")
1496 ;;;_ = allout-post-undo-hook
1497 (defcustom allout-post-undo-hook nil
1498 "Normal hook run after undo activity.
1499 The item that's current when the hook is run *may* be the one
1500 that was affected by the undo.."
1501 :type 'hook
1502 :group 'allout
1503 :version "24.2")
1505 ;;;_ = allout-outside-normal-auto-fill-function
1506 (defvar allout-outside-normal-auto-fill-function nil
1507 "Value of `normal-auto-fill-function' outside of allout mode.
1509 Used by `allout-auto-fill' to do the mandated `normal-auto-fill-function'
1510 wrapped within allout's automatic `fill-prefix' setting.")
1511 (make-variable-buffer-local 'allout-outside-normal-auto-fill-function)
1512 ;;;_ = prevent redundant activation by desktop mode:
1513 (add-to-list 'desktop-minor-mode-handlers '(allout-mode . nil))
1514 ;;;_ = allout-passphrase-verifier-string
1515 (defvar allout-passphrase-verifier-string nil
1516 "Setting used to test solicited encryption passphrases against the one
1517 already associated with a file.
1519 It consists of an encrypted random string useful only to verify that a
1520 passphrase entered by the user is effective for decryption. The passphrase
1521 itself is \*not* recorded in the file anywhere, and the encrypted contents
1522 are random binary characters to avoid exposing greater susceptibility to
1523 search attacks.
1525 The verifier string is retained as an Emacs file variable, as well as in
1526 the Emacs buffer state, if file variable adjustments are enabled. See
1527 `allout-enable-file-variable-adjustment' for details about that.")
1528 (make-variable-buffer-local 'allout-passphrase-verifier-string)
1529 (make-obsolete 'allout-passphrase-verifier-string
1530 'allout-passphrase-verifier-string "23.3")
1531 ;;;###autoload
1532 (put 'allout-passphrase-verifier-string 'safe-local-variable 'stringp)
1533 ;;;_ = allout-passphrase-hint-string
1534 (defvar allout-passphrase-hint-string ""
1535 "Variable used to retain reminder string for file's encryption passphrase.
1537 See the description of `allout-passphrase-hint-handling' for details about how
1538 the reminder is deployed.
1540 The hint is retained as an Emacs file variable, as well as in the Emacs buffer
1541 state, if file variable adjustments are enabled. See
1542 `allout-enable-file-variable-adjustment' for details about that.")
1543 (make-variable-buffer-local 'allout-passphrase-hint-string)
1544 (setq-default allout-passphrase-hint-string "")
1545 (make-obsolete 'allout-passphrase-hint-string
1546 'allout-passphrase-hint-string "23.3")
1547 ;;;###autoload
1548 (put 'allout-passphrase-hint-string 'safe-local-variable 'stringp)
1549 ;;;_ = allout-after-save-decrypt
1550 (defvar allout-after-save-decrypt nil
1551 "Internal variable, is nil or has the value of two points:
1553 - the location of a topic to be decrypted after saving is done
1554 - where to situate the cursor after the decryption is performed
1556 This is used to decrypt the topic that was currently being edited, if it
1557 was encrypted automatically as part of a file write or autosave.")
1558 (make-variable-buffer-local 'allout-after-save-decrypt)
1559 ;;;_ = allout-encryption-plaintext-sanitization-regexps
1560 (defvar allout-encryption-plaintext-sanitization-regexps nil
1561 "List of regexps whose matches are removed from plaintext before encryption.
1563 This is for the sake of removing artifacts, like escapes, that are added on
1564 and not actually part of the original plaintext. The removal is done just
1565 prior to encryption.
1567 Entries must be symbols that are bound to the desired values.
1569 Each value can be a regexp or a list with a regexp followed by a
1570 substitution string. If it's just a regexp, all its matches are removed
1571 before the text is encrypted. If it's a regexp and a substitution, the
1572 substitution is used against the regexp matches, a la `replace-match'.")
1573 (make-variable-buffer-local 'allout-encryption-text-removal-regexps)
1574 ;;;_ = allout-encryption-ciphertext-rejection-regexps
1575 (defvar allout-encryption-ciphertext-rejection-regexps nil
1576 "Variable for regexps matching plaintext to remove before encryption.
1578 This is used to detect strings in encryption results that would
1579 register as allout mode structural elements, for example, as a
1580 topic prefix.
1582 Entries must be symbols that are bound to the desired regexp values.
1584 Encryptions that result in matches will be retried, up to
1585 `allout-encryption-ciphertext-rejection-limit' times, after which
1586 an error is raised.")
1588 (make-variable-buffer-local 'allout-encryption-ciphertext-rejection-regexps)
1589 ;;;_ = allout-encryption-ciphertext-rejection-ceiling
1590 (defvar allout-encryption-ciphertext-rejection-ceiling 5
1591 "Limit on number of times encryption ciphertext is rejected.
1593 See `allout-encryption-ciphertext-rejection-regexps' for rejection reasons.")
1594 (make-variable-buffer-local 'allout-encryption-ciphertext-rejection-ceiling)
1595 ;;;_ > allout-mode-p ()
1596 ;; Must define this macro above any uses, or byte compilation will lack
1597 ;; proper def, if file isn't loaded -- eg, during emacs build!
1598 ;;;###autoload
1599 (defmacro allout-mode-p ()
1600 "Return t if `allout-mode' is active in current buffer."
1601 'allout-mode)
1602 ;;;_ > allout-write-contents-hook-handler ()
1603 (defun allout-write-contents-hook-handler ()
1604 "Implement `allout-encrypt-unencrypted-on-saves' for file writes
1606 Return nil if all goes smoothly, or else return an informative
1607 message if an error is encountered. The message will serve as a
1608 non-nil return on `write-contents-functions' to prevent saving of
1609 the buffer while it has decrypted content.
1611 This behavior depends on Emacs versions that implement the
1612 `write-contents-functions' hook."
1614 (if (or (not (allout-mode-p))
1615 (not (boundp 'allout-encrypt-unencrypted-on-saves))
1616 (not allout-encrypt-unencrypted-on-saves))
1618 (if (save-excursion (goto-char (point-min))
1619 (allout-next-topic-pending-encryption))
1620 (progn
1621 (message "auto-encrypting pending topics")
1622 (sit-for 0)
1623 (condition-case failure
1624 (progn
1625 (setq allout-after-save-decrypt
1626 (allout-encrypt-decrypted))
1627 ;; aok - return nil:
1628 nil)
1629 (error
1630 ;; whoops - probably some still-decrypted items, return non-nil:
1631 (let ((text (format (concat "%s contents write inhibited due to"
1632 " encrypted topic encryption error:"
1633 " %s")
1634 (buffer-name (current-buffer))
1635 failure)))
1636 (message text)(sit-for 2)
1637 text)))))
1639 ;;;_ > allout-after-saves-handler ()
1640 (defun allout-after-saves-handler ()
1641 "Decrypt topic encrypted for save, if it's currently being edited.
1643 Ie, if it was pending encryption and contained the point in its body before
1644 the save.
1646 We use values stored in `allout-after-save-decrypt' to locate the topic
1647 and the place for the cursor after the decryption is done."
1648 (if (not (and (allout-mode-p)
1649 (boundp 'allout-after-save-decrypt)
1650 allout-after-save-decrypt))
1652 (goto-char (car allout-after-save-decrypt))
1653 (let ((was-modified (buffer-modified-p)))
1654 (allout-toggle-subtree-encryption)
1655 (if (not was-modified)
1656 (set-buffer-modified-p nil)))
1657 (goto-char (cadr allout-after-save-decrypt))
1658 (setq allout-after-save-decrypt nil))
1660 ;;;_ > allout-called-interactively-p ()
1661 (defmacro allout-called-interactively-p ()
1662 "A version of `called-interactively-p' independent of Emacs version."
1663 ;; ... to ease maintenance of allout without betraying deprecation.
1664 (if (equal (subr-arity (symbol-function 'called-interactively-p))
1665 '(0 . 0))
1666 '(called-interactively-p)
1667 '(called-interactively-p 'interactive)))
1668 ;;;_ = allout-inhibit-aberrance-doublecheck nil
1669 ;; In some exceptional moments, disparate topic depths need to be allowed
1670 ;; momentarily, eg when one topic is being yanked into another and they're
1671 ;; about to be reconciled. let-binding allout-inhibit-aberrance-doublecheck
1672 ;; prevents the aberrance doublecheck to allow, eg, the reconciliation
1673 ;; processing to happen in the presence of such discrepancies. It should
1674 ;; almost never be needed, however.
1675 (defvar allout-inhibit-aberrance-doublecheck nil
1676 "Internal state, for momentarily inhibits aberrance doublecheck.
1678 This should only be momentarily let-bound non-nil, not set
1679 non-nil in a lasting way.")
1681 ;;;_ #2 Mode environment and activation
1682 ;;;_ = allout-explicitly-deactivated
1683 (defvar allout-explicitly-deactivated nil
1684 "If t, `allout-mode's last deactivation was deliberate.
1685 So `allout-post-command-business' should not reactivate it...")
1686 (make-variable-buffer-local 'allout-explicitly-deactivated)
1687 ;;;_ > allout-init (mode)
1688 (defun allout-init (mode)
1689 "DEPRECATED - configure allout activation by customizing
1690 `allout-auto-activation'. This function remains around, limited
1691 from what it did before, for backwards compatibility.
1693 MODE is the activation mode - see `allout-auto-activation' for
1694 valid values."
1696 (custom-set-variables (list 'allout-auto-activation (format "%s" mode)))
1697 (format "%s" mode))
1698 (make-obsolete 'allout-init
1699 "customize 'allout-auto-activation' instead." "23.3")
1700 ;;;_ > allout-setup-menubar ()
1701 (defun allout-setup-menubar ()
1702 "Populate the current buffer's menubar with `allout-mode' stuff."
1703 (let ((menus (list allout-mode-exposure-menu
1704 allout-mode-editing-menu
1705 allout-mode-navigation-menu
1706 allout-mode-misc-menu))
1707 cur)
1708 (while menus
1709 (setq cur (car menus)
1710 menus (cdr menus))
1711 (easy-menu-add cur))))
1712 ;;;_ > allout-overlay-preparations
1713 (defun allout-overlay-preparations ()
1714 "Set the properties of the allout invisible-text overlay and others."
1715 (setplist 'allout-exposure-category nil)
1716 (put 'allout-exposure-category 'invisible 'allout)
1717 (put 'allout-exposure-category 'evaporate t)
1718 ;; ??? We use isearch-open-invisible *and* isearch-mode-end-hook. The
1719 ;; latter would be sufficient, but it seems that a separate behavior --
1720 ;; the _transient_ opening of invisible text during isearch -- is keyed to
1721 ;; presence of the isearch-open-invisible property -- even though this
1722 ;; property controls the isearch _arrival_ behavior. This is the case at
1723 ;; least in emacs 21, 22.1, and xemacs 21.4.
1724 (put 'allout-exposure-category 'isearch-open-invisible
1725 'allout-isearch-end-handler)
1726 (if (featurep 'xemacs)
1727 (put 'allout-exposure-category 'start-open t)
1728 (put 'allout-exposure-category 'insert-in-front-hooks
1729 '(allout-overlay-insert-in-front-handler)))
1730 (put 'allout-exposure-category 'modification-hooks
1731 '(allout-overlay-interior-modification-handler)))
1732 ;;;_ > define-minor-mode allout-mode
1733 ;;;_ : Defun:
1734 ;;;###autoload
1735 (define-minor-mode allout-mode
1736 ;;;_ . Doc string:
1737 "Toggle Allout outline mode.
1738 With a prefix argument ARG, enable Allout outline mode if ARG is
1739 positive, and disable it otherwise. If called from Lisp, enable
1740 the mode if ARG is omitted or nil.
1742 \\<allout-mode-map-value>
1743 Allout outline mode is a minor mode that provides extensive
1744 outline oriented formatting and manipulation. It enables
1745 structural editing of outlines, as well as navigation and
1746 exposure. It also is specifically aimed at accommodating
1747 syntax-sensitive text like programming languages. (For example,
1748 see the allout code itself, which is organized as an allout
1749 outline.)
1751 In addition to typical outline navigation and exposure, allout includes:
1753 - topic-oriented authoring, including keystroke-based topic creation,
1754 repositioning, promotion/demotion, cut, and paste
1755 - incremental search with dynamic exposure and reconcealment of hidden text
1756 - adjustable format, so programming code can be developed in outline-structure
1757 - easy topic encryption and decryption, symmetric or key-pair
1758 - \"Hot-spot\" operation, for single-keystroke maneuvering and exposure control
1759 - integral outline layout, for automatic initial exposure when visiting a file
1760 - independent extensibility, using comprehensive exposure and authoring hooks
1762 and many other features.
1764 Below is a description of the key bindings, and then description
1765 of special `allout-mode' features and terminology. See also the
1766 outline menubar additions for quick reference to many of the
1767 features. Customize `allout-auto-activation' to prepare your
1768 Emacs session for automatic activation of `allout-mode'.
1770 The bindings are those listed in `allout-prefixed-keybindings'
1771 and `allout-unprefixed-keybindings'. We recommend customizing
1772 `allout-command-prefix' to use just `\\C-c' as the command
1773 prefix, if the allout bindings don't conflict with any personal
1774 bindings you have on \\C-c. In any case, outline structure
1775 navigation and authoring is simplified by positioning the cursor
1776 on an item's bullet character, the \"hot-spot\" -- then you can
1777 invoke allout commands with just the un-prefixed,
1778 un-control-shifted command letters. This is described further in
1779 the HOT-SPOT Operation section.
1781 Exposure Control:
1782 ----------------
1783 \\[allout-hide-current-subtree] `allout-hide-current-subtree'
1784 \\[allout-show-children] `allout-show-children'
1785 \\[allout-show-current-subtree] `allout-show-current-subtree'
1786 \\[allout-show-current-entry] `allout-show-current-entry'
1787 \\[allout-show-all] `allout-show-all'
1789 Navigation:
1790 ----------
1791 \\[allout-next-visible-heading] `allout-next-visible-heading'
1792 \\[allout-previous-visible-heading] `allout-previous-visible-heading'
1793 \\[allout-up-current-level] `allout-up-current-level'
1794 \\[allout-forward-current-level] `allout-forward-current-level'
1795 \\[allout-backward-current-level] `allout-backward-current-level'
1796 \\[allout-end-of-entry] `allout-end-of-entry'
1797 \\[allout-beginning-of-current-entry] `allout-beginning-of-current-entry' (alternately, goes to hot-spot)
1798 \\[allout-beginning-of-line] `allout-beginning-of-line' -- like regular beginning-of-line, but
1799 if immediately repeated cycles to the beginning of the current item
1800 and then to the hot-spot (if `allout-beginning-of-line-cycles' is set).
1803 Topic Header Production:
1804 -----------------------
1805 \\[allout-open-sibtopic] `allout-open-sibtopic' Create a new sibling after current topic.
1806 \\[allout-open-subtopic] `allout-open-subtopic' ... an offspring of current topic.
1807 \\[allout-open-supertopic] `allout-open-supertopic' ... a sibling of the current topic's parent.
1809 Topic Level and Prefix Adjustment:
1810 ---------------------------------
1811 \\[allout-shift-in] `allout-shift-in' Shift current topic and all offspring deeper
1812 \\[allout-shift-out] `allout-shift-out' ... less deep
1813 \\[allout-rebullet-current-heading] `allout-rebullet-current-heading' Prompt for alternate bullet for
1814 current topic
1815 \\[allout-rebullet-topic] `allout-rebullet-topic' Reconcile bullets of topic and
1816 its offspring -- distinctive bullets are not changed, others
1817 are alternated according to nesting depth.
1818 \\[allout-number-siblings] `allout-number-siblings' Number bullets of topic and siblings --
1819 the offspring are not affected.
1820 With repeat count, revoke numbering.
1822 Topic-oriented Killing and Yanking:
1823 ----------------------------------
1824 \\[allout-kill-topic] `allout-kill-topic' Kill current topic, including offspring.
1825 \\[allout-copy-topic-as-kill] `allout-copy-topic-as-kill' Copy current topic, including offspring.
1826 \\[allout-kill-line] `allout-kill-line' Kill line, attending to outline structure.
1827 \\[allout-copy-line-as-kill] `allout-copy-line-as-kill' Copy line but don't delete it.
1828 \\[allout-yank] `allout-yank' Yank, adjusting depth of yanked topic to
1829 depth of heading if yanking into bare topic
1830 heading (ie, prefix sans text).
1831 \\[allout-yank-pop] `allout-yank-pop' Is to `allout-yank' as `yank-pop' is to `yank'.
1833 Topic-oriented Encryption:
1834 -------------------------
1835 \\[allout-toggle-current-subtree-encryption] `allout-toggle-current-subtree-encryption'
1836 Encrypt/Decrypt topic content
1838 Misc commands:
1839 -------------
1840 M-x outlineify-sticky Activate outline mode for current buffer,
1841 and establish a default file-var setting
1842 for `allout-layout'.
1843 \\[allout-mark-topic] `allout-mark-topic'
1844 \\[allout-copy-exposed-to-buffer] `allout-copy-exposed-to-buffer'
1845 Duplicate outline, sans concealed text, to
1846 buffer with name derived from derived from that
1847 of current buffer -- \"*BUFFERNAME exposed*\".
1848 \\[allout-flatten-exposed-to-buffer] `allout-flatten-exposed-to-buffer'
1849 Like above 'copy-exposed', but convert topic
1850 prefixes to section.subsection... numeric
1851 format.
1852 \\[customize-variable] allout-auto-activation
1853 Prepare Emacs session for allout outline mode
1854 auto-activation.
1856 Topic Encryption
1858 Outline mode supports gpg encryption of topics, with support for
1859 symmetric and key-pair modes, and auto-encryption of topics
1860 pending encryption on save.
1862 Topics pending encryption are, by default, automatically
1863 encrypted during file saves, including checkpoint saves, to avoid
1864 exposing the plain text of encrypted topics in the file system.
1865 If the content of the topic containing the cursor was encrypted
1866 for a save, it is automatically decrypted for continued editing.
1868 NOTE: A few GnuPG v2 versions improperly preserve incorrect
1869 symmetric decryption keys, preventing entry of the correct key on
1870 subsequent decryption attempts until the cache times-out. That
1871 can take several minutes. (Decryption of other entries is not
1872 affected.) Upgrade your EasyPG version, if you can, and you can
1873 deliberately clear your gpg-agent's cache by sending it a '-HUP'
1874 signal.
1876 See `allout-toggle-current-subtree-encryption' function docstring
1877 and `allout-encrypt-unencrypted-on-saves' customization variable
1878 for details.
1880 HOT-SPOT Operation
1882 Hot-spot operation provides a means for easy, single-keystroke outline
1883 navigation and exposure control.
1885 When the text cursor is positioned directly on the bullet character of
1886 a topic, regular characters (a to z) invoke the commands of the
1887 corresponding allout-mode keymap control chars. For example, \"f\"
1888 would invoke the command typically bound to \"C-c<space>C-f\"
1889 \(\\[allout-forward-current-level] `allout-forward-current-level').
1891 Thus, by positioning the cursor on a topic bullet, you can
1892 execute the outline navigation and manipulation commands with a
1893 single keystroke. Regular navigation keys (eg, \\[forward-char], \\[next-line]) don't get
1894 this special translation, so you can use them to get out of the
1895 hot-spot and back to normal editing operation.
1897 In allout-mode, the normal beginning-of-line command (\\[allout-beginning-of-line]) is
1898 replaced with one that makes it easy to get to the hot-spot. If you
1899 repeat it immediately it cycles (if `allout-beginning-of-line-cycles'
1900 is set) to the beginning of the item and then, if you hit it again
1901 immediately, to the hot-spot. Similarly, `allout-beginning-of-current-entry'
1902 \(\\[allout-beginning-of-current-entry]) moves to the hot-spot when the cursor is already located
1903 at the beginning of the current entry.
1905 Extending Allout
1907 Allout exposure and authoring activities all have associated
1908 hooks, by which independent code can cooperate with allout
1909 without changes to the allout core. Here are key ones:
1911 `allout-mode-hook'
1912 `allout-mode-deactivate-hook' (deprecated)
1913 `allout-mode-off-hook'
1914 `allout-exposure-change-functions'
1915 `allout-structure-added-functions'
1916 `allout-structure-deleted-functions'
1917 `allout-structure-shifted-functions'
1918 `allout-after-copy-or-kill-hook'
1919 `allout-post-undo-hook'
1921 Terminology
1923 Topic hierarchy constituents -- TOPICS and SUBTOPICS:
1925 ITEM: A unitary outline element, including the HEADER and ENTRY text.
1926 TOPIC: An ITEM and any ITEMs contained within it, ie having greater DEPTH
1927 and with no intervening items of lower DEPTH than the container.
1928 CURRENT ITEM:
1929 The visible ITEM most immediately containing the cursor.
1930 DEPTH: The degree of nesting of an ITEM; it increases with containment.
1931 The DEPTH is determined by the HEADER PREFIX. The DEPTH is also
1932 called the:
1933 LEVEL: The same as DEPTH.
1935 ANCESTORS:
1936 Those ITEMs whose TOPICs contain an ITEM.
1937 PARENT: An ITEM's immediate ANCESTOR. It has a DEPTH one less than that
1938 of the ITEM.
1939 OFFSPRING:
1940 The ITEMs contained within an ITEM's TOPIC.
1941 SUBTOPIC:
1942 An OFFSPRING of its ANCESTOR TOPICs.
1943 CHILD:
1944 An immediate SUBTOPIC of its PARENT.
1945 SIBLINGS:
1946 TOPICs having the same PARENT and DEPTH.
1948 Topic text constituents:
1950 HEADER: The first line of an ITEM, include the ITEM PREFIX and HEADER
1951 text.
1952 ENTRY: The text content of an ITEM, before any OFFSPRING, but including
1953 the HEADER text and distinct from the ITEM PREFIX.
1954 BODY: Same as ENTRY.
1955 PREFIX: The leading text of an ITEM which distinguishes it from normal
1956 ENTRY text. Allout recognizes the outline structure according
1957 to the strict PREFIX format. It consists of a PREFIX-LEAD string,
1958 PREFIX-PADDING, and a BULLET. The BULLET might be followed by a
1959 number, indicating the ordinal number of the topic among its
1960 siblings, or an asterisk indicating encryption, plus an optional
1961 space. After that is the ITEM HEADER text, which is not part of
1962 the PREFIX.
1964 The relative length of the PREFIX determines the nesting DEPTH
1965 of the ITEM.
1966 PREFIX-LEAD:
1967 The string at the beginning of a HEADER PREFIX, by default a `.'.
1968 It can be customized by changing the setting of
1969 `allout-header-prefix' and then reinitializing `allout-mode'.
1971 When the PREFIX-LEAD is set to the comment-string of a
1972 programming language, outline structuring can be embedded in
1973 program code without interfering with processing of the text
1974 (by Emacs or the language processor) as program code. This
1975 setting happens automatically when allout mode is used in
1976 programming-mode buffers. See `allout-use-mode-specific-leader'
1977 docstring for more detail.
1978 PREFIX-PADDING:
1979 Spaces or asterisks which separate the PREFIX-LEAD and the
1980 bullet, determining the ITEM's DEPTH.
1981 BULLET: A character at the end of the ITEM PREFIX, it must be one of
1982 the characters listed on `allout-plain-bullets-string' or
1983 `allout-distinctive-bullets-string'. When creating a TOPIC,
1984 plain BULLETs are by default used, according to the DEPTH of the
1985 TOPIC. Choice among the distinctive BULLETs is offered when you
1986 provide a universal argument (\\[universal-argument]) to the
1987 TOPIC creation command, or when explicitly rebulleting a TOPIC. The
1988 significance of the various distinctive bullets is purely by
1989 convention. See the documentation for the above bullet strings for
1990 more details.
1991 EXPOSURE:
1992 The state of a TOPIC which determines the on-screen visibility
1993 of its OFFSPRING and contained ENTRY text.
1994 CONCEALED:
1995 TOPICs and ENTRY text whose EXPOSURE is inhibited. Concealed
1996 text is represented by \"...\" ellipses.
1998 CONCEALED TOPICs are effectively collapsed within an ANCESTOR.
1999 CLOSED: A TOPIC whose immediate OFFSPRING and body-text is CONCEALED.
2000 OPEN: A TOPIC that is not CLOSED, though its OFFSPRING or BODY may be."
2001 ;;;_ . Code
2002 :lighter " Allout"
2003 :keymap 'allout-mode-map
2005 (let ((use-layout (if (listp allout-layout)
2006 allout-layout
2007 allout-default-layout)))
2009 (if (not (allout-mode-p))
2010 (progn
2011 ;; Deactivation:
2013 ; Activation not explicitly
2014 ; requested, and either in
2015 ; active state or *de*activation
2016 ; specifically requested:
2017 (allout-do-resumptions)
2019 (remove-from-invisibility-spec '(allout . t))
2020 (remove-hook 'pre-command-hook 'allout-pre-command-business t)
2021 (remove-hook 'post-command-hook 'allout-post-command-business t)
2022 (remove-hook 'before-change-functions 'allout-before-change-handler t)
2023 (remove-hook 'isearch-mode-end-hook 'allout-isearch-end-handler t)
2024 (remove-hook 'write-contents-functions
2025 'allout-write-contents-hook-handler t)
2027 (remove-overlays (point-min) (point-max)
2028 'category 'allout-exposure-category))
2030 ;; Activating:
2031 (if allout-old-style-prefixes
2032 ;; Inhibit all the fancy formatting:
2033 (allout-add-resumptions '(allout-primary-bullet "*")))
2035 (allout-overlay-preparations) ; Doesn't hurt to redo this.
2037 (allout-infer-header-lead-and-primary-bullet)
2038 (allout-infer-body-reindent)
2040 (set-allout-regexp)
2041 (allout-add-resumptions '(allout-encryption-ciphertext-rejection-regexps
2042 allout-line-boundary-regexp
2043 extend)
2044 '(allout-encryption-ciphertext-rejection-regexps
2045 allout-bob-regexp
2046 extend))
2048 (allout-compose-and-institute-keymap)
2049 (produce-allout-mode-menubar-entries)
2051 (add-to-invisibility-spec '(allout . t))
2053 (allout-add-resumptions '(line-move-ignore-invisible t))
2054 (add-hook 'pre-command-hook 'allout-pre-command-business nil t)
2055 (add-hook 'post-command-hook 'allout-post-command-business nil t)
2056 (add-hook 'before-change-functions 'allout-before-change-handler nil t)
2057 (add-hook 'isearch-mode-end-hook 'allout-isearch-end-handler nil t)
2058 (add-hook 'write-contents-functions 'allout-write-contents-hook-handler
2059 nil t)
2061 ;; Stash auto-fill settings and adjust so custom allout auto-fill
2062 ;; func will be used if auto-fill is active or activated. (The
2063 ;; custom func respects topic headline, maintains hanging-indents,
2064 ;; etc.)
2065 (allout-add-resumptions (list 'allout-former-auto-filler
2066 auto-fill-function)
2067 ;; Register allout-auto-fill to be used if
2068 ;; filling is active:
2069 (list 'allout-outside-normal-auto-fill-function
2070 normal-auto-fill-function)
2071 '(normal-auto-fill-function allout-auto-fill)
2072 ;; Paragraphs are broken by topic headlines.
2073 (list 'paragraph-start
2074 (concat paragraph-start "\\|^\\("
2075 allout-regexp "\\)"))
2076 (list 'paragraph-separate
2077 (concat paragraph-separate "\\|^\\("
2078 allout-regexp "\\)")))
2079 (if (and auto-fill-function (not allout-inhibit-auto-fill))
2080 ;; allout-auto-fill will use the stashed values and so forth.
2081 (allout-add-resumptions '(auto-fill-function allout-auto-fill)))
2083 (allout-setup-menubar)
2085 ;; Do auto layout if warranted:
2086 (when (and allout-layout
2087 allout-auto-activation
2088 use-layout
2089 (and (not (string= allout-auto-activation "activate"))
2090 (if (string= allout-auto-activation "ask")
2091 (if (y-or-n-p (format "Expose %s with layout '%s'? "
2092 (buffer-name)
2093 use-layout))
2095 (message "Skipped %s layout." (buffer-name))
2096 nil)
2097 t)))
2098 (save-excursion
2099 (message "Adjusting '%s' exposure..." (buffer-name))
2100 (goto-char 0)
2101 (allout-this-or-next-heading)
2102 (condition-case err
2103 (progn
2104 (apply 'allout-expose-topic (list use-layout))
2105 (message "Adjusting '%s' exposure... done."
2106 (buffer-name)))
2107 ;; Problem applying exposure -- notify user, but don't
2108 ;; interrupt, eg, file visit:
2109 (error (message "%s" (car (cdr err)))
2110 (sit-for 1))))
2111 ) ; when allout-layout
2112 ) ; if (allout-mode-p)
2113 ) ; let (())
2114 ) ; define-minor-mode
2115 ;;;_ > allout-minor-mode alias
2116 (defalias 'allout-minor-mode 'allout-mode)
2117 ;;;_ > allout-unload-function
2118 (defun allout-unload-function ()
2119 "Unload the allout outline library."
2120 (save-current-buffer
2121 (dolist (buffer (buffer-list))
2122 (set-buffer buffer)
2123 (when (allout-mode-p) (allout-mode -1))))
2124 ;; continue standard unloading
2125 nil)
2127 ;;;_ - Position Assessment
2128 ;;;_ > allout-hidden-p (&optional pos)
2129 (defsubst allout-hidden-p (&optional pos)
2130 "Non-nil if the character after point was made invisible by allout."
2131 (eq (get-char-property (or pos (point)) 'invisible) 'allout))
2133 ;;;_ > allout-overlay-insert-in-front-handler (ol after beg end
2134 ;;; &optional prelen)
2135 (defun allout-overlay-insert-in-front-handler (ol after beg end
2136 &optional prelen)
2137 "Shift the overlay so stuff inserted in front of it is excluded."
2138 (if after
2139 ;; ??? Shouldn't moving the overlay should be unnecessary, if overlay
2140 ;; front-advance on the overlay worked as expected?
2141 (move-overlay ol (1+ beg) (overlay-end ol))))
2142 ;;;_ > allout-overlay-interior-modification-handler (ol after beg end
2143 ;;; &optional prelen)
2144 (defun allout-overlay-interior-modification-handler (ol after beg end
2145 &optional prelen)
2146 "Get confirmation before making arbitrary changes to invisible text.
2148 We expose the invisible text and ask for confirmation. Refusal or
2149 `keyboard-quit' abandons the changes, with keyboard-quit additionally
2150 reclosing the opened text.
2152 No confirmation is necessary when `inhibit-read-only' is set -- eg, allout
2153 internal functions use this feature cohesively bunch changes."
2155 (when (and (not inhibit-read-only) (not after))
2156 (let ((start (point))
2157 (ol-start (overlay-start ol))
2158 (ol-end (overlay-end ol))
2159 first)
2160 (goto-char beg)
2161 (while (< (point) end)
2162 (when (allout-hidden-p)
2163 (allout-show-to-offshoot)
2164 (if (allout-hidden-p)
2165 (save-excursion (forward-char 1)
2166 (allout-show-to-offshoot)))
2167 (when (not first)
2168 (setq first (point))))
2169 (goto-char (if (featurep 'xemacs)
2170 (next-property-change (1+ (point)) nil end)
2171 (next-char-property-change (1+ (point)) end))))
2172 (when first
2173 (goto-char first)
2174 (condition-case nil
2175 (if (not
2176 (yes-or-no-p
2177 (substitute-command-keys
2178 (concat "Modify concealed text? (\"no\" just aborts,"
2179 " \\[keyboard-quit] also reconceals) "))))
2180 (progn (goto-char start)
2181 (error "Concealed-text change refused")))
2182 (quit (allout-flag-region ol-start ol-end nil)
2183 (allout-flag-region ol-start ol-end t)
2184 (error "Concealed-text change abandoned, text reconcealed"))))
2185 (goto-char start))))
2186 ;;;_ > allout-before-change-handler (beg end)
2187 (defun allout-before-change-handler (beg end)
2188 "Protect against changes to invisible text.
2190 See `allout-overlay-interior-modification-handler' for details."
2192 (when (and (allout-mode-p) undo-in-progress)
2193 (setq allout-just-did-undo t)
2194 (if (allout-hidden-p)
2195 (allout-show-children)))
2197 ;; allout-overlay-interior-modification-handler on an overlay handles
2198 ;; this in other emacs, via `allout-exposure-category's 'modification-hooks.
2199 (when (and (featurep 'xemacs) (allout-mode-p))
2200 ;; process all of the pending overlays:
2201 (save-excursion
2202 (goto-char beg)
2203 (let ((overlay (allout-get-invisibility-overlay)))
2204 (if overlay
2205 (allout-overlay-interior-modification-handler
2206 overlay nil beg end nil))))))
2207 ;;;_ > allout-isearch-end-handler (&optional overlay)
2208 (defun allout-isearch-end-handler (&optional overlay)
2209 "Reconcile allout outline exposure on arriving in hidden text after isearch.
2211 Optional OVERLAY parameter is for when this function is used by
2212 `isearch-open-invisible' overlay property. It is otherwise unused, so this
2213 function can also be used as an `isearch-mode-end-hook'."
2215 (if (and (allout-mode-p) (allout-hidden-p))
2216 (allout-show-to-offshoot)))
2218 ;;;_ #3 Internal Position State-Tracking -- "allout-recent-*" funcs
2219 ;; All the basic outline functions that directly do string matches to
2220 ;; evaluate heading prefix location set the variables
2221 ;; `allout-recent-prefix-beginning' and `allout-recent-prefix-end'
2222 ;; when successful. Functions starting with `allout-recent-' all
2223 ;; use this state, providing the means to avoid redundant searches
2224 ;; for just-established data. This optimization can provide
2225 ;; significant speed improvement, but it must be employed carefully.
2226 ;;;_ = allout-recent-prefix-beginning
2227 (defvar allout-recent-prefix-beginning 0
2228 "Buffer point of the start of the last topic prefix encountered.")
2229 (make-variable-buffer-local 'allout-recent-prefix-beginning)
2230 ;;;_ = allout-recent-prefix-end
2231 (defvar allout-recent-prefix-end 0
2232 "Buffer point of the end of the last topic prefix encountered.")
2233 (make-variable-buffer-local 'allout-recent-prefix-end)
2234 ;;;_ = allout-recent-depth
2235 (defvar allout-recent-depth 0
2236 "Depth of the last topic prefix encountered.")
2237 (make-variable-buffer-local 'allout-recent-depth)
2238 ;;;_ = allout-recent-end-of-subtree
2239 (defvar allout-recent-end-of-subtree 0
2240 "Buffer point last returned by `allout-end-of-current-subtree'.")
2241 (make-variable-buffer-local 'allout-recent-end-of-subtree)
2242 ;;;_ > allout-prefix-data ()
2243 (defsubst allout-prefix-data ()
2244 "Register allout-prefix state data.
2246 For reference by `allout-recent' funcs. Return
2247 the new value of `allout-recent-prefix-beginning'."
2248 (setq allout-recent-prefix-end (or (match-end 1) (match-end 2) (match-end 3))
2249 allout-recent-prefix-beginning (or (match-beginning 1)
2250 (match-beginning 2)
2251 (match-beginning 3))
2252 allout-recent-depth (max 1 (- allout-recent-prefix-end
2253 allout-recent-prefix-beginning
2254 allout-header-subtraction)))
2255 allout-recent-prefix-beginning)
2256 ;;;_ > nullify-allout-prefix-data ()
2257 (defsubst nullify-allout-prefix-data ()
2258 "Mark allout prefix data as being uninformative."
2259 (setq allout-recent-prefix-end (point)
2260 allout-recent-prefix-beginning (point)
2261 allout-recent-depth 0)
2262 allout-recent-prefix-beginning)
2263 ;;;_ > allout-recent-depth ()
2264 (defsubst allout-recent-depth ()
2265 "Return depth of last heading encountered by an outline maneuvering function.
2267 All outline functions which directly do string matches to assess
2268 headings set the variables `allout-recent-prefix-beginning' and
2269 `allout-recent-prefix-end' if successful. This function uses those settings
2270 to return the current depth."
2272 allout-recent-depth)
2273 ;;;_ > allout-recent-prefix ()
2274 (defsubst allout-recent-prefix ()
2275 "Like `allout-recent-depth', but returns text of last encountered prefix.
2277 All outline functions which directly do string matches to assess
2278 headings set the variables `allout-recent-prefix-beginning' and
2279 `allout-recent-prefix-end' if successful. This function uses those settings
2280 to return the current prefix."
2281 (buffer-substring-no-properties allout-recent-prefix-beginning
2282 allout-recent-prefix-end))
2283 ;;;_ > allout-recent-bullet ()
2284 (defmacro allout-recent-bullet ()
2285 "Like `allout-recent-prefix', but returns bullet of last encountered prefix.
2287 All outline functions which directly do string matches to assess
2288 headings set the variables `allout-recent-prefix-beginning' and
2289 `allout-recent-prefix-end' if successful. This function uses those settings
2290 to return the current depth of the most recently matched topic."
2291 '(buffer-substring-no-properties (1- allout-recent-prefix-end)
2292 allout-recent-prefix-end))
2294 ;;;_ #4 Navigation
2296 ;;;_ - Position Assessment
2297 ;;;_ : Location Predicates
2298 ;;;_ > allout-do-doublecheck ()
2299 (defsubst allout-do-doublecheck ()
2300 "True if current item conditions qualify for checking on topic aberrance."
2301 (and
2302 ;; presume integrity of outline and yanked content during yank -- necessary
2303 ;; to allow for level disparity of yank location and yanked text:
2304 (not allout-inhibit-aberrance-doublecheck)
2305 ;; allout-doublecheck-at-and-shallower is ceiling for doublecheck:
2306 (<= allout-recent-depth allout-doublecheck-at-and-shallower)))
2307 ;;;_ > allout-aberrant-container-p ()
2308 (defun allout-aberrant-container-p ()
2309 "True if topic, or next sibling with children, contains them discontinuously.
2311 Discontinuous means an immediate offspring that is nested more
2312 than one level deeper than the topic.
2314 If topic has no offspring, then the next sibling with offspring will
2315 determine whether or not this one is determined to be aberrant.
2317 If true, then the allout-recent-* settings are calibrated on the
2318 offspring that qualifies it as aberrant, ie with depth that
2319 exceeds the topic by more than one."
2321 ;; This is most clearly understood when considering standard-prefix-leader
2322 ;; low-level topics, which can all too easily match text not intended as
2323 ;; headers. For example, any line with a leading '.' or '*' and lacking a
2324 ;; following bullet qualifies without this protection. (A sequence of
2325 ;; them can occur naturally, eg a typical textual bullet list.) We
2326 ;; disqualify such low-level sequences when they are followed by a
2327 ;; discontinuously contained child, inferring that the sequences are not
2328 ;; actually connected with their prospective context.
2330 (let ((depth (allout-depth))
2331 (start-point (point))
2332 done aberrant)
2333 (save-match-data
2334 (save-excursion
2335 (while (and (not done)
2336 (re-search-forward allout-line-boundary-regexp nil 0))
2337 (allout-prefix-data)
2338 (goto-char allout-recent-prefix-beginning)
2339 (cond
2340 ;; sibling -- continue:
2341 ((eq allout-recent-depth depth))
2342 ;; first offspring is excessive -- aberrant:
2343 ((> allout-recent-depth (1+ depth))
2344 (setq done t aberrant t))
2345 ;; next non-sibling is lower-depth -- not aberrant:
2346 (t (setq done t))))))
2347 (if aberrant
2348 aberrant
2349 (goto-char start-point)
2350 ;; recalibrate allout-recent-*
2351 (allout-depth)
2352 nil)))
2353 ;;;_ > allout-on-current-heading-p ()
2354 (defun allout-on-current-heading-p ()
2355 "Return non-nil if point is on current visible topics' header line.
2357 Actually, returns prefix beginning point."
2358 (save-excursion
2359 (allout-beginning-of-current-line)
2360 (save-match-data
2361 (and (looking-at allout-regexp)
2362 (allout-prefix-data)
2363 (or (not (allout-do-doublecheck))
2364 (not (allout-aberrant-container-p)))))))
2365 ;;;_ > allout-on-heading-p ()
2366 (defalias 'allout-on-heading-p 'allout-on-current-heading-p)
2367 ;;;_ > allout-e-o-prefix-p ()
2368 (defun allout-e-o-prefix-p ()
2369 "True if point is located where current topic prefix ends, heading begins."
2370 (and (save-match-data
2371 (save-excursion (let ((inhibit-field-text-motion t))
2372 (beginning-of-line))
2373 (looking-at allout-regexp))
2374 (= (point) (save-excursion (allout-end-of-prefix)(point))))))
2375 ;;;_ : Location attributes
2376 ;;;_ > allout-depth ()
2377 (defun allout-depth ()
2378 "Return depth of topic most immediately containing point.
2380 Does not do doublecheck for aberrant topic header.
2382 Return zero if point is not within any topic.
2384 Like `allout-current-depth', but respects hidden as well as visible topics."
2385 (save-excursion
2386 (let ((start-point (point)))
2387 (if (and (allout-goto-prefix)
2388 (not (< start-point (point))))
2389 allout-recent-depth
2390 (progn
2391 ;; Oops, no prefix, nullify it:
2392 (nullify-allout-prefix-data)
2393 ;; ... and return 0:
2394 0)))))
2395 ;;;_ > allout-current-depth ()
2396 (defun allout-current-depth ()
2397 "Return depth of visible topic most immediately containing point.
2399 Return zero if point is not within any topic."
2400 (save-excursion
2401 (if (allout-back-to-current-heading)
2402 (max 1
2403 (- allout-recent-prefix-end
2404 allout-recent-prefix-beginning
2405 allout-header-subtraction))
2406 0)))
2407 ;;;_ > allout-get-current-prefix ()
2408 (defun allout-get-current-prefix ()
2409 "Topic prefix of the current topic."
2410 (save-excursion
2411 (if (allout-goto-prefix)
2412 (allout-recent-prefix))))
2413 ;;;_ > allout-get-bullet ()
2414 (defun allout-get-bullet ()
2415 "Return bullet of containing topic (visible or not)."
2416 (save-excursion
2417 (and (allout-goto-prefix)
2418 (allout-recent-bullet))))
2419 ;;;_ > allout-current-bullet ()
2420 (defun allout-current-bullet ()
2421 "Return bullet of current (visible) topic heading, or none if none found."
2422 (condition-case nil
2423 (save-excursion
2424 (allout-back-to-current-heading)
2425 (buffer-substring-no-properties (- allout-recent-prefix-end 1)
2426 allout-recent-prefix-end))
2427 ;; Quick and dirty provision, ostensibly for missing bullet:
2428 (args-out-of-range nil))
2430 ;;;_ > allout-get-prefix-bullet (prefix)
2431 (defun allout-get-prefix-bullet (prefix)
2432 "Return the bullet of the header prefix string PREFIX."
2433 ;; Doesn't make sense if we're old-style prefixes, but this just
2434 ;; oughtn't be called then, so forget about it...
2435 (if (string-match allout-regexp prefix)
2436 (substring prefix (1- (match-end 2)) (match-end 2))))
2437 ;;;_ > allout-sibling-index (&optional depth)
2438 (defun allout-sibling-index (&optional depth)
2439 "Item number of this prospective topic among its siblings.
2441 If optional arg DEPTH is greater than current depth, then we're
2442 opening a new level, and return 0.
2444 If less than this depth, ascend to that depth and count..."
2446 (save-excursion
2447 (cond ((and depth (<= depth 0) 0))
2448 ((or (null depth) (= depth (allout-depth)))
2449 (let ((index 1))
2450 (while (allout-previous-sibling allout-recent-depth nil)
2451 (setq index (1+ index)))
2452 index))
2453 ((< depth allout-recent-depth)
2454 (allout-ascend-to-depth depth)
2455 (allout-sibling-index))
2456 (0))))
2457 ;;;_ > allout-topic-flat-index ()
2458 (defun allout-topic-flat-index ()
2459 "Return a list indicating point's numeric section.subsect.subsubsect...
2460 Outermost is first."
2461 (let* ((depth (allout-depth))
2462 (next-index (allout-sibling-index depth))
2463 (rev-sibls nil))
2464 (while (> next-index 0)
2465 (setq rev-sibls (cons next-index rev-sibls))
2466 (setq depth (1- depth))
2467 (setq next-index (allout-sibling-index depth)))
2468 rev-sibls)
2471 ;;;_ - Navigation routines
2472 ;;;_ > allout-beginning-of-current-line ()
2473 (defun allout-beginning-of-current-line ()
2474 "Like beginning of line, but to visible text."
2476 ;; This combination of move-beginning-of-line and beginning-of-line is
2477 ;; deliberate, but the (beginning-of-line) may now be superfluous.
2478 (let ((inhibit-field-text-motion t))
2479 (move-beginning-of-line 1)
2480 (beginning-of-line)
2481 (while (and (not (bobp)) (or (not (bolp)) (allout-hidden-p)))
2482 (beginning-of-line)
2483 (if (or (allout-hidden-p) (not (bolp)))
2484 (forward-char -1)))))
2485 ;;;_ > allout-end-of-current-line ()
2486 (defun allout-end-of-current-line ()
2487 "Move to the end of line, past concealed text if any."
2488 ;; This is for symmetry with `allout-beginning-of-current-line' --
2489 ;; `move-end-of-line' doesn't suffer the same problem as
2490 ;; `move-beginning-of-line'.
2491 (let ((inhibit-field-text-motion t))
2492 (end-of-line)
2493 (while (allout-hidden-p)
2494 (end-of-line)
2495 (if (allout-hidden-p) (forward-char 1)))))
2496 ;;;_ > allout-beginning-of-line ()
2497 (defun allout-beginning-of-line ()
2498 "Beginning-of-line with `allout-beginning-of-line-cycles' behavior, if set."
2500 (interactive)
2502 (if (or (not allout-beginning-of-line-cycles)
2503 (not (equal last-command this-command)))
2504 (progn
2505 (if (and (not (bolp))
2506 (allout-hidden-p (1- (point))))
2507 (goto-char (allout-previous-single-char-property-change
2508 (1- (point)) 'invisible)))
2509 (move-beginning-of-line 1))
2510 (allout-depth)
2511 (let ((beginning-of-body
2512 (save-excursion
2513 (while (and (allout-do-doublecheck)
2514 (allout-aberrant-container-p)
2515 (allout-previous-visible-heading 1)))
2516 (allout-beginning-of-current-entry)
2517 (point))))
2518 (cond ((= (current-column) 0)
2519 (goto-char beginning-of-body))
2520 ((< (point) beginning-of-body)
2521 (allout-beginning-of-current-line))
2522 ((= (point) beginning-of-body)
2523 (goto-char (allout-current-bullet-pos)))
2524 (t (allout-beginning-of-current-line)
2525 (if (< (point) beginning-of-body)
2526 ;; we were on the headline after its start:
2527 (goto-char beginning-of-body)))))))
2528 ;;;_ > allout-end-of-line ()
2529 (defun allout-end-of-line ()
2530 "End-of-line with `allout-end-of-line-cycles' behavior, if set."
2532 (interactive)
2534 (if (or (not allout-end-of-line-cycles)
2535 (not (equal last-command this-command)))
2536 (allout-end-of-current-line)
2537 (let ((end-of-entry (save-excursion
2538 (allout-end-of-entry)
2539 (point))))
2540 (cond ((not (eolp))
2541 (allout-end-of-current-line))
2542 ((or (allout-hidden-p) (save-excursion
2543 (forward-char -1)
2544 (allout-hidden-p)))
2545 (allout-back-to-current-heading)
2546 (allout-show-current-entry)
2547 (allout-show-children)
2548 (allout-end-of-entry))
2549 ((>= (point) end-of-entry)
2550 (allout-back-to-current-heading)
2551 (allout-end-of-current-line))
2553 (if (not (allout-mark-active-p))
2554 (push-mark))
2555 (allout-end-of-entry))))))
2556 ;;;_ > allout-mark-active-p ()
2557 (defun allout-mark-active-p ()
2558 "True if the mark is currently or always active."
2559 ;; `(cond (boundp...))' (or `(if ...)') invokes special byte-compiler
2560 ;; provisions, at least in GNU Emacs to prevent warnings about lack of,
2561 ;; eg, region-active-p.
2562 (cond ((boundp 'mark-active)
2563 mark-active)
2564 ((fboundp 'region-active-p)
2565 (region-active-p))
2566 (t)))
2567 ;;;_ > allout-next-heading ()
2568 (defsubst allout-next-heading ()
2569 "Move to the heading for the topic (possibly invisible) after this one.
2571 Returns the location of the heading, or nil if none found.
2573 We skip anomalous low-level topics, a la `allout-aberrant-container-p'."
2574 (save-match-data
2576 (if (looking-at allout-regexp)
2577 (forward-char 1))
2579 (when (re-search-forward allout-line-boundary-regexp nil 0)
2580 (allout-prefix-data)
2581 (goto-char allout-recent-prefix-beginning)
2582 (while (not (bolp))
2583 (forward-char -1))
2584 (and (allout-do-doublecheck)
2585 ;; this will set allout-recent-* on the first non-aberrant topic,
2586 ;; whether it's the current one or one that disqualifies it:
2587 (allout-aberrant-container-p))
2588 ;; this may or may not be the same as above depending on doublecheck:
2589 (goto-char allout-recent-prefix-beginning))))
2590 ;;;_ > allout-this-or-next-heading
2591 (defun allout-this-or-next-heading ()
2592 "Position cursor on current or next heading."
2593 ;; A throwaway non-macro that is defined after allout-next-heading
2594 ;; and usable by allout-mode.
2595 (if (not (allout-goto-prefix-doublechecked)) (allout-next-heading)))
2596 ;;;_ > allout-previous-heading ()
2597 (defun allout-previous-heading ()
2598 "Move to the prior (possibly invisible) heading line.
2600 Return the location of the beginning of the heading, or nil if not found.
2602 We skip anomalous low-level topics, a la `allout-aberrant-container-p'."
2604 (if (bobp)
2606 (let ((start-point (point)))
2607 ;; allout-goto-prefix-doublechecked calls us, so we can't use it here.
2608 (allout-goto-prefix)
2609 (save-match-data
2610 (when (or (re-search-backward allout-line-boundary-regexp nil 0)
2611 (looking-at allout-bob-regexp))
2612 (goto-char (allout-prefix-data))
2613 (if (and (allout-do-doublecheck)
2614 (allout-aberrant-container-p))
2615 (or (allout-previous-heading)
2616 (and (goto-char start-point)
2617 ;; recalibrate allout-recent-*:
2618 (allout-depth)
2619 nil))
2620 (point)))))))
2621 ;;;_ > allout-get-invisibility-overlay ()
2622 (defun allout-get-invisibility-overlay ()
2623 "Return the overlay at point that dictates allout invisibility."
2624 (let ((overlays (overlays-at (point)))
2625 got)
2626 (while (and overlays (not got))
2627 (if (equal (overlay-get (car overlays) 'invisible) 'allout)
2628 (setq got (car overlays))
2629 (pop overlays)))
2630 got))
2631 ;;;_ > allout-back-to-visible-text ()
2632 (defun allout-back-to-visible-text ()
2633 "Move to most recent prior character that is visible, and return point."
2634 (if (allout-hidden-p)
2635 (goto-char (overlay-start (allout-get-invisibility-overlay))))
2636 (point))
2638 ;;;_ - Subtree Charting
2639 ;;;_ " These routines either produce or assess charts, which are
2640 ;;; nested lists of the locations of topics within a subtree.
2642 ;;; Charts enable efficient subtree navigation by providing a reusable basis
2643 ;;; for elaborate, compound assessment and adjustment of a subtree.
2645 ;;;_ > allout-chart-subtree (&optional levels visible orig-depth prev-depth)
2646 (defun allout-chart-subtree (&optional levels visible orig-depth prev-depth)
2647 "Produce a location \"chart\" of subtopics of the containing topic.
2649 Optional argument LEVELS specifies a depth limit (relative to start
2650 depth) for the chart. Null LEVELS means no limit.
2652 When optional argument VISIBLE is non-nil, the chart includes
2653 only the visible subelements of the charted subjects.
2655 The remaining optional args are for internal use by the function.
2657 Point is left at the end of the subtree.
2659 Charts are used to capture outline structure, so that outline-altering
2660 routines need to assess the structure only once, and then use the chart
2661 for their elaborate manipulations.
2663 The chart entries for the topics are in reverse order, so the
2664 last topic is listed first. The entry for each topic consists of
2665 an integer indicating the point at the beginning of the topic
2666 prefix. Charts for offspring consist of a list containing,
2667 recursively, the charts for the respective subtopics. The chart
2668 for a topics' offspring precedes the entry for the topic itself.
2670 The other function parameters are for internal recursion, and should
2671 not be specified by external callers. ORIG-DEPTH is depth of topic at
2672 starting point, and PREV-DEPTH is depth of prior topic."
2674 (let ((original (not orig-depth)) ; `orig-depth' set only in recursion.
2675 chart curr-depth)
2677 (if original ; Just starting?
2678 ; Register initial settings and
2679 ; position to first offspring:
2680 (progn (setq orig-depth (allout-depth))
2681 (or prev-depth (setq prev-depth (1+ orig-depth)))
2682 (if visible
2683 (allout-next-visible-heading 1)
2684 (allout-next-heading))))
2686 ;; Loop over the current levels' siblings. Besides being more
2687 ;; efficient than tail-recursing over a level, it avoids exceeding
2688 ;; the typically quite constrained Emacs max-lisp-eval-depth.
2690 ;; Probably would speed things up to implement loop-based stack
2691 ;; operation rather than recursing for lower levels. Bah.
2693 (while (and (not (eobp))
2694 ; Still within original topic?
2695 (< orig-depth (setq curr-depth allout-recent-depth))
2696 (cond ((= prev-depth curr-depth)
2697 ;; Register this one and move on:
2698 (setq chart (cons allout-recent-prefix-beginning chart))
2699 (if (and levels (<= levels 1))
2700 ;; At depth limit -- skip sublevels:
2701 (or (allout-next-sibling curr-depth)
2702 ;; or no more siblings -- proceed to
2703 ;; next heading at lesser depth:
2704 (while (and (<= curr-depth
2705 allout-recent-depth)
2706 (if visible
2707 (allout-next-visible-heading 1)
2708 (allout-next-heading)))))
2709 (if visible
2710 (allout-next-visible-heading 1)
2711 (allout-next-heading))))
2713 ((and (< prev-depth curr-depth)
2714 (or (not levels)
2715 (> levels 0)))
2716 ;; Recurse on deeper level of curr topic:
2717 (setq chart
2718 (cons (allout-chart-subtree (and levels
2719 (1- levels))
2720 visible
2721 orig-depth
2722 curr-depth)
2723 chart))
2724 ;; ... then continue with this one.
2727 ;; ... else nil if we've ascended back to prev-depth.
2731 (if original ; We're at the last sibling on
2732 ; the original level. Position
2733 ; to the end of it:
2734 (progn (and (not (eobp)) (forward-char -1))
2735 (and (= (preceding-char) ?\n)
2736 (= (aref (buffer-substring (max 1 (- (point) 3))
2737 (point))
2739 ?\n)
2740 (forward-char -1))
2741 (setq allout-recent-end-of-subtree (point))))
2743 chart ; (nreverse chart) not necessary,
2744 ; and maybe not preferable.
2746 ;;;_ > allout-chart-siblings (&optional start end)
2747 (defun allout-chart-siblings (&optional start end)
2748 "Produce a list of locations of this and succeeding sibling topics.
2749 Effectively a top-level chart of siblings. See `allout-chart-subtree'
2750 for an explanation of charts."
2751 (save-excursion
2752 (when (allout-goto-prefix-doublechecked)
2753 (let ((chart (list (point))))
2754 (while (allout-next-sibling)
2755 (setq chart (cons (point) chart)))
2756 (if chart (setq chart (nreverse chart)))))))
2757 ;;;_ > allout-chart-to-reveal (chart depth)
2758 (defun allout-chart-to-reveal (chart depth)
2760 "Return a flat list of hidden points in subtree CHART, up to DEPTH.
2762 If DEPTH is nil, include hidden points at any depth.
2764 Note that point can be left at any of the points on chart, or at the
2765 start point."
2767 (let (result here)
2768 (while (and (or (null depth) (> depth 0))
2769 chart)
2770 (setq here (car chart))
2771 (if (listp here)
2772 (let ((further (allout-chart-to-reveal here (if (null depth)
2773 depth
2774 (1- depth)))))
2775 ;; We're on the start of a subtree -- recurse with it, if there's
2776 ;; more depth to go:
2777 (if further (setq result (append further result)))
2778 (setq chart (cdr chart)))
2779 (goto-char here)
2780 (if (allout-hidden-p)
2781 (setq result (cons here result)))
2782 (setq chart (cdr chart))))
2783 result))
2784 ;;;_ X allout-chart-spec (chart spec &optional exposing)
2785 ;; (defun allout-chart-spec (chart spec &optional exposing)
2786 ;; "Not yet (if ever) implemented.
2788 ;; Produce exposure directives given topic/subtree CHART and an exposure SPEC.
2790 ;; Exposure spec indicates the locations to be exposed and the prescribed
2791 ;; exposure status. Optional arg EXPOSING is an integer, with 0
2792 ;; indicating pending concealment, anything higher indicating depth to
2793 ;; which subtopic headers should be exposed, and negative numbers
2794 ;; indicating (negative of) the depth to which subtopic headers and
2795 ;; bodies should be exposed.
2797 ;; The produced list can have two types of entries. Bare numbers
2798 ;; indicate points in the buffer where topic headers that should be
2799 ;; exposed reside.
2801 ;; - bare negative numbers indicates that the topic starting at the
2802 ;; point which is the negative of the number should be opened,
2803 ;; including their entries.
2804 ;; - bare positive values indicate that this topic header should be
2805 ;; opened.
2806 ;; - Lists signify the beginning and end points of regions that should
2807 ;; be flagged, and the flag to employ. (For concealment: `(\?r)', and
2808 ;; exposure:"
2809 ;; (while spec
2810 ;; (cond ((listp spec)
2811 ;; )
2812 ;; )
2813 ;; (setq spec (cdr spec)))
2814 ;; )
2816 ;;;_ - Within Topic
2817 ;;;_ > allout-goto-prefix ()
2818 (defun allout-goto-prefix ()
2819 "Put point at beginning of immediately containing outline topic.
2821 Goes to most immediate subsequent topic if none immediately containing.
2823 Not sensitive to topic visibility.
2825 Returns the point at the beginning of the prefix, or nil if none."
2827 (save-match-data
2828 (let (done)
2829 (while (and (not done)
2830 (search-backward "\n" nil 1))
2831 (forward-char 1)
2832 (if (looking-at allout-regexp)
2833 (setq done (allout-prefix-data))
2834 (forward-char -1)))
2835 (if (bobp)
2836 (cond ((looking-at allout-regexp)
2837 (allout-prefix-data))
2838 ((allout-next-heading))
2839 (done))
2840 done))))
2841 ;;;_ > allout-goto-prefix-doublechecked ()
2842 (defun allout-goto-prefix-doublechecked ()
2843 "Put point at beginning of immediately containing outline topic.
2845 Like `allout-goto-prefix', but shallow topics (according to
2846 `allout-doublecheck-at-and-shallower') are checked and
2847 disqualified for child containment discontinuity, according to
2848 `allout-aberrant-container-p'."
2849 (if (allout-goto-prefix)
2850 (if (and (allout-do-doublecheck)
2851 (allout-aberrant-container-p))
2852 (allout-previous-heading)
2853 (point))))
2855 ;;;_ > allout-end-of-prefix ()
2856 (defun allout-end-of-prefix (&optional ignore-decorations)
2857 "Position cursor at beginning of header text.
2859 If optional IGNORE-DECORATIONS is non-nil, put just after bullet,
2860 otherwise skip white space between bullet and ensuing text."
2862 (if (not (allout-goto-prefix-doublechecked))
2864 (goto-char allout-recent-prefix-end)
2865 (save-match-data
2866 (if ignore-decorations
2868 (while (looking-at "[0-9]") (forward-char 1))
2869 (if (and (not (eolp)) (looking-at "\\s-")) (forward-char 1))))
2870 ;; Reestablish where we are:
2871 (allout-current-depth)))
2872 ;;;_ > allout-current-bullet-pos ()
2873 (defun allout-current-bullet-pos ()
2874 "Return position of current (visible) topic's bullet."
2876 (if (not (allout-current-depth))
2878 (1- allout-recent-prefix-end)))
2879 ;;;_ > allout-back-to-current-heading (&optional interactive)
2880 (defun allout-back-to-current-heading (&optional interactive)
2881 "Move to heading line of current topic, or beginning if not in a topic.
2883 If interactive, we position at the end of the prefix.
2885 Return value of resulting point, unless we started outside
2886 of (before any) topics, in which case we return nil."
2888 (interactive "p")
2890 (allout-beginning-of-current-line)
2891 (let ((bol-point (point)))
2892 (when (allout-goto-prefix-doublechecked)
2893 (if (<= (point) bol-point)
2894 (progn
2895 (setq bol-point (point))
2896 (allout-beginning-of-current-line)
2897 (if (not (= bol-point (point)))
2898 (if (looking-at allout-regexp)
2899 (allout-prefix-data)))
2900 (if interactive
2901 (allout-end-of-prefix)
2902 (point)))
2903 (goto-char (point-min))
2904 nil))))
2905 ;;;_ > allout-back-to-heading ()
2906 (defalias 'allout-back-to-heading 'allout-back-to-current-heading)
2907 ;;;_ > allout-pre-next-prefix ()
2908 (defun allout-pre-next-prefix ()
2909 "Skip forward to just before the next heading line.
2911 Returns that character position."
2913 (if (allout-next-heading)
2914 (goto-char (1- allout-recent-prefix-beginning))))
2915 ;;;_ > allout-end-of-subtree (&optional current include-trailing-blank)
2916 (defun allout-end-of-subtree (&optional current include-trailing-blank)
2917 "Put point at the end of the last leaf in the containing topic.
2919 Optional CURRENT means put point at the end of the containing
2920 visible topic.
2922 Optional INCLUDE-TRAILING-BLANK means include a trailing blank line, if
2923 any, as part of the subtree. Otherwise, that trailing blank will be
2924 excluded as delimiting whitespace between topics.
2926 Returns the value of point."
2927 (interactive "P")
2928 (if current
2929 (allout-back-to-current-heading)
2930 (allout-goto-prefix-doublechecked))
2931 (let ((level allout-recent-depth))
2932 (allout-next-heading)
2933 (while (and (not (eobp))
2934 (> allout-recent-depth level))
2935 (allout-next-heading))
2936 (if (eobp)
2937 (allout-end-of-entry)
2938 (forward-char -1))
2939 (if (and (not include-trailing-blank) (= ?\n (preceding-char)))
2940 (forward-char -1))
2941 (setq allout-recent-end-of-subtree (point))))
2942 ;;;_ > allout-end-of-current-subtree (&optional include-trailing-blank)
2943 (defun allout-end-of-current-subtree (&optional include-trailing-blank)
2945 "Put point at end of last leaf in currently visible containing topic.
2947 Optional INCLUDE-TRAILING-BLANK means include a trailing blank line, if
2948 any, as part of the subtree. Otherwise, that trailing blank will be
2949 excluded as delimiting whitespace between topics.
2951 Returns the value of point."
2952 (interactive)
2953 (allout-end-of-subtree t include-trailing-blank))
2954 ;;;_ > allout-beginning-of-current-entry (&optional interactive)
2955 (defun allout-beginning-of-current-entry (&optional interactive)
2956 "When not already there, position point at beginning of current topic header.
2958 If already there, move cursor to bullet for hot-spot operation.
2959 \(See `allout-mode' doc string for details of hot-spot operation.)"
2960 (interactive "p")
2961 (let ((start-point (point)))
2962 (move-beginning-of-line 1)
2963 (if (< 0 (allout-current-depth))
2964 (goto-char allout-recent-prefix-end)
2965 (goto-char (point-min)))
2966 (allout-end-of-prefix)
2967 (if (and interactive
2968 (= (point) start-point))
2969 (goto-char (allout-current-bullet-pos)))))
2970 ;;;_ > allout-end-of-entry (&optional inclusive)
2971 (defun allout-end-of-entry (&optional inclusive)
2972 "Position the point at the end of the current topics' entry.
2974 Optional INCLUSIVE means also include trailing empty line, if any. When
2975 unset, whitespace between items separates them even when the items are
2976 collapsed."
2977 (interactive)
2978 (allout-pre-next-prefix)
2979 (if (and (not inclusive) (not (bobp)) (= ?\n (preceding-char)))
2980 (forward-char -1))
2981 (point))
2982 ;;;_ > allout-end-of-current-heading ()
2983 (defun allout-end-of-current-heading ()
2984 (interactive)
2985 (allout-beginning-of-current-entry)
2986 (search-forward "\n" nil t)
2987 (forward-char -1))
2988 (defalias 'allout-end-of-heading 'allout-end-of-current-heading)
2989 ;;;_ > allout-get-body-text ()
2990 (defun allout-get-body-text ()
2991 "Return the unmangled body text of the topic immediately containing point."
2992 (save-excursion
2993 (allout-end-of-prefix)
2994 (if (not (search-forward "\n" nil t))
2996 (backward-char 1)
2997 (let ((pre-body (point)))
2998 (if (not pre-body)
3000 (allout-end-of-entry t)
3001 (if (not (= pre-body (point)))
3002 (buffer-substring-no-properties (1+ pre-body) (point))))
3008 ;;;_ - Depth-wise
3009 ;;;_ > allout-ascend-to-depth (depth)
3010 (defun allout-ascend-to-depth (depth)
3011 "Ascend to depth DEPTH, returning depth if successful, nil if not."
3012 (if (and (> depth 0)(<= depth (allout-depth)))
3013 (let (last-ascended)
3014 (while (and (< depth allout-recent-depth)
3015 (setq last-ascended (allout-ascend))))
3016 (goto-char allout-recent-prefix-beginning)
3017 (if (allout-called-interactively-p) (allout-end-of-prefix))
3018 (and last-ascended allout-recent-depth))))
3019 ;;;_ > allout-ascend (&optional dont-move-if-unsuccessful)
3020 (defun allout-ascend (&optional dont-move-if-unsuccessful)
3021 "Ascend one level, returning resulting depth if successful, nil if not.
3023 Point is left at the beginning of the level whether or not
3024 successful, unless optional DONT-MOVE-IF-UNSUCCESSFUL is set, in
3025 which case point is returned to its original starting location."
3026 (if dont-move-if-unsuccessful
3027 (setq dont-move-if-unsuccessful (point)))
3028 (prog1
3029 (if (allout-beginning-of-level)
3030 (let ((bolevel (point))
3031 (bolevel-depth allout-recent-depth))
3032 (allout-previous-heading)
3033 (cond ((< allout-recent-depth bolevel-depth)
3034 allout-recent-depth)
3035 ((= allout-recent-depth bolevel-depth)
3036 (if dont-move-if-unsuccessful
3037 (goto-char dont-move-if-unsuccessful))
3038 (allout-depth)
3039 nil)
3041 ;; some topic after very first is lower depth than first:
3042 (goto-char bolevel)
3043 (allout-depth)
3044 nil))))
3045 (if (allout-called-interactively-p) (allout-end-of-prefix))))
3046 ;;;_ > allout-descend-to-depth (depth)
3047 (defun allout-descend-to-depth (depth)
3048 "Descend to depth DEPTH within current topic.
3050 Returning depth if successful, nil if not."
3051 (let ((start-point (point))
3052 (start-depth (allout-depth)))
3053 (while
3054 (and (> (allout-depth) 0)
3055 (not (= depth allout-recent-depth)) ; ... not there yet
3056 (allout-next-heading) ; ... go further
3057 (< start-depth allout-recent-depth))) ; ... still in topic
3058 (if (and (> (allout-depth) 0)
3059 (= allout-recent-depth depth))
3060 depth
3061 (goto-char start-point)
3062 nil))
3064 ;;;_ > allout-up-current-level (arg)
3065 (defun allout-up-current-level (arg)
3066 "Move out ARG levels from current visible topic."
3067 (interactive "p")
3068 (let ((start-point (point)))
3069 (allout-back-to-current-heading)
3070 (if (not (allout-ascend))
3071 (progn (goto-char start-point)
3072 (error "Can't ascend past outermost level"))
3073 (if (allout-called-interactively-p) (allout-end-of-prefix))
3074 allout-recent-prefix-beginning)))
3076 ;;;_ - Linear
3077 ;;;_ > allout-next-sibling (&optional depth backward)
3078 (defun allout-next-sibling (&optional depth backward)
3079 "Like `allout-forward-current-level', but respects invisible topics.
3081 Traverse at optional DEPTH, or current depth if none specified.
3083 Go backward if optional arg BACKWARD is non-nil.
3085 Return the start point of the new topic if successful, nil otherwise."
3087 (if (if backward (bobp) (eobp))
3089 (let ((target-depth (or depth (allout-depth)))
3090 (start-point (point))
3091 (start-prefix-beginning allout-recent-prefix-beginning)
3092 (count 0)
3093 leaping
3094 last-depth)
3095 (while (and
3096 ;; done too few single steps to resort to the leap routine:
3097 (not leaping)
3098 ;; not at limit:
3099 (not (if backward (bobp) (eobp)))
3100 ;; still traversable:
3101 (if backward (allout-previous-heading) (allout-next-heading))
3102 ;; we're below the target depth
3103 (> (setq last-depth allout-recent-depth) target-depth))
3104 (setq count (1+ count))
3105 (if (> count 7) ; lists are commonly 7 +- 2, right?-)
3106 (setq leaping t)))
3107 (cond (leaping
3108 (or (allout-next-sibling-leap target-depth backward)
3109 (progn
3110 (goto-char start-point)
3111 (if depth (allout-depth) target-depth)
3112 nil)))
3113 ((and (not (eobp))
3114 (and (> (or last-depth (allout-depth)) 0)
3115 (= allout-recent-depth target-depth))
3116 (not (= start-prefix-beginning
3117 allout-recent-prefix-beginning)))
3118 allout-recent-prefix-beginning)
3120 (goto-char start-point)
3121 (if depth (allout-depth) target-depth)
3122 nil)))))
3123 ;;;_ > allout-next-sibling-leap (&optional depth backward)
3124 (defun allout-next-sibling-leap (&optional depth backward)
3125 "Like `allout-next-sibling', but by direct search for topic at depth.
3127 Traverse at optional DEPTH, or current depth if none specified.
3129 Go backward if optional arg BACKWARD is non-nil.
3131 Return the start point of the new topic if successful, nil otherwise.
3133 Costs more than regular `allout-next-sibling' for short traversals:
3135 - we have to check the prior (next, if traveling backwards)
3136 item to confirm connectivity with the prior topic, and
3137 - if confirmed, we have to reestablish the allout-recent-* settings with
3138 some extra navigation
3139 - if confirmation fails, we have to do more work to recover
3141 It is an increasingly big win when there are many intervening
3142 offspring before the next sibling, however, so
3143 `allout-next-sibling' resorts to this if it finds itself in that
3144 situation."
3146 (if (if backward (bobp) (eobp))
3148 (let* ((start-point (point))
3149 (target-depth (or depth (allout-depth)))
3150 (search-whitespace-regexp nil)
3151 (depth-biased (- target-depth 2))
3152 (expression (if (<= target-depth 1)
3153 allout-depth-one-regexp
3154 (format allout-depth-specific-regexp
3155 depth-biased depth-biased)))
3156 found
3157 done)
3158 (while (not done)
3159 (setq found (save-match-data
3160 (if backward
3161 (re-search-backward expression nil 'to-limit)
3162 (forward-char 1)
3163 (re-search-forward expression nil 'to-limit))))
3164 (if (and found (allout-aberrant-container-p))
3165 (setq found nil))
3166 (setq done (or found (if backward (bobp) (eobp)))))
3167 (if (not found)
3168 (progn (goto-char start-point)
3169 nil)
3170 ;; rationale: if any intervening items were at a lower depth, we
3171 ;; would now be on the first offspring at the target depth -- ie,
3172 ;; the preceding item (per the search direction) must be at a
3173 ;; lesser depth. that's all we need to check.
3174 (if backward (allout-next-heading) (allout-previous-heading))
3175 (if (< allout-recent-depth target-depth)
3176 ;; return to start and reestablish allout-recent-*:
3177 (progn
3178 (goto-char start-point)
3179 (allout-depth)
3180 nil)
3181 (goto-char found)
3182 ;; locate cursor and set allout-recent-*:
3183 (allout-goto-prefix))))))
3184 ;;;_ > allout-previous-sibling (&optional depth backward)
3185 (defun allout-previous-sibling (&optional depth backward)
3186 "Like `allout-forward-current-level' backwards, respecting invisible topics.
3188 Optional DEPTH specifies depth to traverse, default current depth.
3190 Optional BACKWARD reverses direction.
3192 Return depth if successful, nil otherwise."
3193 (allout-next-sibling depth (not backward))
3195 ;;;_ > allout-snug-back ()
3196 (defun allout-snug-back ()
3197 "Position cursor at end of previous topic.
3199 Presumes point is at the start of a topic prefix."
3200 (if (or (bobp) (eobp))
3202 (forward-char -1))
3203 (if (or (bobp) (not (= ?\n (preceding-char))))
3205 (forward-char -1))
3206 (point))
3207 ;;;_ > allout-beginning-of-level ()
3208 (defun allout-beginning-of-level ()
3209 "Go back to the first sibling at this level, visible or not."
3210 (allout-end-of-level 'backward))
3211 ;;;_ > allout-end-of-level (&optional backward)
3212 (defun allout-end-of-level (&optional backward)
3213 "Go to the last sibling at this level, visible or not."
3215 (let ((depth (allout-depth)))
3216 (while (allout-previous-sibling depth nil))
3217 (prog1 allout-recent-depth
3218 (if (allout-called-interactively-p) (allout-end-of-prefix)))))
3219 ;;;_ > allout-next-visible-heading (arg)
3220 (defun allout-next-visible-heading (arg)
3221 "Move to the next ARGth visible heading line, backward if ARG is negative.
3223 Move to buffer limit in indicated direction if headings are exhausted."
3225 (interactive "p")
3226 (let* ((inhibit-field-text-motion t)
3227 (backward (if (< arg 0) (setq arg (* -1 arg))))
3228 (step (if backward -1 1))
3229 (progress (allout-current-bullet-pos))
3230 prev got)
3232 (while (> arg 0)
3233 (while (and
3234 ;; Boundary condition:
3235 (not (if backward (bobp)(eobp)))
3236 ;; Move, skipping over all concealed lines in one fell swoop:
3237 (prog1 (condition-case nil (or (line-move step) t)
3238 (error nil))
3239 (allout-beginning-of-current-line)
3240 ;; line-move can wind up on the same line if long.
3241 ;; when moving forward, that would yield no-progress
3242 (when (and (not backward)
3243 (<= (point) progress))
3244 ;; ensure progress by doing line-move from end-of-line:
3245 (end-of-line)
3246 (condition-case nil (or (line-move step) t)
3247 (error nil))
3248 (allout-beginning-of-current-line)
3249 (setq progress (point))))
3250 ;; Deal with apparent header line:
3251 (save-match-data
3252 (if (not (looking-at allout-regexp))
3253 ;; not a header line, keep looking:
3255 (allout-prefix-data)
3256 (if (and (allout-do-doublecheck)
3257 (allout-aberrant-container-p))
3258 ;; skip this aberrant prospective header line:
3260 ;; this prospective headerline qualifies -- register:
3261 (setq got allout-recent-prefix-beginning)
3262 ;; and break the loop:
3263 nil)))))
3264 ;; Register this got, it may be the last:
3265 (if got (setq prev got))
3266 (setq arg (1- arg)))
3267 (cond (got ; Last move was to a prefix:
3268 (allout-end-of-prefix))
3269 (prev ; Last move wasn't, but prev was:
3270 (goto-char prev)
3271 (allout-end-of-prefix))
3272 ((not backward) (end-of-line) nil))))
3273 ;;;_ > allout-previous-visible-heading (arg)
3274 (defun allout-previous-visible-heading (arg)
3275 "Move to the previous heading line.
3277 With argument, repeats or can move forward if negative.
3278 A heading line is one that starts with a `*' (or that `allout-regexp'
3279 matches)."
3280 (interactive "p")
3281 (prog1 (allout-next-visible-heading (- arg))
3282 (if (allout-called-interactively-p) (allout-end-of-prefix))))
3283 ;;;_ > allout-forward-current-level (arg)
3284 (defun allout-forward-current-level (arg)
3285 "Position point at the next heading of the same level.
3287 Takes optional repeat-count, goes backward if count is negative.
3289 Returns resulting position, else nil if none found."
3290 (interactive "p")
3291 (let ((start-depth (allout-current-depth))
3292 (start-arg arg)
3293 (backward (> 0 arg)))
3294 (if (= 0 start-depth)
3295 (error "No siblings, not in a topic..."))
3296 (if backward (setq arg (* -1 arg)))
3297 (allout-back-to-current-heading)
3298 (while (and (not (zerop arg))
3299 (if backward
3300 (allout-previous-sibling)
3301 (allout-next-sibling)))
3302 (setq arg (1- arg)))
3303 (if (not (allout-called-interactively-p))
3305 (allout-end-of-prefix)
3306 (if (not (zerop arg))
3307 (error "Hit %s level %d topic, traversed %d of %d requested"
3308 (if backward "first" "last")
3309 allout-recent-depth
3310 (- (abs start-arg) arg)
3311 (abs start-arg))))))
3312 ;;;_ > allout-backward-current-level (arg)
3313 (defun allout-backward-current-level (arg)
3314 "Inverse of `allout-forward-current-level'."
3315 (interactive "p")
3316 (if (allout-called-interactively-p)
3317 (let ((current-prefix-arg (* -1 arg)))
3318 (call-interactively 'allout-forward-current-level))
3319 (allout-forward-current-level (* -1 arg))))
3321 ;;;_ #5 Alteration
3323 ;;;_ - Fundamental
3324 ;;;_ = allout-post-goto-bullet
3325 (defvar allout-post-goto-bullet nil
3326 "Outline internal var, for `allout-pre-command-business' hot-spot operation.
3328 When set, tells post-processing to reposition on topic bullet, and
3329 then unset it. Set by `allout-pre-command-business' when implementing
3330 hot-spot operation, where literal characters typed over a topic bullet
3331 are mapped to the command of the corresponding control-key on the
3332 `allout-mode-map-value'.")
3333 (make-variable-buffer-local 'allout-post-goto-bullet)
3334 ;;;_ = allout-command-counter
3335 (defvar allout-command-counter 0
3336 "Counter that monotonically increases in allout-mode buffers.
3338 Set by `allout-pre-command-business', to support allout addons in
3339 coordinating with allout activity.")
3340 (make-variable-buffer-local 'allout-command-counter)
3341 ;;;_ = allout-this-command-hid-text
3342 (defvar allout-this-command-hid-text nil
3343 "True if the most recent allout-mode command hid any text.")
3344 (make-variable-buffer-local 'allout-this-command-hid-text)
3345 ;;;_ > allout-post-command-business ()
3346 (defun allout-post-command-business ()
3347 "Outline `post-command-hook' function.
3349 - Implement (and clear) `allout-post-goto-bullet', for hot-spot
3350 outline commands.
3352 - Move the cursor to the beginning of the entry if it is hidden
3353 and collapsing activity just happened.
3355 - If the command we're following was an undo, check for change in
3356 the status of encrypted items and adjust auto-save inhibitions
3357 accordingly.
3359 - Decrypt topic currently being edited if it was encrypted for a save."
3361 (if (not (allout-mode-p)) ; In allout-mode.
3364 (when allout-just-did-undo
3365 (setq allout-just-did-undo nil)
3366 (run-hooks 'allout-post-undo-hook)
3367 (cond ((and (= buffer-saved-size -1)
3368 allout-auto-save-temporarily-disabled)
3369 ;; user possibly undid a decryption, disinhibit auto-save:
3370 (allout-maybe-resume-auto-save-info-after-encryption))
3371 ((save-excursion
3372 (save-restriction
3373 (widen)
3374 (goto-char (point-min))
3375 (not (allout-next-topic-pending-encryption))))
3376 ;; plain-text encrypted items are present, inhibit auto-save:
3377 (allout-inhibit-auto-save-info-for-decryption (buffer-size)))))
3379 (if (and (boundp 'allout-after-save-decrypt)
3380 allout-after-save-decrypt)
3381 (allout-after-saves-handler))
3383 ;; Implement allout-post-goto-bullet, if set:
3384 (if (and allout-post-goto-bullet
3385 (allout-current-bullet-pos))
3386 (progn (goto-char (allout-current-bullet-pos))
3387 (setq allout-post-goto-bullet nil))
3388 (when (and (allout-hidden-p) allout-this-command-hid-text)
3389 (allout-beginning-of-current-entry)))))
3390 ;;;_ > allout-pre-command-business ()
3391 (defun allout-pre-command-business ()
3392 "Outline `pre-command-hook' function for outline buffers.
3394 Among other things, implements special behavior when the cursor is on the
3395 topic bullet character.
3397 When the cursor is on the bullet character, self-insert
3398 characters are reinterpreted as the corresponding
3399 control-character in the `allout-mode-map-value'. The
3400 `allout-mode' `post-command-hook' insures that the cursor which
3401 has moved as a result of such reinterpretation is positioned on
3402 the bullet character of the destination topic.
3404 The upshot is that you can get easy, single (ie, unmodified) key
3405 outline maneuvering operations by positioning the cursor on the bullet
3406 char. When in this mode you can use regular cursor-positioning
3407 command/keystrokes to relocate the cursor off of a bullet character to
3408 return to regular interpretation of self-insert characters."
3410 (if (not (allout-mode-p))
3412 (setq allout-command-counter (1+ allout-command-counter))
3413 (setq allout-this-command-hid-text nil)
3414 ;; Do hot-spot navigation.
3415 (if (and (eq this-command 'self-insert-command)
3416 (eq (point)(allout-current-bullet-pos)))
3417 (allout-hotspot-key-handler))))
3418 ;;;_ > allout-hotspot-key-handler ()
3419 (defun allout-hotspot-key-handler ()
3420 "Catchall handling of key bindings in hot-spots.
3422 Translates unmodified keystrokes to corresponding allout commands, when
3423 they would qualify if prefixed with the `allout-command-prefix', and sets
3424 `this-command' accordingly.
3426 Returns the qualifying command, if any, else nil."
3427 (interactive)
3428 (let* ((modified (event-modifiers last-command-event))
3429 (key-num (cond ((numberp last-command-event) last-command-event)
3430 ;; for XEmacs character type:
3431 ((and (fboundp 'characterp)
3432 (apply 'characterp (list last-command-event)))
3433 (apply 'char-to-int (list last-command-event)))
3434 (t 0)))
3435 mapped-binding)
3437 (if (zerop key-num)
3440 (if (and
3441 ;; exclude control chars and escape:
3442 (not modified)
3443 (<= 33 key-num)
3444 (setq mapped-binding
3446 ;; try control-modified versions of keys:
3447 (key-binding (vconcat allout-command-prefix
3448 (vector
3449 (if (and (<= 97 key-num) ; "a"
3450 (>= 122 key-num)) ; "z"
3451 (- key-num 96) key-num)))
3453 ;; try non-modified versions of keys:
3454 (key-binding (vconcat allout-command-prefix
3455 (vector key-num))
3456 t))))
3457 ;; Qualified as an allout command -- do hot-spot operation.
3458 (setq allout-post-goto-bullet t)
3459 ;; accept-defaults nil, or else we get allout-item-icon-key-handler.
3460 (setq mapped-binding (key-binding (vector key-num))))
3462 (while (keymapp mapped-binding)
3463 (setq mapped-binding
3464 (lookup-key mapped-binding (vector (read-char)))))
3466 (when mapped-binding
3467 (setq this-command mapped-binding)))))
3469 ;;;_ > allout-find-file-hook ()
3470 (defun allout-find-file-hook ()
3471 "Activate `allout-mode' on non-nil `allout-auto-activation', `allout-layout'.
3473 See `allout-auto-activation' for setup instructions."
3474 (if (and allout-auto-activation
3475 (not (allout-mode-p))
3476 allout-layout)
3477 (allout-mode)))
3479 ;;;_ - Topic Format Assessment
3480 ;;;_ > allout-solicit-alternate-bullet (depth &optional current-bullet)
3481 (defun allout-solicit-alternate-bullet (depth &optional current-bullet)
3483 "Prompt for and return a bullet char as an alternative to the current one.
3485 Offer one suitable for current depth DEPTH as default."
3487 (let* ((default-bullet (or (and (stringp current-bullet) current-bullet)
3488 (allout-bullet-for-depth depth)))
3489 (sans-escapes (regexp-sans-escapes allout-bullets-string))
3490 choice)
3491 (save-excursion
3492 (goto-char (allout-current-bullet-pos))
3493 (setq choice (solicit-char-in-string
3494 (format "Select bullet: %s ('%s' default): "
3495 sans-escapes
3496 (allout-substring-no-properties default-bullet))
3497 sans-escapes
3498 t)))
3499 (message "")
3500 (if (string= choice "") default-bullet choice))
3502 ;;;_ > allout-distinctive-bullet (bullet)
3503 (defun allout-distinctive-bullet (bullet)
3504 "True if BULLET is one of those on `allout-distinctive-bullets-string'."
3505 (string-match (regexp-quote bullet) allout-distinctive-bullets-string))
3506 ;;;_ > allout-numbered-type-prefix (&optional prefix)
3507 (defun allout-numbered-type-prefix (&optional prefix)
3508 "True if current header prefix bullet is numbered bullet."
3509 (and allout-numbered-bullet
3510 (string= allout-numbered-bullet
3511 (if prefix
3512 (allout-get-prefix-bullet prefix)
3513 (allout-get-bullet)))))
3514 ;;;_ > allout-encrypted-type-prefix (&optional prefix)
3515 (defun allout-encrypted-type-prefix (&optional prefix)
3516 "True if current header prefix bullet is for an encrypted entry (body)."
3517 (and allout-topic-encryption-bullet
3518 (string= allout-topic-encryption-bullet
3519 (if prefix
3520 (allout-get-prefix-bullet prefix)
3521 (allout-get-bullet)))))
3522 ;;;_ > allout-bullet-for-depth (&optional depth)
3523 (defun allout-bullet-for-depth (&optional depth)
3524 "Return outline topic bullet suited to optional DEPTH, or current depth."
3525 ;; Find bullet in plain-bullets-string modulo DEPTH.
3526 (if allout-stylish-prefixes
3527 (char-to-string (aref allout-plain-bullets-string
3528 (% (max 0 (- depth 2))
3529 allout-plain-bullets-string-len)))
3530 allout-primary-bullet)
3533 ;;;_ - Topic Production
3534 ;;;_ > allout-make-topic-prefix (&optional prior-bullet
3535 (defun allout-make-topic-prefix (&optional prior-bullet
3537 depth
3538 instead
3539 number-control
3540 index)
3541 ;; Depth null means use current depth, non-null means we're either
3542 ;; opening a new topic after current topic, lower or higher, or we're
3543 ;; changing level of current topic.
3544 ;; Instead dominates specified bullet-char.
3545 ;;;_ . Doc string:
3546 "Generate a topic prefix suitable for optional arg DEPTH, or current depth.
3548 All the arguments are optional.
3550 PRIOR-BULLET indicates the bullet of the prefix being changed, or
3551 nil if none. This bullet may be preserved (other options
3552 notwithstanding) if it is on the `allout-distinctive-bullets-string',
3553 for instance.
3555 Second arg NEW indicates that a new topic is being opened after the
3556 topic at point, if non-nil. Default bullet for new topics, eg, may
3557 be set (contingent to other args) to numbered bullets if previous
3558 sibling is one. The implication otherwise is that the current topic
3559 is being adjusted -- shifted or rebulleted -- and we don't consider
3560 bullet or previous sibling.
3562 Third arg DEPTH forces the topic prefix to that depth, regardless of
3563 the current topics' depth.
3565 If INSTEAD is:
3567 - nil, then the bullet char for the context is used, per distinction or depth
3568 - a (numeric) character, then character's string representation is used
3569 - a string, then the user is asked for bullet with the first char as default
3570 - anything else, the user is solicited with bullet char per context as default
3572 \(INSTEAD overrides other options, including, eg, a distinctive
3573 PRIOR-BULLET.)
3575 Fifth arg, NUMBER-CONTROL, matters only if `allout-numbered-bullet'
3576 is non-nil *and* no specific INSTEAD was specified. Then
3577 NUMBER-CONTROL non-nil forces prefix to either numbered or
3578 unnumbered format, depending on the value of the sixth arg, INDEX.
3580 \(Note that NUMBER-CONTROL does *not* apply to level 1 topics. Sorry...)
3582 If NUMBER-CONTROL is non-nil and sixth arg INDEX is non-nil then
3583 the prefix of the topic is forced to be numbered. Non-nil
3584 NUMBER-CONTROL and nil INDEX forces non-numbered format on the
3585 bullet. Non-nil NUMBER-CONTROL and non-nil, non-number INDEX means
3586 that the index for the numbered prefix will be derived, by counting
3587 siblings back to start of level. If INDEX is a number, then that
3588 number is used as the index for the numbered prefix (allowing, eg,
3589 sequential renumbering to not require this function counting back the
3590 index for each successive sibling)."
3591 ;;;_ . Code:
3592 ;; The options are ordered in likely frequency of use, most common
3593 ;; highest, least lowest. Ie, more likely to be doing prefix
3594 ;; adjustments than soliciting, and yet more than numbering.
3595 ;; Current prefix is least dominant, but most likely to be commonly
3596 ;; specified...
3598 (let* (body
3599 numbering
3600 denumbering
3601 (depth (or depth (allout-depth)))
3602 (header-lead allout-header-prefix)
3603 (bullet-char
3605 ;; Getting value for bullet char is practically the whole job:
3607 (cond
3608 ; Simplest situation -- level 1:
3609 ((<= depth 1) (setq header-lead "") allout-primary-bullet)
3610 ; Simple, too: all asterisks:
3611 (allout-old-style-prefixes
3612 ;; Cheat -- make body the whole thing, null out header-lead and
3613 ;; bullet-char:
3614 (setq body (make-string depth
3615 (string-to-char allout-primary-bullet)))
3616 (setq header-lead "")
3619 ;; (Neither level 1 nor old-style, so we're space padding.
3620 ;; Sneak it in the condition of the next case, whatever it is.)
3622 ;; Solicitation overrides numbering and other cases:
3623 ((progn (setq body (make-string (- depth 2) ?\ ))
3624 ;; The actual condition:
3625 instead)
3626 (let ((got (cond ((stringp instead)
3627 (if (> (length instead) 0)
3628 (allout-solicit-alternate-bullet
3629 depth (substring instead 0 1))))
3630 ((characterp instead) (char-to-string instead))
3631 (t (allout-solicit-alternate-bullet depth)))))
3632 ;; Gotta check whether we're numbering and got a numbered bullet:
3633 (setq numbering (and allout-numbered-bullet
3634 (not (and number-control (not index)))
3635 (string= got allout-numbered-bullet)))
3636 ;; Now return what we got, regardless:
3637 got))
3639 ;; Numbering invoked through args:
3640 ((and allout-numbered-bullet number-control)
3641 (if (setq numbering (not (setq denumbering (not index))))
3642 allout-numbered-bullet
3643 (if (and prior-bullet
3644 (not (string= allout-numbered-bullet
3645 prior-bullet)))
3646 prior-bullet
3647 (allout-bullet-for-depth depth))))
3649 ;;; Neither soliciting nor controlled numbering ;;;
3650 ;;; (may be controlled denumbering, tho) ;;;
3652 ;; Check wrt previous sibling:
3653 ((and new ; only check for new prefixes
3654 (<= depth (allout-depth))
3655 allout-numbered-bullet ; ... & numbering enabled
3656 (not denumbering)
3657 (let ((sibling-bullet
3658 (save-excursion
3659 ;; Locate correct sibling:
3660 (or (>= depth (allout-depth))
3661 (allout-ascend-to-depth depth))
3662 (allout-get-bullet))))
3663 (if (and sibling-bullet
3664 (string= allout-numbered-bullet sibling-bullet))
3665 (setq numbering sibling-bullet)))))
3667 ;; Distinctive prior bullet?
3668 ((and prior-bullet
3669 (allout-distinctive-bullet prior-bullet)
3670 ;; Either non-numbered:
3671 (or (not (and allout-numbered-bullet
3672 (string= prior-bullet allout-numbered-bullet)))
3673 ;; or numbered, and not denumbering:
3674 (setq numbering (not denumbering)))
3675 ;; Here 'tis:
3676 prior-bullet))
3678 ;; Else, standard bullet per depth:
3679 ((allout-bullet-for-depth depth)))))
3681 (concat header-lead
3682 body
3683 bullet-char
3684 (if numbering
3685 (format "%d" (cond ((and index (numberp index)) index)
3686 (new (1+ (allout-sibling-index depth)))
3687 ((allout-sibling-index))))))
3690 ;;;_ > allout-open-topic (relative-depth &optional before offer-recent-bullet)
3691 (defun allout-open-topic (relative-depth &optional before offer-recent-bullet)
3692 "Open a new topic at depth DEPTH.
3694 New topic is situated after current one, unless optional flag BEFORE
3695 is non-nil, or unless current line is completely empty -- lacking even
3696 whitespace -- in which case open is done on the current line.
3698 When adding an offspring, it will be added immediately after the parent if
3699 the other offspring are exposed, or after the last child if the offspring
3700 are hidden. (The intervening offspring will be exposed in the latter
3701 case.)
3703 If OFFER-RECENT-BULLET is true, offer to use the bullet of the prior sibling.
3705 Nuances:
3707 - Creation of new topics is with respect to the visible topic
3708 containing the cursor, regardless of intervening concealed ones.
3710 - New headers are generally created after/before the body of a
3711 topic. However, they are created right at cursor location if the
3712 cursor is on a blank line, even if that breaks the current topic
3713 body. This is intentional, to provide a simple means for
3714 deliberately dividing topic bodies.
3716 - Double spacing of topic lists is preserved. Also, the first
3717 level two topic is created double-spaced (and so would be
3718 subsequent siblings, if that's left intact). Otherwise,
3719 single-spacing is used.
3721 - Creation of sibling or nested topics is with respect to the topic
3722 you're starting from, even when creating backwards. This way you
3723 can easily create a sibling in front of the current topic without
3724 having to go to its preceding sibling, and then open forward
3725 from there."
3727 (allout-beginning-of-current-line)
3728 (save-match-data
3729 (let* ((inhibit-field-text-motion t)
3730 (depth (+ (allout-current-depth) relative-depth))
3731 (opening-on-blank (if (looking-at "^\$")
3732 (not (setq before nil))))
3733 ;; bunch o vars set while computing ref-topic
3734 opening-numbered
3735 ref-depth
3736 ref-bullet
3737 (ref-topic (save-excursion
3738 (cond ((< relative-depth 0)
3739 (allout-ascend-to-depth depth))
3740 ((>= relative-depth 1) nil)
3741 (t (allout-back-to-current-heading)))
3742 (setq ref-depth allout-recent-depth)
3743 (setq ref-bullet
3744 (if (> allout-recent-prefix-end 1)
3745 (allout-recent-bullet)
3746 ""))
3747 (setq opening-numbered
3748 (save-excursion
3749 (and allout-numbered-bullet
3750 (or (<= relative-depth 0)
3751 (allout-descend-to-depth depth))
3752 (if (allout-numbered-type-prefix)
3753 allout-numbered-bullet))))
3754 (point)))
3755 dbl-space
3756 doing-beginning
3757 start end)
3759 (if (not opening-on-blank)
3760 ; Positioning and vertical
3761 ; padding -- only if not
3762 ; opening-on-blank:
3763 (progn
3764 (goto-char ref-topic)
3765 (setq dbl-space ; Determine double space action:
3766 (or (and (<= relative-depth 0) ; not descending;
3767 (save-excursion
3768 ;; at b-o-b or preceded by a blank line?
3769 (or (> 0 (forward-line -1))
3770 (looking-at "^\\s-*$")
3771 (bobp)))
3772 (save-excursion
3773 ;; succeeded by a blank line?
3774 (allout-end-of-current-subtree)
3775 (looking-at "\n\n")))
3776 (and (= ref-depth 1)
3777 (or before
3778 (= depth 1)
3779 (save-excursion
3780 ;; Don't already have following
3781 ;; vertical padding:
3782 (not (allout-pre-next-prefix)))))))
3784 ;; Position to prior heading, if inserting backwards, and not
3785 ;; going outwards:
3786 (if (and before (>= relative-depth 0))
3787 (progn (allout-back-to-current-heading)
3788 (setq doing-beginning (bobp))
3789 (if (not (bobp))
3790 (allout-previous-heading)))
3791 (if (and before (bobp))
3792 (open-line 1)))
3794 (if (<= relative-depth 0)
3795 ;; Not going inwards, don't snug up:
3796 (if doing-beginning
3797 (if (not dbl-space)
3798 (open-line 1)
3799 (open-line 2))
3800 (if before
3801 (progn (end-of-line)
3802 (allout-pre-next-prefix)
3803 (while (and (= ?\n (following-char))
3804 (save-excursion
3805 (forward-char 1)
3806 (allout-hidden-p)))
3807 (forward-char 1))
3808 (if (not (looking-at "^$"))
3809 (open-line 1)))
3810 (allout-end-of-current-subtree)
3811 (if (looking-at "\n\n") (forward-char 1))))
3812 ;; Going inwards -- double-space if first offspring is
3813 ;; double-spaced, otherwise snug up.
3814 (allout-end-of-entry)
3815 (if (eobp)
3816 (newline 1)
3817 (line-move 1))
3818 (allout-beginning-of-current-line)
3819 (backward-char 1)
3820 (if (bolp)
3821 ;; Blank lines between current header body and next
3822 ;; header -- get to last substantive (non-white-space)
3823 ;; line in body:
3824 (progn (setq dbl-space t)
3825 (re-search-backward "[^ \t\n]" nil t)))
3826 (if (looking-at "\n\n")
3827 (setq dbl-space t))
3828 (if (save-excursion
3829 (allout-next-heading)
3830 (when (> allout-recent-depth ref-depth)
3831 ;; This is an offspring.
3832 (forward-line -1)
3833 (looking-at "^\\s-*$")))
3834 (progn (forward-line 1)
3835 (open-line 1)
3836 (forward-line 1)))
3837 (allout-end-of-current-line))
3839 ;;(if doing-beginning (goto-char doing-beginning))
3840 (if (not (bobp))
3841 ;; We insert a newline char rather than using open-line to
3842 ;; avoid rear-stickiness inheritance of read-only property.
3843 (progn (if (and (not (> depth ref-depth))
3844 (not before))
3845 (open-line 1)
3846 (if (and (not dbl-space) (> depth ref-depth))
3847 (newline 1)
3848 (if dbl-space
3849 (open-line 1)
3850 (if (not before)
3851 (newline 1)))))
3852 (if (and dbl-space (not (> relative-depth 0)))
3853 (newline 1))
3854 (if (and (not (eobp))
3855 (or (not (bolp))
3856 (and (not (bobp))
3857 ;; bolp doesn't detect concealed
3858 ;; trailing newlines, compensate:
3859 (save-excursion
3860 (forward-char -1)
3861 (allout-hidden-p)))))
3862 (forward-char 1))))
3864 (setq start (point))
3865 (insert (concat (allout-make-topic-prefix opening-numbered t depth)
3866 " "))
3867 (setq end (1+ (point)))
3869 (allout-rebullet-heading (and offer-recent-bullet ref-bullet)
3870 depth nil nil t)
3871 (if (> relative-depth 0)
3872 (save-excursion (goto-char ref-topic)
3873 (allout-show-children)))
3874 (end-of-line)
3876 (run-hook-with-args 'allout-structure-added-functions start end)
3880 ;;;_ > allout-open-subtopic (arg)
3881 (defun allout-open-subtopic (arg)
3882 "Open new topic header at deeper level than the current one.
3884 Negative universal ARG means to open deeper, but place the new topic
3885 prior to the current one."
3886 (interactive "p")
3887 (allout-open-topic 1 (> 0 arg) (< 1 arg)))
3888 ;;;_ > allout-open-sibtopic (arg)
3889 (defun allout-open-sibtopic (arg)
3890 "Open new topic header at same level as the current one.
3892 Positive universal ARG means to use the bullet of the prior sibling.
3894 Negative universal ARG means to place the new topic prior to the current
3895 one."
3896 (interactive "p")
3897 (allout-open-topic 0 (> 0 arg) (not (= 1 arg))))
3898 ;;;_ > allout-open-supertopic (arg)
3899 (defun allout-open-supertopic (arg)
3900 "Open new topic header at shallower level than the current one.
3902 Negative universal ARG means to open shallower, but place the new
3903 topic prior to the current one."
3905 (interactive "p")
3906 (allout-open-topic -1 (> 0 arg) (< 1 arg)))
3908 ;;;_ - Outline Alteration
3909 ;;;_ : Topic Modification
3910 ;;;_ = allout-former-auto-filler
3911 (defvar allout-former-auto-filler nil
3912 "Name of modal fill function being wrapped by `allout-auto-fill'.")
3913 ;;;_ > allout-auto-fill ()
3914 (defun allout-auto-fill ()
3915 "`allout-mode' autofill function.
3917 Maintains outline hanging topic indentation if
3918 `allout-use-hanging-indents' is set."
3920 (when (and (not allout-inhibit-auto-fill)
3921 (or (not allout-inhibit-auto-fill-on-headline)
3922 (not (allout-on-current-heading-p))))
3923 (let ((fill-prefix (if allout-use-hanging-indents
3924 ;; Check for topic header indentation:
3925 (save-match-data
3926 (save-excursion
3927 (beginning-of-line)
3928 (if (looking-at allout-regexp)
3929 ;; ... construct indentation to account for
3930 ;; length of topic prefix:
3931 (make-string (progn (allout-end-of-prefix)
3932 (current-column))
3933 ?\ ))))))
3934 (use-auto-fill-function
3935 (if (and (eq allout-outside-normal-auto-fill-function
3936 'allout-auto-fill)
3937 (eq auto-fill-function 'allout-auto-fill))
3938 'do-auto-fill
3939 (or allout-outside-normal-auto-fill-function
3940 auto-fill-function))))
3941 (if (or allout-former-auto-filler allout-use-hanging-indents)
3942 (funcall use-auto-fill-function)))))
3943 ;;;_ > allout-reindent-body (old-depth new-depth &optional number)
3944 (defun allout-reindent-body (old-depth new-depth &optional number)
3945 "Reindent body lines which were indented at OLD-DEPTH to NEW-DEPTH.
3947 Optional arg NUMBER indicates numbering is being added, and it must
3948 be accommodated.
3950 Note that refill of indented paragraphs is not done."
3952 (save-excursion
3953 (allout-end-of-prefix)
3954 (let* ((new-margin (current-column))
3955 excess old-indent-begin old-indent-end
3956 ;; We want the column where the header-prefix text started
3957 ;; *before* the prefix was changed, so we infer it relative
3958 ;; to the new margin and the shift in depth:
3959 (old-margin (+ old-depth (- new-margin new-depth))))
3961 ;; Process lines up to (but excluding) next topic header:
3962 (allout-unprotected
3963 (save-match-data
3964 (while
3965 (and (re-search-forward "\n\\(\\s-*\\)"
3968 ;; Register the indent data, before we reset the
3969 ;; match data with a subsequent `looking-at':
3970 (setq old-indent-begin (match-beginning 1)
3971 old-indent-end (match-end 1))
3972 (not (looking-at allout-regexp)))
3973 (if (> 0 (setq excess (- (- old-indent-end old-indent-begin)
3974 old-margin)))
3975 ;; Text starts left of old margin -- don't adjust:
3977 ;; Text was hanging at or right of old left margin --
3978 ;; reindent it, preserving its existing indentation
3979 ;; beyond the old margin:
3980 (delete-region old-indent-begin old-indent-end)
3981 (indent-to (+ new-margin excess (current-column))))))))))
3982 ;;;_ > allout-rebullet-current-heading (arg)
3983 (defun allout-rebullet-current-heading (arg)
3984 "Solicit new bullet for current visible heading."
3985 (interactive "p")
3986 (let ((initial-col (current-column))
3987 (on-bullet (eq (point)(allout-current-bullet-pos)))
3988 from to
3989 (backwards (if (< arg 0)
3990 (setq arg (* arg -1)))))
3991 (while (> arg 0)
3992 (save-excursion (allout-back-to-current-heading)
3993 (allout-end-of-prefix)
3994 (setq from allout-recent-prefix-beginning
3995 to allout-recent-prefix-end)
3996 (allout-rebullet-heading t ;;; instead
3997 nil ;;; depth
3998 nil ;;; number-control
3999 nil ;;; index
4000 t) ;;; do-successors
4001 (run-hook-with-args 'allout-exposure-change-functions
4002 from to t))
4003 (setq arg (1- arg))
4004 (if (<= arg 0)
4006 (setq initial-col nil) ; Override positioning back to init col
4007 (if (not backwards)
4008 (allout-next-visible-heading 1)
4009 (allout-goto-prefix-doublechecked)
4010 (allout-next-visible-heading -1))))
4011 (message "Done.")
4012 (cond (on-bullet (goto-char (allout-current-bullet-pos)))
4013 (initial-col (move-to-column initial-col)))))
4014 ;;;_ > allout-rebullet-heading (&optional instead ...)
4015 (defun allout-rebullet-heading (&optional instead
4016 new-depth
4017 number-control
4018 index
4019 do-successors)
4021 "Adjust bullet of current topic prefix.
4023 All args are optional.
4025 If INSTEAD is:
4026 - nil, then the bullet char for the context is used, per distinction or depth
4027 - a (numeric) character, then character's string representation is used
4028 - a string, then the user is asked for bullet with the first char as default
4029 - anything else, the user is solicited with bullet char per context as default
4031 Second arg DEPTH forces the topic prefix to that depth, regardless
4032 of the topic's current depth.
4034 Third arg NUMBER-CONTROL can force the prefix to or away from
4035 numbered form. It has effect only if `allout-numbered-bullet' is
4036 non-nil and soliciting was not explicitly invoked (via first arg).
4037 Its effect, numbering or denumbering, then depends on the setting
4038 of the fourth arg, INDEX.
4040 If NUMBER-CONTROL is non-nil and fourth arg INDEX is nil, then the
4041 prefix of the topic is forced to be non-numbered. Null index and
4042 non-nil NUMBER-CONTROL forces denumbering. Non-nil INDEX (and
4043 non-nil NUMBER-CONTROL) forces a numbered-prefix form. If non-nil
4044 INDEX is a number, then that number is used for the numbered
4045 prefix. Non-nil and non-number means that the index for the
4046 numbered prefix will be derived by allout-make-topic-prefix.
4048 Fifth arg DO-SUCCESSORS t means re-resolve count on succeeding
4049 siblings.
4051 Cf vars `allout-stylish-prefixes', `allout-old-style-prefixes',
4052 and `allout-numbered-bullet', which all affect the behavior of
4053 this function."
4055 (let* ((current-depth (allout-depth))
4056 (new-depth (or new-depth current-depth))
4057 (mb allout-recent-prefix-beginning)
4058 (me allout-recent-prefix-end)
4059 (current-bullet (buffer-substring-no-properties (- me 1) me))
4060 (has-annotation (get-text-property mb 'allout-was-hidden))
4061 (new-prefix (allout-make-topic-prefix current-bullet
4063 new-depth
4064 instead
4065 number-control
4066 index)))
4068 ;; Is new one identical to old?
4069 (if (and (= current-depth new-depth)
4070 (string= current-bullet
4071 (substring new-prefix (1- (length new-prefix)))))
4072 ;; Nothing to do:
4075 ;; New prefix probably different from old:
4076 ; get rid of old one:
4077 (allout-unprotected (delete-region mb me))
4078 (goto-char mb)
4079 ; Dispense with number if
4080 ; numbered-bullet prefix:
4081 (save-match-data
4082 (if (and allout-numbered-bullet
4083 (string= allout-numbered-bullet current-bullet)
4084 (looking-at "[0-9]+"))
4085 (allout-unprotected
4086 (delete-region (match-beginning 0)(match-end 0)))))
4088 ;; convey 'allout-was-hidden annotation, if original had it:
4089 (if has-annotation
4090 (put-text-property 0 (length new-prefix) 'allout-was-hidden t
4091 new-prefix))
4093 ; Put in new prefix:
4094 (allout-unprotected (insert new-prefix))
4096 ;; Reindent the body if elected, margin changed, and not encrypted body:
4097 (if (and allout-reindent-bodies
4098 (not (= new-depth current-depth))
4099 (not (allout-encrypted-topic-p)))
4100 (allout-reindent-body current-depth new-depth))
4102 (run-hook-with-args 'allout-exposure-change-functions mb me nil)
4104 ;; Recursively rectify successive siblings of orig topic if
4105 ;; caller elected for it:
4106 (if do-successors
4107 (save-excursion
4108 (while (allout-next-sibling new-depth nil)
4109 (setq index
4110 (cond ((numberp index) (1+ index))
4111 ((not number-control) (allout-sibling-index))))
4112 (if (allout-numbered-type-prefix)
4113 (allout-rebullet-heading nil ;;; instead
4114 new-depth ;;; new-depth
4115 number-control;;; number-control
4116 index ;;; index
4117 nil))))) ;;;(dont!)do-successors
4118 ) ; (if (and (= current-depth new-depth)...))
4119 ) ; let* ((current-depth (allout-depth))...)
4120 ) ; defun
4121 ;;;_ > allout-rebullet-topic (arg)
4122 (defun allout-rebullet-topic (arg &optional sans-offspring)
4123 "Rebullet the visible topic containing point and all contained subtopics.
4125 Descends into invisible as well as visible topics, however.
4127 When optional SANS-OFFSPRING is non-nil, subtopics are not
4128 shifted. (Shifting a topic outwards without shifting its
4129 offspring is disallowed, since this would create a \"containment
4130 discontinuity\", where the depth difference between a topic and
4131 its immediate offspring is greater than one.)
4133 With repeat count, shift topic depth by that amount."
4134 (interactive "P")
4135 (let ((start-col (current-column)))
4136 (save-excursion
4137 ;; Normalize arg:
4138 (cond ((null arg) (setq arg 0))
4139 ((listp arg) (setq arg (car arg))))
4140 ;; Fill the user in, in case we're shifting a big topic:
4141 (if (not (zerop arg)) (message "Shifting..."))
4142 (allout-back-to-current-heading)
4143 (if (<= (+ allout-recent-depth arg) 0)
4144 (error "Attempt to shift topic below level 1"))
4145 (allout-rebullet-topic-grunt arg nil nil nil nil sans-offspring)
4146 (if (not (zerop arg)) (message "Shifting... done.")))
4147 (move-to-column (max 0 (+ start-col arg)))))
4148 ;;;_ > allout-rebullet-topic-grunt (&optional relative-depth ...)
4149 (defun allout-rebullet-topic-grunt (&optional relative-depth
4150 starting-depth
4151 starting-point
4152 index
4153 do-successors
4154 sans-offspring)
4155 "Like `allout-rebullet-topic', but on nearest containing topic
4156 \(visible or not).
4158 See `allout-rebullet-heading' for rebulleting behavior.
4160 All arguments are optional.
4162 First arg RELATIVE-DEPTH means to shift the depth of the entire
4163 topic that amount.
4165 Several subsequent args are for internal recursive use by the function
4166 itself: STARTING-DEPTH, STARTING-POINT, and INDEX.
4168 Finally, if optional SANS-OFFSPRING is non-nil then the offspring
4169 are not shifted. (Shifting a topic outwards without shifting
4170 its offspring is disallowed, since this would create a
4171 \"containment discontinuity\", where the depth difference between
4172 a topic and its immediate offspring is greater than one.)"
4174 ;; XXX the recursion here is peculiar, and in general the routine may
4175 ;; need simplification with refactoring.
4177 (if (and sans-offspring
4178 relative-depth
4179 (< relative-depth 0))
4180 (error (concat "Attempt to shift topic outwards without offspring,"
4181 " would cause containment discontinuity.")))
4183 (let* ((relative-depth (or relative-depth 0))
4184 (new-depth (allout-depth))
4185 (starting-depth (or starting-depth new-depth))
4186 (on-starting-call (null starting-point))
4187 (index (or index
4188 ;; Leave index null on starting call, so rebullet-heading
4189 ;; calculates it at what might be new depth:
4190 (and (or (zerop relative-depth)
4191 (not on-starting-call))
4192 (allout-sibling-index))))
4193 (starting-index index)
4194 (moving-outwards (< 0 relative-depth))
4195 (starting-point (or starting-point (point)))
4196 (local-point (point)))
4198 ;; Sanity check for excessive promotion done only on starting call:
4199 (and on-starting-call
4200 moving-outwards
4201 (> 0 (+ starting-depth relative-depth))
4202 (error "Attempt to shift topic out beyond level 1"))
4204 (cond ((= starting-depth new-depth)
4205 ;; We're at depth to work on this one.
4207 ;; When shifting out we work on the children before working on
4208 ;; the parent to avoid interim `allout-aberrant-container-p'
4209 ;; aberrancy, and vice-versa when shifting in:
4210 (if (>= relative-depth 0)
4211 (allout-rebullet-heading nil
4212 (+ starting-depth relative-depth)
4213 nil ;;; number
4214 index
4215 nil)) ;;; do-successors
4216 (when (not sans-offspring)
4217 ;; ... and work on subsequent ones which are at greater depth:
4218 (setq index 0)
4219 (allout-next-heading)
4220 (while (and (not (eobp))
4221 (< starting-depth (allout-depth)))
4222 (setq index (1+ index))
4223 (allout-rebullet-topic-grunt relative-depth
4224 (1+ starting-depth)
4225 starting-point
4226 index)))
4227 (when (< relative-depth 0)
4228 (save-excursion
4229 (goto-char local-point)
4230 (allout-rebullet-heading nil ;;; instead
4231 (+ starting-depth relative-depth)
4232 nil ;;; number
4233 starting-index
4234 nil)))) ;;; do-successors
4236 ((< starting-depth new-depth)
4237 ;; Rare case -- subtopic more than one level deeper than parent.
4238 ;; Treat this one at an even deeper level:
4239 (allout-rebullet-topic-grunt relative-depth
4240 new-depth
4241 starting-point
4242 index
4243 sans-offspring)))
4245 (if on-starting-call
4246 (progn
4247 ;; Rectify numbering of former siblings of the adjusted topic,
4248 ;; if topic has changed depth
4249 (if (or do-successors
4250 (and (not (zerop relative-depth))
4251 (or (= allout-recent-depth starting-depth)
4252 (= allout-recent-depth (+ starting-depth
4253 relative-depth)))))
4254 (allout-rebullet-heading nil nil nil nil t))
4255 ;; Now rectify numbering of new siblings of the adjusted topic,
4256 ;; if depth has been changed:
4257 (progn (goto-char starting-point)
4258 (if (not (zerop relative-depth))
4259 (allout-rebullet-heading nil nil nil nil t)))))
4262 ;;;_ > allout-renumber-to-depth (&optional depth)
4263 (defun allout-renumber-to-depth (&optional depth)
4264 "Renumber siblings at current depth.
4266 Affects superior topics if optional arg DEPTH is less than current depth.
4268 Returns final depth."
4270 ;; Proceed by level, processing subsequent siblings on each,
4271 ;; ascending until we get shallower than the start depth:
4273 (let ((ascender (allout-depth))
4274 was-eobp)
4275 (while (and (not (eobp))
4276 (allout-depth)
4277 (>= allout-recent-depth depth)
4278 (>= ascender depth))
4279 ; Skip over all topics at
4280 ; lesser depths, which can not
4281 ; have been disturbed:
4282 (while (and (not (setq was-eobp (eobp)))
4283 (> allout-recent-depth ascender))
4284 (allout-next-heading))
4285 ; Prime ascender for ascension:
4286 (setq ascender (1- allout-recent-depth))
4287 (if (>= allout-recent-depth depth)
4288 (allout-rebullet-heading nil ;;; instead
4289 nil ;;; depth
4290 nil ;;; number-control
4291 nil ;;; index
4292 t)) ;;; do-successors
4293 (if was-eobp (goto-char (point-max)))))
4294 allout-recent-depth)
4295 ;;;_ > allout-number-siblings (&optional denumber)
4296 (defun allout-number-siblings (&optional denumber)
4297 "Assign numbered topic prefix to this topic and its siblings.
4299 With universal argument, denumber -- assign default bullet to this
4300 topic and its siblings.
4302 With repeated universal argument (`^U^U'), solicit bullet for each
4303 rebulleting each topic at this level."
4305 (interactive "P")
4307 (save-excursion
4308 (allout-back-to-current-heading)
4309 (allout-beginning-of-level)
4310 (let ((depth allout-recent-depth)
4311 (index (if (not denumber) 1))
4312 (use-bullet (equal '(16) denumber))
4313 (more t))
4314 (while more
4315 (allout-rebullet-heading use-bullet ;;; instead
4316 depth ;;; depth
4317 t ;;; number-control
4318 index ;;; index
4319 nil) ;;; do-successors
4320 (if index (setq index (1+ index)))
4321 (setq more (allout-next-sibling depth nil))))))
4322 ;;;_ > allout-shift-in (arg)
4323 (defun allout-shift-in (arg)
4324 "Increase depth of current heading and any items collapsed within it.
4326 With a negative argument, the item is shifted out using
4327 `allout-shift-out', instead.
4329 With an argument greater than one, shift-in the item but not its
4330 offspring, making the item into a sibling of its former children,
4331 and a child of sibling that formerly preceded it.
4333 You are not allowed to shift the first offspring of a topic
4334 inwards, because that would yield a \"containment
4335 discontinuity\", where the depth difference between a topic and
4336 its immediate offspring is greater than one. The first topic in
4337 the file can be adjusted to any positive depth, however."
4339 (interactive "p")
4340 (if (< arg 0)
4341 (allout-shift-out (* arg -1))
4342 ;; refuse to create a containment discontinuity:
4343 (save-excursion
4344 (allout-back-to-current-heading)
4345 (if (not (bobp))
4346 (let* ((current-depth allout-recent-depth)
4347 (start-point (point))
4348 (predecessor-depth (progn
4349 (forward-char -1)
4350 (allout-goto-prefix-doublechecked)
4351 (if (< (point) start-point)
4352 allout-recent-depth
4353 0))))
4354 (if (and (> predecessor-depth 0)
4355 (> (1+ current-depth)
4356 (1+ predecessor-depth)))
4357 (error (concat "Disallowed shift deeper than"
4358 " containing topic's children."))
4359 (allout-back-to-current-heading)
4360 (if (< allout-recent-depth (1+ current-depth))
4361 (allout-show-children))))))
4362 (let ((where (point)))
4363 (allout-rebullet-topic 1 (and (> arg 1) 'sans-offspring))
4364 (run-hook-with-args 'allout-structure-shifted-functions arg where))))
4365 ;;;_ > allout-shift-out (arg)
4366 (defun allout-shift-out (arg)
4367 "Decrease depth of current heading and any topics collapsed within it.
4368 This will make the item a sibling of its former container.
4370 With a negative argument, the item is shifted in using
4371 `allout-shift-in', instead.
4373 With an argument greater than one, shift-out the item's offspring
4374 but not the item itself, making the former children siblings of
4375 the item.
4377 With an argument greater than 1, the item's offspring are shifted
4378 out without shifting the item. This will make the immediate
4379 subtopics into siblings of the item."
4380 (interactive "p")
4381 (if (< arg 0)
4382 (allout-shift-in (* arg -1))
4383 ;; Get proper exposure in this area:
4384 (save-excursion (if (allout-ascend)
4385 (allout-show-children)))
4386 ;; Show collapsed children if there's a successor which will become
4387 ;; their sibling:
4388 (if (and (allout-current-topic-collapsed-p)
4389 (save-excursion (allout-next-sibling)))
4390 (allout-show-children))
4391 (let ((where (and (allout-depth) allout-recent-prefix-beginning)))
4392 (save-excursion
4393 (if (> arg 1)
4394 ;; Shift the offspring but not the topic:
4395 (let ((children-chart (allout-chart-subtree 1)))
4396 (if (listp (car children-chart))
4397 ;; whoops:
4398 (setq children-chart (allout-flatten children-chart)))
4399 (save-excursion
4400 (dolist (child-point children-chart)
4401 (goto-char child-point)
4402 (allout-shift-out 1))))
4403 (allout-rebullet-topic (* arg -1))))
4404 (run-hook-with-args 'allout-structure-shifted-functions (* arg -1) where))))
4405 ;;;_ : Surgery (kill-ring) functions with special provisions for outlines:
4406 ;;;_ > allout-kill-line (&optional arg)
4407 (defun allout-kill-line (&optional arg)
4408 "Kill line, adjusting subsequent lines suitably for outline mode."
4410 (interactive "*P")
4412 (if (or (not (allout-mode-p))
4413 (not (bolp))
4414 (not (save-match-data (looking-at allout-regexp))))
4415 ;; Just do a regular kill:
4416 (kill-line arg)
4417 ;; Ah, have to watch out for adjustments:
4418 (let* ((beg (point))
4420 (beg-hidden (allout-hidden-p))
4421 (end-hidden (save-excursion (allout-end-of-current-line)
4422 (setq end (point))
4423 (allout-hidden-p)))
4424 (depth (allout-depth)))
4426 (allout-annotate-hidden beg end)
4427 (unwind-protect
4428 (if (and (not beg-hidden) (not end-hidden))
4429 (allout-unprotected (kill-line arg))
4430 (kill-line arg))
4431 (run-hooks 'allout-after-copy-or-kill-hook)
4432 (allout-deannotate-hidden beg end)
4434 (if allout-numbered-bullet
4435 (save-excursion ; Renumber subsequent topics if needed:
4436 (if (not (save-match-data (looking-at allout-regexp)))
4437 (allout-next-heading))
4438 (allout-renumber-to-depth depth)))
4439 (run-hook-with-args 'allout-structure-deleted-functions depth (point))))))
4440 ;;;_ > allout-copy-line-as-kill ()
4441 (defun allout-copy-line-as-kill ()
4442 "Like `allout-kill-topic', but save to kill ring instead of deleting."
4443 (interactive)
4444 (let ((buffer-read-only t))
4445 (condition-case nil
4446 (allout-kill-line)
4447 (buffer-read-only nil))))
4448 ;;;_ > allout-kill-topic ()
4449 (defun allout-kill-topic ()
4450 "Kill topic together with subtopics.
4452 Trailing whitespace is killed with a topic if that whitespace:
4454 - would separate the topic from a subsequent sibling
4455 - would separate the topic from the end of buffer
4456 - would not be added to whitespace already separating the topic from the
4457 previous one.
4459 Topic exposure is marked with text-properties, to be used by
4460 `allout-yank-processing' for exposure recovery."
4462 (interactive)
4463 (let* ((inhibit-field-text-motion t)
4464 (beg (prog1 (allout-back-to-current-heading) (beginning-of-line)))
4466 (depth allout-recent-depth))
4467 (allout-end-of-current-subtree)
4468 (if (and (/= (current-column) 0) (not (eobp)))
4469 (forward-char 1))
4470 (if (not (eobp))
4471 (if (and (save-match-data (looking-at "\n"))
4472 (or (save-excursion
4473 (or (not (allout-next-heading))
4474 (= depth allout-recent-depth)))
4475 (and (> (- beg (point-min)) 3)
4476 (string= (buffer-substring (- beg 2) beg) "\n\n"))))
4477 (forward-char 1)))
4479 (allout-annotate-hidden beg (setq end (point)))
4480 (unwind-protect ; for possible barf-if-buffer-read-only.
4481 (allout-unprotected (kill-region beg end))
4482 (allout-deannotate-hidden beg end)
4483 (run-hooks 'allout-after-copy-or-kill-hook)
4485 (save-excursion
4486 (allout-renumber-to-depth depth))
4487 (run-hook-with-args 'allout-structure-deleted-functions depth (point)))))
4488 ;;;_ > allout-copy-topic-as-kill ()
4489 (defun allout-copy-topic-as-kill ()
4490 "Like `allout-kill-topic', but save to kill ring instead of deleting."
4491 (interactive)
4492 (let ((buffer-read-only t))
4493 (condition-case nil
4494 (allout-kill-topic)
4495 (buffer-read-only (message "Topic copied...")))))
4496 ;;;_ > allout-annotate-hidden (begin end)
4497 (defun allout-annotate-hidden (begin end)
4498 "Qualify text with properties to indicate exposure status."
4500 (let ((was-modified (buffer-modified-p))
4501 (buffer-read-only nil))
4502 (allout-deannotate-hidden begin end)
4503 (save-excursion
4504 (goto-char begin)
4505 (let (done next prev overlay)
4506 (while (not done)
4507 ;; at or advance to start of next hidden region:
4508 (if (not (allout-hidden-p))
4509 (setq next
4510 (max (1+ (point))
4511 (allout-next-single-char-property-change (point)
4512 'invisible
4513 nil end))))
4514 (if (or (not next) (eq prev next))
4515 ;; still not at start of hidden area -- must not be any left.
4516 (setq done t)
4517 (goto-char next)
4518 (setq prev next)
4519 (if (not (allout-hidden-p))
4520 ;; still not at start of hidden area.
4521 (setq done t)
4522 (setq overlay (allout-get-invisibility-overlay))
4523 (setq next (overlay-end overlay)
4524 prev next)
4525 ;; advance to end of this hidden area:
4526 (when next
4527 (goto-char next)
4528 (allout-unprotected
4529 (let ((buffer-undo-list t))
4530 (put-text-property (overlay-start overlay) next
4531 'allout-was-hidden t)))))))))
4532 (set-buffer-modified-p was-modified)))
4533 ;;;_ > allout-deannotate-hidden (begin end)
4534 (defun allout-deannotate-hidden (begin end)
4535 "Remove allout hidden-text annotation between BEGIN and END."
4537 (allout-unprotected
4538 (let ((inhibit-read-only t)
4539 (buffer-undo-list t))
4540 (remove-text-properties begin (min end (point-max))
4541 '(allout-was-hidden t)))))
4542 ;;;_ > allout-hide-by-annotation (begin end)
4543 (defun allout-hide-by-annotation (begin end)
4544 "Translate text properties indicating exposure status into actual exposure."
4545 (save-excursion
4546 (goto-char begin)
4547 (let ((was-modified (buffer-modified-p))
4548 done next prev)
4549 (while (not done)
4550 ;; at or advance to start of next annotation:
4551 (if (not (get-text-property (point) 'allout-was-hidden))
4552 (setq next (allout-next-single-char-property-change
4553 (point) 'allout-was-hidden nil end)))
4554 (if (or (not next) (eq prev next))
4555 ;; no more or not advancing -- must not be any left.
4556 (setq done t)
4557 (goto-char next)
4558 (setq prev next)
4559 (if (not (get-text-property (point) 'allout-was-hidden))
4560 ;; still not at start of annotation.
4561 (setq done t)
4562 ;; advance to just after end of this annotation:
4563 (setq next (allout-next-single-char-property-change
4564 (point) 'allout-was-hidden nil end))
4565 (let ((o (make-overlay prev next nil 'front-advance)))
4566 (overlay-put o 'category 'allout-exposure-category)
4567 (overlay-put o 'evaporate t))
4568 (allout-deannotate-hidden prev next)
4569 (setq prev next)
4570 (if next (goto-char next)))))
4571 (set-buffer-modified-p was-modified))))
4572 ;;;_ > allout-yank-processing ()
4573 (defun allout-yank-processing (&optional arg)
4575 "Incidental allout-specific business to be done just after text yanks.
4577 Does depth adjustment of yanked topics, when:
4579 1 the stuff being yanked starts with a valid outline header prefix, and
4580 2 it is being yanked at the end of a line which consists of only a valid
4581 topic prefix.
4583 Also, adjusts numbering of subsequent siblings when appropriate.
4585 Depth adjustment alters the depth of all the topics being yanked
4586 the amount it takes to make the first topic have the depth of the
4587 header into which it's being yanked.
4589 The point is left in front of yanked, adjusted topics, rather than
4590 at the end (and vice-versa with the mark). Non-adjusted yanks,
4591 however, are left exactly like normal, non-allout-specific yanks."
4593 (interactive "*P")
4594 ; Get to beginning, leaving
4595 ; region around subject:
4596 (if (< (allout-mark-marker t) (point))
4597 (exchange-point-and-mark))
4598 (save-match-data
4599 (let* ((subj-beg (point))
4600 (into-bol (bolp))
4601 (subj-end (allout-mark-marker t))
4602 ;; 'resituate' if yanking an entire topic into topic header:
4603 (resituate (and (let ((allout-inhibit-aberrance-doublecheck t))
4604 (allout-e-o-prefix-p))
4605 (looking-at allout-regexp)
4606 (allout-prefix-data)))
4607 ;; `rectify-numbering' if resituating (where several topics may
4608 ;; be resituating) or yanking a topic into a topic slot (bol):
4609 (rectify-numbering (or resituate
4610 (and into-bol (looking-at allout-regexp)))))
4611 (if resituate
4612 ;; Yanking a topic into the start of a topic -- reconcile to fit:
4613 (let* ((inhibit-field-text-motion t)
4614 (prefix-len (if (not (match-end 1))
4616 (- (match-end 1) subj-beg)))
4617 (subj-depth allout-recent-depth)
4618 (prefix-bullet (allout-recent-bullet))
4619 (adjust-to-depth
4620 ;; Nil if adjustment unnecessary, otherwise depth to which
4621 ;; adjustment should be made:
4622 (save-excursion
4623 (and (goto-char subj-end)
4624 (eolp)
4625 (goto-char subj-beg)
4626 (and (looking-at allout-regexp)
4627 (progn
4628 (beginning-of-line)
4629 (not (= (point) subj-beg)))
4630 (looking-at allout-regexp)
4631 (allout-prefix-data))
4632 allout-recent-depth)))
4633 (more t))
4634 (setq rectify-numbering allout-numbered-bullet)
4635 (if adjust-to-depth
4636 ; Do the adjustment:
4637 (progn
4638 (save-restriction
4639 (narrow-to-region subj-beg subj-end)
4640 ; Trim off excessive blank
4641 ; line at end, if any:
4642 (goto-char (point-max))
4643 (if (looking-at "^$")
4644 (allout-unprotected (delete-char -1)))
4645 ; Work backwards, with each
4646 ; shallowest level,
4647 ; successively excluding the
4648 ; last processed topic from
4649 ; the narrow region:
4650 (while more
4651 (allout-back-to-current-heading)
4652 ; go as high as we can in each bunch:
4653 (while (allout-ascend t))
4654 (save-excursion
4655 (allout-unprotected
4656 (allout-rebullet-topic-grunt (- adjust-to-depth
4657 subj-depth)))
4658 (allout-depth))
4659 (if (setq more (not (bobp)))
4660 (progn (widen)
4661 (forward-char -1)
4662 (narrow-to-region subj-beg (point))))))
4663 ;; Remove new heading prefix:
4664 (allout-unprotected
4665 (progn
4666 (delete-region (point) (+ (point)
4667 prefix-len
4668 (- adjust-to-depth
4669 subj-depth)))
4670 ; and delete residual subj
4671 ; prefix digits and space:
4672 (while (looking-at "[0-9]") (delete-char 1))
4673 (delete-char -1)
4674 (if (not (eolp))
4675 (forward-char))))
4676 ;; Assert new topic's bullet - minimal effort if unchanged:
4677 (allout-rebullet-heading (string-to-char prefix-bullet)))
4678 (exchange-point-and-mark))))
4679 (if rectify-numbering
4680 (progn
4681 (save-excursion
4682 ; Give some preliminary feedback:
4683 (message "... reconciling numbers")
4684 ; ... and renumber, in case necessary:
4685 (goto-char subj-beg)
4686 (if (allout-goto-prefix-doublechecked)
4687 (allout-unprotected
4688 (allout-rebullet-heading nil ;;; instead
4689 (allout-depth) ;;; depth
4690 nil ;;; number-control
4691 nil ;;; index
4692 t)))
4693 (message ""))))
4694 (if (or into-bol resituate)
4695 (allout-hide-by-annotation (point) (allout-mark-marker t))
4696 (allout-deannotate-hidden (allout-mark-marker t) (point)))
4697 (if (not resituate)
4698 (exchange-point-and-mark))
4699 (run-hook-with-args 'allout-structure-added-functions subj-beg subj-end))))
4700 ;;;_ > allout-yank (&optional arg)
4701 (defun allout-yank (&optional arg)
4702 "`allout-mode' yank, with depth and numbering adjustment of yanked topics.
4704 Non-topic yanks work no differently than normal yanks.
4706 If a topic is being yanked into a bare topic prefix, the depth of the
4707 yanked topic is adjusted to the depth of the topic prefix.
4709 1 we're yanking in an `allout-mode' buffer
4710 2 the stuff being yanked starts with a valid outline header prefix, and
4711 3 it is being yanked at the end of a line which consists of only a valid
4712 topic prefix.
4714 If these conditions hold then the depth of the yanked topics are all
4715 adjusted the amount it takes to make the first one at the depth of the
4716 header into which it's being yanked.
4718 The point is left in front of yanked, adjusted topics, rather than
4719 at the end (and vice-versa with the mark). Non-adjusted yanks,
4720 however, (ones that don't qualify for adjustment) are handled
4721 exactly like normal yanks.
4723 Numbering of yanked topics, and the successive siblings at the depth
4724 into which they're being yanked, is adjusted.
4726 `allout-yank-pop' works with `allout-yank' just like normal `yank-pop'
4727 works with normal `yank' in non-outline buffers."
4729 (interactive "*P")
4730 (setq this-command 'yank)
4731 (allout-unprotected
4732 (yank arg))
4733 (if (allout-mode-p)
4734 (allout-yank-processing)))
4735 ;;;_ > allout-yank-pop (&optional arg)
4736 (defun allout-yank-pop (&optional arg)
4737 "Yank-pop like `allout-yank' when popping to bare outline prefixes.
4739 Adapts level of popped topics to level of fresh prefix.
4741 Note -- prefix changes to distinctive bullets will stick, if followed
4742 by pops to non-distinctive yanks. Bug..."
4744 (interactive "*p")
4745 (setq this-command 'yank)
4746 (yank-pop arg)
4747 (if (allout-mode-p)
4748 (allout-yank-processing)))
4750 ;;;_ - Specialty bullet functions
4751 ;;;_ : File Cross references
4752 ;;;_ > allout-resolve-xref ()
4753 (defun allout-resolve-xref ()
4754 "Pop to file associated with current heading, if it has an xref bullet.
4756 \(Works according to setting of `allout-file-xref-bullet')."
4757 (interactive)
4758 (if (not allout-file-xref-bullet)
4759 (error
4760 "Outline cross references disabled -- no `allout-file-xref-bullet'")
4761 (if (not (string= (allout-current-bullet) allout-file-xref-bullet))
4762 (error "Current heading lacks cross-reference bullet `%s'"
4763 allout-file-xref-bullet)
4764 (let ((inhibit-field-text-motion t)
4765 file-name)
4766 (save-match-data
4767 (save-excursion
4768 (let* ((text-start allout-recent-prefix-end)
4769 (heading-end (point-at-eol)))
4770 (goto-char text-start)
4771 (setq file-name
4772 (if (re-search-forward "\\s-\\(\\S-*\\)" heading-end t)
4773 (buffer-substring (match-beginning 1)
4774 (match-end 1)))))))
4775 (setq file-name (expand-file-name file-name))
4776 (if (or (file-exists-p file-name)
4777 (if (file-writable-p file-name)
4778 (y-or-n-p (format "%s not there, create one? "
4779 file-name))
4780 (error "%s not found and can't be created" file-name)))
4781 (condition-case failure
4782 (find-file-other-window file-name)
4783 (error failure))
4784 (error "%s not found" file-name))
4790 ;;;_ #6 Exposure Control
4792 ;;;_ - Fundamental
4793 ;;;_ > allout-flag-region (from to flag)
4794 (defun allout-flag-region (from to flag)
4795 "Conceal text between FROM and TO if FLAG is non-nil, else reveal it.
4796 After the exposure changes are made, run the abnormal hook
4797 `allout-exposure-change-functions' with the same arguments as
4798 this function."
4800 ;; We use outline invisibility spec.
4801 (remove-overlays from to 'category 'allout-exposure-category)
4802 (when flag
4803 (let ((o (make-overlay from to nil 'front-advance)))
4804 (overlay-put o 'category 'allout-exposure-category)
4805 (overlay-put o 'evaporate t)
4806 (when (featurep 'xemacs)
4807 (let ((props (symbol-plist 'allout-exposure-category)))
4808 (while props
4809 (condition-case nil
4810 ;; as of 2008-02-27, xemacs lacks modification-hooks
4811 (overlay-put o (pop props) (pop props))
4812 (error nil))))))
4813 (setq allout-this-command-hid-text t))
4814 (run-hook-with-args 'allout-exposure-change-functions from to flag))
4815 ;;;_ > allout-flag-current-subtree (flag)
4816 (defun allout-flag-current-subtree (flag)
4817 "Conceal currently-visible topic's subtree if FLAG non-nil, else reveal it."
4819 (save-excursion
4820 (allout-back-to-current-heading)
4821 (let ((inhibit-field-text-motion t))
4822 (end-of-line))
4823 (allout-flag-region (point)
4824 ;; Exposing must not leave trailing blanks hidden,
4825 ;; but can leave them exposed when hiding, so we
4826 ;; can use flag's inverse as the
4827 ;; include-trailing-blank cue:
4828 (allout-end-of-current-subtree (not flag))
4829 flag)))
4831 ;;;_ - Topic-specific
4832 ;;;_ > allout-show-entry ()
4833 (defun allout-show-entry ()
4834 "Like `allout-show-current-entry', but reveals entries in hidden topics.
4836 This is a way to give restricted peek at a concealed locality without the
4837 expense of exposing its context, but can leave the outline with aberrant
4838 exposure. `allout-show-offshoot' should be used after the peek to rectify
4839 the exposure."
4841 (interactive)
4842 (save-excursion
4843 (let (beg end)
4844 (allout-goto-prefix-doublechecked)
4845 (setq beg (if (allout-hidden-p) (1- (point)) (point)))
4846 (setq end (allout-pre-next-prefix))
4847 (allout-flag-region beg end nil)
4848 (list beg end))))
4849 ;;;_ > allout-show-children (&optional level strict)
4850 (defun allout-show-children (&optional level strict)
4852 "If point is visible, show all direct subheadings of this heading.
4854 Otherwise, do `allout-show-to-offshoot', and then show subheadings.
4856 Optional LEVEL specifies how many levels below the current level
4857 should be shown, or all levels if t. Default is 1.
4859 Optional STRICT means don't resort to -show-to-offshoot, no matter
4860 what. This is basically so -show-to-offshoot, which is called by
4861 this function, can employ the pure offspring-revealing capabilities of
4864 Returns point at end of subtree that was opened, if any. (May get a
4865 point of non-opened subtree?)"
4867 (interactive "p")
4868 (let ((start-point (point)))
4869 (if (and (not strict)
4870 (allout-hidden-p))
4872 (progn (allout-show-to-offshoot) ; Point's concealed, open to
4873 ; expose it.
4874 ;; Then recurse, but with "strict" set so we don't
4875 ;; infinite regress:
4876 (allout-show-children level t))
4878 (save-excursion
4879 (allout-beginning-of-current-line)
4880 (save-restriction
4881 (let* (depth
4882 ;; translate the level spec for this routine to the ones
4883 ;; used by -chart-subtree and -chart-to-reveal:
4884 (chart-level (cond ((not level) 1)
4885 ((eq level t) nil)
4886 (t level)))
4887 (chart (allout-chart-subtree chart-level))
4888 (to-reveal (or (allout-chart-to-reveal chart chart-level)
4889 ;; interactive, show discontinuous children:
4890 (and chart
4891 (allout-called-interactively-p)
4892 (save-excursion
4893 (allout-back-to-current-heading)
4894 (setq depth (allout-current-depth))
4895 (and (allout-next-heading)
4896 (> allout-recent-depth
4897 (1+ depth))))
4898 (message
4899 "Discontinuous offspring; use `%s %s'%s."
4900 (substitute-command-keys
4901 "\\[universal-argument]")
4902 (substitute-command-keys
4903 "\\[allout-shift-out]")
4904 " to elevate them.")
4905 (allout-chart-to-reveal
4906 chart (- allout-recent-depth depth))))))
4907 (goto-char start-point)
4908 (when (and strict (allout-hidden-p))
4909 ;; Concealed root would already have been taken care of,
4910 ;; unless strict was set.
4911 (allout-flag-region (point) (allout-snug-back) nil)
4912 (when allout-show-bodies
4913 (goto-char (car to-reveal))
4914 (allout-show-current-entry)))
4915 (while to-reveal
4916 (goto-char (car to-reveal))
4917 (allout-flag-region (save-excursion (allout-snug-back) (point))
4918 (progn (search-forward "\n" nil t)
4919 (1- (point)))
4920 nil)
4921 (when allout-show-bodies
4922 (goto-char (car to-reveal))
4923 (allout-show-current-entry))
4924 (setq to-reveal (cdr to-reveal)))))))
4925 ;; Compensate for `save-excursion's maintenance of point
4926 ;; within invisible text:
4927 (goto-char start-point)))
4928 ;;;_ > allout-show-to-offshoot ()
4929 (defun allout-show-to-offshoot ()
4930 "Like `allout-show-entry', but reveals all concealed ancestors, as well.
4932 Useful for coherently exposing to a random point in a hidden region."
4933 (interactive)
4934 (save-excursion
4935 (let ((inhibit-field-text-motion t)
4936 (orig-pt (point))
4937 (orig-pref (allout-goto-prefix-doublechecked))
4938 (last-at (point))
4939 (bag-it 0))
4940 (while (or (> bag-it 1) (allout-hidden-p))
4941 (while (allout-hidden-p)
4942 (move-beginning-of-line 1)
4943 (if (allout-hidden-p) (forward-char -1)))
4944 (if (= last-at (setq last-at (point)))
4945 ;; Oops, we're not making any progress! Show the current topic
4946 ;; completely, and try one more time here, if we haven't already.
4947 (progn (beginning-of-line)
4948 (allout-show-current-subtree)
4949 (goto-char orig-pt)
4950 (setq bag-it (1+ bag-it))
4951 (if (> bag-it 1)
4952 (error "allout-show-to-offshoot: %s"
4953 "Stumped by aberrant nesting.")))
4954 (if (> bag-it 0) (setq bag-it 0))
4955 (allout-show-children)
4956 (goto-char orig-pref)))
4957 (goto-char orig-pt)))
4958 (if (allout-hidden-p)
4959 (allout-show-entry)))
4960 ;;;_ > allout-hide-current-entry ()
4961 (defun allout-hide-current-entry ()
4962 "Hide the body directly following this heading."
4963 (interactive)
4964 (allout-back-to-current-heading)
4965 (save-excursion
4966 (let ((inhibit-field-text-motion t))
4967 (end-of-line))
4968 (allout-flag-region (point)
4969 (progn (allout-end-of-entry) (point))
4970 t)))
4971 ;;;_ > allout-show-current-entry (&optional arg)
4972 (defun allout-show-current-entry (&optional arg)
4973 "Show body following current heading, or hide entry with universal argument."
4975 (interactive "P")
4976 (if arg
4977 (allout-hide-current-entry)
4978 (save-excursion (allout-show-to-offshoot))
4979 (save-excursion
4980 (allout-flag-region (point)
4981 (progn (allout-end-of-entry t) (point))
4982 nil)
4984 ;;;_ > allout-show-current-subtree (&optional arg)
4985 (defun allout-show-current-subtree (&optional arg)
4986 "Show everything within the current topic.
4987 With a repeat-count, expose this topic and its siblings."
4988 (interactive "P")
4989 (save-excursion
4990 (if (<= (allout-current-depth) 0)
4991 ;; Outside any topics -- try to get to the first:
4992 (if (not (allout-next-heading))
4993 (error "No topics")
4994 ;; got to first, outermost topic -- set to expose it and siblings:
4995 (message "Above outermost topic -- exposing all.")
4996 (allout-flag-region (point-min)(point-max) nil))
4997 (allout-beginning-of-current-line)
4998 (if (not arg)
4999 (allout-flag-current-subtree nil)
5000 (allout-beginning-of-level)
5001 (allout-expose-topic '(* :))))))
5002 ;;;_ > allout-current-topic-collapsed-p (&optional include-single-liners)
5003 (defun allout-current-topic-collapsed-p (&optional include-single-liners)
5004 "True if the currently visible containing topic is already collapsed.
5006 Single line topics intrinsically can be considered as being both
5007 collapsed and uncollapsed. If optional INCLUDE-SINGLE-LINERS is
5008 true, then single-line topics are considered to be collapsed. By
5009 default, they are treated as being uncollapsed."
5010 (save-match-data
5011 (save-excursion
5012 (and
5013 ;; Is the topic all on one line (allowing for trailing blank line)?
5014 (>= (progn (allout-back-to-current-heading)
5015 (let ((inhibit-field-text-motion t))
5016 (move-end-of-line 1))
5017 (point))
5018 (allout-end-of-current-subtree (not (looking-at "\n\n"))))
5020 (or include-single-liners
5021 (progn (backward-char 1) (allout-hidden-p)))))))
5022 ;;;_ > allout-hide-current-subtree (&optional just-close)
5023 (defun allout-hide-current-subtree (&optional just-close)
5024 "Close the current topic, or containing topic if this one is already closed.
5026 If this topic is closed and it's a top level topic, close this topic
5027 and its siblings.
5029 If optional arg JUST-CLOSE is non-nil, do not close the parent or
5030 siblings, even if the target topic is already closed."
5032 (interactive)
5033 (let* ((from (point))
5034 (sibs-msg "Top-level topic already closed -- closing siblings...")
5035 (current-exposed (not (allout-current-topic-collapsed-p t))))
5036 (cond (current-exposed (allout-flag-current-subtree t))
5037 (just-close nil)
5038 ((allout-ascend) (allout-hide-current-subtree))
5039 (t (goto-char 0)
5040 (message sibs-msg)
5041 (allout-goto-prefix-doublechecked)
5042 (allout-expose-topic '(0 :))
5043 (message (concat sibs-msg " Done."))))
5044 (goto-char from)))
5045 ;;;_ > allout-toggle-current-subtree-exposure
5046 (defun allout-toggle-current-subtree-exposure ()
5047 "Show or hide the current subtree depending on its current state."
5048 ;; thanks to tassilo for suggesting this.
5049 (interactive)
5050 (save-excursion
5051 (allout-back-to-heading)
5052 (if (allout-hidden-p (point-at-eol))
5053 (allout-show-current-subtree)
5054 (allout-hide-current-subtree))))
5055 ;;;_ > allout-show-current-branches ()
5056 (defun allout-show-current-branches ()
5057 "Show all subheadings of this heading, but not their bodies."
5058 (interactive)
5059 (let ((inhibit-field-text-motion t))
5060 (beginning-of-line))
5061 (allout-show-children t))
5062 ;;;_ > allout-hide-current-leaves ()
5063 (defun allout-hide-current-leaves ()
5064 "Hide the bodies of the current topic and all its offspring."
5065 (interactive)
5066 (allout-back-to-current-heading)
5067 (allout-hide-region-body (point) (progn (allout-end-of-current-subtree)
5068 (point))))
5070 ;;;_ - Region and beyond
5071 ;;;_ > allout-show-all ()
5072 (defun allout-show-all ()
5073 "Show all of the text in the buffer."
5074 (interactive)
5075 (message "Exposing entire buffer...")
5076 (allout-flag-region (point-min) (point-max) nil)
5077 (message "Exposing entire buffer... Done."))
5078 ;;;_ > allout-hide-bodies ()
5079 (defun allout-hide-bodies ()
5080 "Hide all of buffer except headings."
5081 (interactive)
5082 (allout-hide-region-body (point-min) (point-max)))
5083 ;;;_ > allout-hide-region-body (start end)
5084 (defun allout-hide-region-body (start end)
5085 "Hide all body lines in the region, but not headings."
5086 (save-match-data
5087 (save-excursion
5088 (save-restriction
5089 (narrow-to-region start end)
5090 (goto-char (point-min))
5091 (let ((inhibit-field-text-motion t))
5092 (while (not (eobp))
5093 (end-of-line)
5094 (allout-flag-region (point) (allout-end-of-entry) t)
5095 (if (not (eobp))
5096 (forward-char
5097 (if (looking-at "\n\n")
5098 2 1)))))))))
5100 ;;;_ > allout-expose-topic (spec)
5101 (defun allout-expose-topic (spec)
5102 "Apply exposure specs to successive outline topic items.
5104 Use the more convenient frontend, `allout-new-exposure', if you don't
5105 need evaluation of the arguments, or even better, the `allout-layout'
5106 variable-keyed mode-activation/auto-exposure feature of allout outline
5107 mode. See the respective documentation strings for more details.
5109 Cursor is left at start position.
5111 SPEC is either a number or a list.
5113 Successive specs on a list are applied to successive sibling topics.
5115 A simple spec (either a number, one of a few symbols, or the null
5116 list) dictates the exposure for the corresponding topic.
5118 Non-null lists recursively designate exposure specs for respective
5119 subtopics of the current topic.
5121 The `:' repeat spec is used to specify exposure for any number of
5122 successive siblings, up to the trailing ones for which there are
5123 explicit specs following the `:'.
5125 Simple (numeric and null-list) specs are interpreted as follows:
5127 Numbers indicate the relative depth to open the corresponding topic.
5128 - negative numbers force the topic to be closed before opening to the
5129 absolute value of the number, so all siblings are open only to
5130 that level.
5131 - positive numbers open to the relative depth indicated by the
5132 number, but do not force already opened subtopics to be closed.
5133 - 0 means to close topic -- hide all offspring.
5134 : - `repeat'
5135 apply prior element to all siblings at current level, *up to*
5136 those siblings that would be covered by specs following the `:'
5137 on the list. Ie, apply to all topics at level but the last
5138 ones. (Only first of multiple colons at same level is
5139 respected -- subsequent ones are discarded.)
5140 * - completely opens the topic, including bodies.
5141 + - shows all the sub headers, but not the bodies
5142 - - exposes the body of the corresponding topic.
5144 Examples:
5145 \(allout-expose-topic '(-1 : 0))
5146 Close this and all following topics at current level, exposing
5147 only their immediate children, but close down the last topic
5148 at this current level completely.
5149 \(allout-expose-topic '(-1 () : 1 0))
5150 Close current topic so only the immediate subtopics are shown;
5151 show the children in the second to last topic, and completely
5152 close the last one.
5153 \(allout-expose-topic '(-2 : -1 *))
5154 Expose children and grandchildren of all topics at current
5155 level except the last two; expose children of the second to
5156 last and completely open the last one."
5158 (interactive "xExposure spec: ")
5159 (if (not (listp spec))
5161 (let ((depth (allout-depth))
5162 (max-pos 0)
5163 prev-elem curr-elem
5164 stay)
5165 (while spec
5166 (setq prev-elem curr-elem
5167 curr-elem (car spec)
5168 spec (cdr spec))
5169 (cond ; Do current element:
5170 ((null curr-elem) nil)
5171 ((symbolp curr-elem)
5172 (cond ((eq curr-elem '*) (allout-show-current-subtree)
5173 (if (> allout-recent-end-of-subtree max-pos)
5174 (setq max-pos allout-recent-end-of-subtree)))
5175 ((eq curr-elem '+)
5176 (if (not (allout-hidden-p))
5177 (save-excursion (allout-hide-current-subtree t)))
5178 (allout-show-current-branches)
5179 (if (> allout-recent-end-of-subtree max-pos)
5180 (setq max-pos allout-recent-end-of-subtree)))
5181 ((eq curr-elem '-) (allout-show-current-entry))
5182 ((eq curr-elem ':)
5183 (setq stay t)
5184 ;; Expand the `repeat' spec to an explicit version,
5185 ;; w.r.t. remaining siblings:
5186 (let ((residue ; = # of sibs not covered by remaining spec
5187 ;; Dang, could be nice to make use of the chart, sigh:
5188 (- (length (allout-chart-siblings))
5189 (length spec))))
5190 (if (< 0 residue)
5191 ;; Some residue -- cover it with prev-elem:
5192 (setq spec (append (make-list residue prev-elem)
5193 spec)))))))
5194 ((numberp curr-elem)
5195 (if (and (>= 0 curr-elem) (not (allout-hidden-p)))
5196 (save-excursion (allout-hide-current-subtree t)
5197 (if (> 0 curr-elem)
5199 (if (> allout-recent-end-of-subtree max-pos)
5200 (setq max-pos
5201 allout-recent-end-of-subtree)))))
5202 (if (> (abs curr-elem) 0)
5203 (progn (allout-show-children (abs curr-elem))
5204 (if (> allout-recent-end-of-subtree max-pos)
5205 (setq max-pos allout-recent-end-of-subtree)))))
5206 ((listp curr-elem)
5207 (if (allout-descend-to-depth (1+ depth))
5208 (let ((got (allout-expose-topic curr-elem)))
5209 (if (and got (> got max-pos)) (setq max-pos got))))))
5210 (cond (stay (setq stay nil))
5211 ((listp (car spec)) nil)
5212 ((> max-pos (point))
5213 ;; Capitalize on max-pos state to get us nearer next sibling:
5214 (progn (goto-char (min (point-max) max-pos))
5215 (allout-next-heading)))
5216 ((allout-next-sibling depth))))
5217 max-pos)))
5218 ;;;_ > allout-old-expose-topic (spec &rest followers)
5219 (defun allout-old-expose-topic (spec &rest followers)
5221 "Deprecated. Use `allout-expose-topic' (with different schema
5222 format) instead.
5224 Dictate wholesale exposure scheme for current topic, according to SPEC.
5226 SPEC is either a number or a list. Optional successive args
5227 dictate exposure for subsequent siblings of current topic.
5229 A simple spec (either a number, a special symbol, or the null list)
5230 dictates the overall exposure for a topic. Non null lists are
5231 composite specs whose first element dictates the overall exposure for
5232 a topic, with the subsequent elements in the list interpreted as specs
5233 that dictate the exposure for the successive offspring of the topic.
5235 Simple (numeric and null-list) specs are interpreted as follows:
5237 - Numbers indicate the relative depth to open the corresponding topic:
5238 - negative numbers force the topic to be close before opening to the
5239 absolute value of the number.
5240 - positive numbers just open to the relative depth indicated by the number.
5241 - 0 just closes
5242 - `*' completely opens the topic, including bodies.
5243 - `+' shows all the sub headers, but not the bodies
5244 - `-' exposes the body and immediate offspring of the corresponding topic.
5246 If the spec is a list, the first element must be a number, which
5247 dictates the exposure depth of the topic as a whole. Subsequent
5248 elements of the list are nested SPECs, dictating the specific exposure
5249 for the corresponding offspring of the topic.
5251 Optional FOLLOWERS arguments dictate exposure for succeeding siblings."
5253 (interactive "xExposure spec: ")
5254 (let ((inhibit-field-text-motion t)
5255 (depth (allout-current-depth))
5256 max-pos)
5257 (cond ((null spec) nil)
5258 ((symbolp spec)
5259 (if (eq spec '*) (allout-show-current-subtree))
5260 (if (eq spec '+) (allout-show-current-branches))
5261 (if (eq spec '-) (allout-show-current-entry)))
5262 ((numberp spec)
5263 (if (>= 0 spec)
5264 (save-excursion (allout-hide-current-subtree t)
5265 (end-of-line)
5266 (if (or (not max-pos)
5267 (> (point) max-pos))
5268 (setq max-pos (point)))
5269 (if (> 0 spec)
5270 (setq spec (* -1 spec)))))
5271 (if (> spec 0)
5272 (allout-show-children spec)))
5273 ((listp spec)
5274 ;(let ((got (allout-old-expose-topic (car spec))))
5275 ; (if (and got (or (not max-pos) (> got max-pos)))
5276 ; (setq max-pos got)))
5277 (let ((new-depth (+ (allout-current-depth) 1))
5278 got)
5279 (setq max-pos (allout-old-expose-topic (car spec)))
5280 (setq spec (cdr spec))
5281 (if (and spec
5282 (allout-descend-to-depth new-depth)
5283 (not (allout-hidden-p)))
5284 (progn (setq got (apply 'allout-old-expose-topic spec))
5285 (if (and got (or (not max-pos) (> got max-pos)))
5286 (setq max-pos got)))))))
5287 (while (and followers
5288 (progn (if (and max-pos (< (point) max-pos))
5289 (progn (goto-char max-pos)
5290 (setq max-pos nil)))
5291 (end-of-line)
5292 (allout-next-sibling depth)))
5293 (allout-old-expose-topic (car followers))
5294 (setq followers (cdr followers)))
5295 max-pos))
5296 ;;;_ > allout-new-exposure '()
5297 (defmacro allout-new-exposure (&rest spec)
5298 "Literal frontend for `allout-expose-topic', doesn't evaluate arguments.
5299 Some arguments that would need to be quoted in `allout-expose-topic'
5300 need not be quoted in `allout-new-exposure'.
5302 Cursor is left at start position.
5304 Use this instead of obsolete `allout-exposure'.
5306 Examples:
5307 \(allout-new-exposure (-1 () () () 1) 0)
5308 Close current topic at current level so only the immediate
5309 subtopics are shown, except also show the children of the
5310 third subtopic; and close the next topic at the current level.
5311 \(allout-new-exposure : -1 0)
5312 Close all topics at current level to expose only their
5313 immediate children, except for the last topic at the current
5314 level, in which even its immediate children are hidden.
5315 \(allout-new-exposure -2 : -1 *)
5316 Expose children and grandchildren of first topic at current
5317 level, and expose children of subsequent topics at current
5318 level *except* for the last, which should be opened completely."
5319 (list 'save-excursion
5320 '(if (not (or (allout-goto-prefix-doublechecked)
5321 (allout-next-heading)))
5322 (error "allout-new-exposure: Can't find any outline topics"))
5323 (list 'allout-expose-topic (list 'quote spec))))
5325 ;;;_ #7 Systematic outline presentation -- copying, printing, flattening
5327 ;;;_ - Mapping and processing of topics
5328 ;;;_ ( See also Subtree Charting, in Navigation code.)
5329 ;;;_ > allout-stringify-flat-index (flat-index)
5330 (defun allout-stringify-flat-index (flat-index &optional context)
5331 "Convert list representing section/subsection/... to document string.
5333 Optional arg CONTEXT indicates interior levels to include."
5334 (let ((delim ".")
5335 result
5336 numstr
5337 (context-depth (or (and context 2) 1)))
5338 ;; Take care of the explicit context:
5339 (while (> context-depth 0)
5340 (setq numstr (int-to-string (car flat-index))
5341 flat-index (cdr flat-index)
5342 result (if flat-index
5343 (cons delim (cons numstr result))
5344 (cons numstr result))
5345 context-depth (if flat-index (1- context-depth) 0)))
5346 (setq delim " ")
5347 ;; Take care of the indentation:
5348 (if flat-index
5349 (progn
5350 (while flat-index
5351 (setq result
5352 (cons delim
5353 (cons (make-string
5354 (1+ (truncate (if (zerop (car flat-index))
5356 (log10 (car flat-index)))))
5358 result)))
5359 (setq flat-index (cdr flat-index)))
5360 ;; Dispose of single extra delim:
5361 (setq result (cdr result))))
5362 (apply 'concat result)))
5363 ;;;_ > allout-stringify-flat-index-plain (flat-index)
5364 (defun allout-stringify-flat-index-plain (flat-index)
5365 "Convert list representing section/subsection/... to document string."
5366 (let ((delim ".")
5367 result)
5368 (while flat-index
5369 (setq result (cons (int-to-string (car flat-index))
5370 (if result
5371 (cons delim result))))
5372 (setq flat-index (cdr flat-index)))
5373 (apply 'concat result)))
5374 ;;;_ > allout-stringify-flat-index-indented (flat-index)
5375 (defun allout-stringify-flat-index-indented (flat-index)
5376 "Convert list representing section/subsection/... to document string."
5377 (let ((delim ".")
5378 result
5379 numstr)
5380 ;; Take care of the explicit context:
5381 (setq numstr (int-to-string (car flat-index))
5382 flat-index (cdr flat-index)
5383 result (if flat-index
5384 (cons delim (cons numstr result))
5385 (cons numstr result)))
5386 (setq delim " ")
5387 ;; Take care of the indentation:
5388 (if flat-index
5389 (progn
5390 (while flat-index
5391 (setq result
5392 (cons delim
5393 (cons (make-string
5394 (1+ (truncate (if (zerop (car flat-index))
5396 (log10 (car flat-index)))))
5398 result)))
5399 (setq flat-index (cdr flat-index)))
5400 ;; Dispose of single extra delim:
5401 (setq result (cdr result))))
5402 (apply 'concat result)))
5403 ;;;_ > allout-listify-exposed (&optional start end format)
5404 (defun allout-listify-exposed (&optional start end format)
5406 "Produce a list representing exposed topics in current region.
5408 This list can then be used by `allout-process-exposed' to manipulate
5409 the subject region.
5411 Optional START and END indicate bounds of region.
5413 Optional arg, FORMAT, designates an alternate presentation form for
5414 the prefix:
5416 list -- Present prefix as numeric section.subsection..., starting with
5417 section indicated by the list, innermost nesting first.
5418 `indent' (symbol) -- Convert header prefixes to all white space,
5419 except for distinctive bullets.
5421 The elements of the list produced are lists that represents a topic
5422 header and body. The elements of that list are:
5424 - a number representing the depth of the topic,
5425 - a string representing the header-prefix, including trailing whitespace and
5426 bullet.
5427 - a string representing the bullet character,
5428 - and a series of strings, each containing one line of the exposed
5429 portion of the topic entry."
5431 (interactive "r")
5432 (save-excursion
5433 (let*
5434 ((inhibit-field-text-motion t)
5435 ;; state vars:
5436 strings prefix result depth new-depth out gone-out bullet beg
5437 next done)
5439 (goto-char start)
5440 (beginning-of-line)
5441 ;; Goto initial topic, and register preceding stuff, if any:
5442 (if (> (allout-goto-prefix-doublechecked) start)
5443 ;; First topic follows beginning point -- register preliminary stuff:
5444 (setq result
5445 (list (list 0 "" nil
5446 (buffer-substring-no-properties start
5447 (1- (point)))))))
5448 (while (and (not done)
5449 (not (eobp)) ; Loop until we've covered the region.
5450 (not (> (point) end)))
5451 (setq depth allout-recent-depth ; Current topics depth,
5452 bullet (allout-recent-bullet) ; ... bullet,
5453 prefix (allout-recent-prefix)
5454 beg (progn (allout-end-of-prefix t) (point))) ; and beginning.
5455 (setq done ; The boundary for the current topic:
5456 (not (allout-next-visible-heading 1)))
5457 (setq new-depth allout-recent-depth)
5458 (setq gone-out out
5459 out (< new-depth depth))
5460 (beginning-of-line)
5461 (setq next (point))
5462 (goto-char beg)
5463 (setq strings nil)
5464 (while (> next (point)) ; Get all the exposed text in
5465 (setq strings
5466 (cons (buffer-substring-no-properties
5468 ;To hidden text or end of line:
5469 (progn
5470 (end-of-line)
5471 (allout-back-to-visible-text)))
5472 strings))
5473 (when (< (point) next) ; Resume from after hid text, if any.
5474 (line-move 1)
5475 (beginning-of-line))
5476 (setq beg (point)))
5477 ;; Accumulate list for this topic:
5478 (setq strings (nreverse strings))
5479 (setq result
5480 (cons
5481 (if format
5482 (let ((special (if (string-match
5483 (regexp-quote bullet)
5484 allout-distinctive-bullets-string)
5485 bullet)))
5486 (cond ((listp format)
5487 (list depth
5488 (if allout-flattened-numbering-abbreviation
5489 (allout-stringify-flat-index format
5490 gone-out)
5491 (allout-stringify-flat-index-plain
5492 format))
5493 strings
5494 special))
5495 ((eq format 'indent)
5496 (if special
5497 (list depth
5498 (concat (make-string (1+ depth) ? )
5499 (substring prefix -1))
5500 strings)
5501 (list depth
5502 (make-string depth ? )
5503 strings)))
5504 (t (error "allout-listify-exposed: %s %s"
5505 "invalid format" format))))
5506 (list depth prefix strings))
5507 result))
5508 ;; Reassess format, if any:
5509 (if (and format (listp format))
5510 (cond ((= new-depth depth)
5511 (setq format (cons (1+ (car format))
5512 (cdr format))))
5513 ((> new-depth depth) ; descending -- assume by 1:
5514 (setq format (cons 1 format)))
5516 ; Pop the residue:
5517 (while (< new-depth depth)
5518 (setq format (cdr format))
5519 (setq depth (1- depth)))
5520 ; And increment the current one:
5521 (setq format
5522 (cons (1+ (or (car format)
5523 -1))
5524 (cdr format)))))))
5525 ;; Put the list with first at front, to last at back:
5526 (nreverse result))))
5527 ;;;_ > allout-region-active-p ()
5528 (defmacro allout-region-active-p ()
5529 (cond ((fboundp 'use-region-p) '(use-region-p))
5530 ((fboundp 'region-active-p) '(region-active-p))
5531 (t 'mark-active)))
5532 ;;_ > allout-process-exposed (&optional func from to frombuf
5533 ;;; tobuf format)
5534 (defun allout-process-exposed (&optional func from to frombuf tobuf
5535 format start-num)
5536 "Map function on exposed parts of current topic; results to another buffer.
5538 All args are options; default values itemized below.
5540 Apply FUNCTION to exposed portions FROM position TO position in buffer
5541 FROMBUF to buffer TOBUF. Sixth optional arg, FORMAT, designates an
5542 alternate presentation form:
5544 `flat' -- Present prefix as numeric section.subsection..., starting with
5545 section indicated by the START-NUM, innermost nesting first.
5546 X`flat-indented' -- Prefix is like `flat' for first topic at each
5547 X level, but subsequent topics have only leaf topic
5548 X number, padded with blanks to line up with first.
5549 `indent' (symbol) -- Convert header prefixes to all white space,
5550 except for distinctive bullets.
5552 Defaults:
5553 FUNCTION: `allout-insert-listified'
5554 FROM: region start, if region active, else start of buffer
5555 TO: region end, if region active, else end of buffer
5556 FROMBUF: current buffer
5557 TOBUF: buffer name derived: \"*current-buffer-name exposed*\"
5558 FORMAT: nil"
5560 ; Resolve arguments,
5561 ; defaulting if necessary:
5562 (if (not func) (setq func 'allout-insert-listified))
5563 (if (not (and from to))
5564 (if (allout-region-active-p)
5565 (setq from (region-beginning) to (region-end))
5566 (setq from (point-min) to (point-max))))
5567 (if frombuf
5568 (if (not (bufferp frombuf))
5569 ;; Specified but not a buffer -- get it:
5570 (let ((got (get-buffer frombuf)))
5571 (if (not got)
5572 (error (concat "allout-process-exposed: source buffer "
5573 frombuf
5574 " not found."))
5575 (setq frombuf got))))
5576 ;; not specified -- default it:
5577 (setq frombuf (current-buffer)))
5578 (if tobuf
5579 (if (not (bufferp tobuf))
5580 (setq tobuf (get-buffer-create tobuf)))
5581 ;; not specified -- default it:
5582 (setq tobuf (concat "*" (buffer-name frombuf) " exposed*")))
5583 (if (listp format)
5584 (nreverse format))
5586 (let* ((listified
5587 (progn (set-buffer frombuf)
5588 (allout-listify-exposed from to format))))
5589 (set-buffer tobuf)
5590 (mapc func listified)
5591 (pop-to-buffer tobuf)))
5593 ;;;_ - Copy exposed
5594 ;;;_ > allout-insert-listified (listified)
5595 (defun allout-insert-listified (listified)
5596 "Insert contents of listified outline portion in current buffer.
5598 LISTIFIED is a list representing each topic header and body:
5600 \`(depth prefix text)'
5602 or \`(depth prefix text bullet-plus)'
5604 If `bullet-plus' is specified, it is inserted just after the entire prefix."
5605 (setq listified (cdr listified))
5606 (let ((prefix (prog1
5607 (car listified)
5608 (setq listified (cdr listified))))
5609 (text (prog1
5610 (car listified)
5611 (setq listified (cdr listified))))
5612 (bullet-plus (car listified)))
5613 (insert prefix)
5614 (if bullet-plus (insert (concat " " bullet-plus)))
5615 (while text
5616 (insert (car text))
5617 (if (setq text (cdr text))
5618 (insert "\n")))
5619 (insert "\n")))
5620 ;;;_ > allout-copy-exposed-to-buffer (&optional arg tobuf format)
5621 (defun allout-copy-exposed-to-buffer (&optional arg tobuf format)
5622 "Duplicate exposed portions of current outline to another buffer.
5624 Other buffer has current buffers name with \" exposed\" appended to it.
5626 With repeat count, copy the exposed parts of only the current topic.
5628 Optional second arg TOBUF is target buffer name.
5630 Optional third arg FORMAT, if non-nil, symbolically designates an
5631 alternate presentation format for the outline:
5633 `flat' - Convert topic header prefixes to numeric
5634 section.subsection... identifiers.
5635 `indent' - Convert header prefixes to all white space, except for
5636 distinctive bullets.
5637 `indent-flat' - The best of both - only the first of each level has
5638 the full path, the rest have only the section number
5639 of the leaf, preceded by the right amount of indentation."
5641 (interactive "P")
5642 (if (not tobuf)
5643 (setq tobuf (get-buffer-create (concat "*" (buffer-name) " exposed*"))))
5644 (let* ((start-pt (point))
5645 (beg (if arg (allout-back-to-current-heading) (point-min)))
5646 (end (if arg (allout-end-of-current-subtree) (point-max)))
5647 (buf (current-buffer))
5648 (start-list ()))
5649 (if (eq format 'flat)
5650 (setq format (if arg (save-excursion
5651 (goto-char beg)
5652 (allout-topic-flat-index))
5653 '(1))))
5654 (with-current-buffer tobuf (erase-buffer))
5655 (allout-process-exposed 'allout-insert-listified
5658 (current-buffer)
5659 tobuf
5660 format start-list)
5661 (goto-char (point-min))
5662 (pop-to-buffer buf)
5663 (goto-char start-pt)))
5664 ;;;_ > allout-flatten-exposed-to-buffer (&optional arg tobuf)
5665 (defun allout-flatten-exposed-to-buffer (&optional arg tobuf)
5666 "Present numeric outline of outline's exposed portions in another buffer.
5668 The resulting outline is not compatible with outline mode -- use
5669 `allout-copy-exposed-to-buffer' if you want that.
5671 Use `allout-indented-exposed-to-buffer' for indented presentation.
5673 With repeat count, copy the exposed portions of only current topic.
5675 Other buffer has current buffer's name with \" exposed\" appended to
5676 it, unless optional second arg TOBUF is specified, in which case it is
5677 used verbatim."
5678 (interactive "P")
5679 (allout-copy-exposed-to-buffer arg tobuf 'flat))
5680 ;;;_ > allout-indented-exposed-to-buffer (&optional arg tobuf)
5681 (defun allout-indented-exposed-to-buffer (&optional arg tobuf)
5682 "Present indented outline of outline's exposed portions in another buffer.
5684 The resulting outline is not compatible with outline mode -- use
5685 `allout-copy-exposed-to-buffer' if you want that.
5687 Use `allout-flatten-exposed-to-buffer' for numeric sectional presentation.
5689 With repeat count, copy the exposed portions of only current topic.
5691 Other buffer has current buffer's name with \" exposed\" appended to
5692 it, unless optional second arg TOBUF is specified, in which case it is
5693 used verbatim."
5694 (interactive "P")
5695 (allout-copy-exposed-to-buffer arg tobuf 'indent))
5697 ;;;_ - LaTeX formatting
5698 ;;;_ > allout-latex-verb-quote (string &optional flow)
5699 (defun allout-latex-verb-quote (string &optional flow)
5700 "Return copy of STRING for literal reproduction across LaTeX processing.
5701 Expresses the original characters (including carriage returns) of the
5702 string across LaTeX processing."
5703 (mapconcat (function
5704 (lambda (char)
5705 (cond ((memq char '(?\\ ?$ ?% ?# ?& ?{ ?} ?_ ?^ ?- ?*))
5706 (concat "\\char" (number-to-string char) "{}"))
5707 ((= char ?\n) "\\\\")
5708 (t (char-to-string char)))))
5709 string
5710 ""))
5711 ;;;_ > allout-latex-verbatim-quote-curr-line ()
5712 (defun allout-latex-verbatim-quote-curr-line ()
5713 "Express line for exact (literal) representation across LaTeX processing.
5715 Adjust line contents so it is unaltered (from the original line)
5716 across LaTeX processing, within the context of a `verbatim'
5717 environment. Leaves point at the end of the line."
5718 (let ((inhibit-field-text-motion t))
5719 (beginning-of-line)
5720 (let ((beg (point))
5721 (end (point-at-eol)))
5722 (save-match-data
5723 (while (re-search-forward "\\\\"
5724 ;;"\\\\\\|\\{\\|\\}\\|\\_\\|\\$\\|\\\"\\|\\&\\|\\^\\|\\-\\|\\*\\|#"
5725 end ; bounded by end-of-line
5726 1) ; no matches, move to end & return nil
5727 (goto-char (match-beginning 2))
5728 (insert "\\")
5729 (setq end (1+ end))
5730 (goto-char (1+ (match-end 2))))))))
5731 ;;;_ > allout-insert-latex-header (buffer)
5732 (defun allout-insert-latex-header (buffer)
5733 "Insert initial LaTeX commands at point in BUFFER."
5734 ;; Much of this is being derived from the stuff in appendix of E in
5735 ;; the TeXBook, pg 421.
5736 (set-buffer buffer)
5737 (let ((doc-style (format "\n\\documentstyle{%s}\n"
5738 "report"))
5739 (page-numbering (if allout-number-pages
5740 "\\pagestyle{empty}\n"
5741 ""))
5742 (titlecmd (format "\\newcommand{\\titlecmd}[1]{{%s #1}}\n"
5743 allout-title-style))
5744 (labelcmd (format "\\newcommand{\\labelcmd}[1]{{%s #1}}\n"
5745 allout-label-style))
5746 (headlinecmd (format "\\newcommand{\\headlinecmd}[1]{{%s #1}}\n"
5747 allout-head-line-style))
5748 (bodylinecmd (format "\\newcommand{\\bodylinecmd}[1]{{%s #1}}\n"
5749 allout-body-line-style))
5750 (setlength (format "%s%s%s%s"
5751 "\\newlength{\\stepsize}\n"
5752 "\\setlength{\\stepsize}{"
5753 allout-indent
5754 "}\n"))
5755 (oneheadline (format "%s%s%s%s%s%s%s"
5756 "\\newcommand{\\OneHeadLine}[3]{%\n"
5757 "\\noindent%\n"
5758 "\\hspace*{#2\\stepsize}%\n"
5759 "\\labelcmd{#1}\\hspace*{.2cm}"
5760 "\\headlinecmd{#3}\\\\["
5761 allout-line-skip
5762 "]\n}\n"))
5763 (onebodyline (format "%s%s%s%s%s%s"
5764 "\\newcommand{\\OneBodyLine}[2]{%\n"
5765 "\\noindent%\n"
5766 "\\hspace*{#1\\stepsize}%\n"
5767 "\\bodylinecmd{#2}\\\\["
5768 allout-line-skip
5769 "]\n}\n"))
5770 (begindoc "\\begin{document}\n\\begin{center}\n")
5771 (title (format "%s%s%s%s"
5772 "\\titlecmd{"
5773 (allout-latex-verb-quote (if allout-title
5774 (condition-case nil
5775 (eval allout-title)
5776 (error "<unnamed buffer>"))
5777 "Unnamed Outline"))
5778 "}\n"
5779 "\\end{center}\n\n"))
5780 (hsize "\\hsize = 7.5 true in\n")
5781 (hoffset "\\hoffset = -1.5 true in\n")
5782 (vspace "\\vspace{.1cm}\n\n"))
5783 (insert (concat doc-style
5784 page-numbering
5785 titlecmd
5786 labelcmd
5787 headlinecmd
5788 bodylinecmd
5789 setlength
5790 oneheadline
5791 onebodyline
5792 begindoc
5793 title
5794 hsize
5795 hoffset
5796 vspace)
5798 ;;;_ > allout-insert-latex-trailer (buffer)
5799 (defun allout-insert-latex-trailer (buffer)
5800 "Insert concluding LaTeX commands at point in BUFFER."
5801 (set-buffer buffer)
5802 (insert "\n\\end{document}\n"))
5803 ;;;_ > allout-latexify-one-item (depth prefix bullet text)
5804 (defun allout-latexify-one-item (depth prefix bullet text)
5805 "Insert LaTeX commands for formatting one outline item.
5807 Args are the topics numeric DEPTH, the header PREFIX lead string, the
5808 BULLET string, and a list of TEXT strings for the body."
5809 (let* ((head-line (if text (car text)))
5810 (body-lines (cdr text))
5811 (curr-line)
5812 body-content bop)
5813 ; Do the head line:
5814 (insert (concat "\\OneHeadLine{\\verb\1 "
5815 (allout-latex-verb-quote bullet)
5816 "\1}{"
5817 depth
5818 "}{\\verb\1 "
5819 (if head-line
5820 (allout-latex-verb-quote head-line)
5822 "\1}\n"))
5823 (if (not body-lines)
5825 ;;(insert "\\beginlines\n")
5826 (insert "\\begin{verbatim}\n")
5827 (while body-lines
5828 (setq curr-line (car body-lines))
5829 (if (and (not body-content)
5830 (not (string-match "^\\s-*$" curr-line)))
5831 (setq body-content t))
5832 ; Mangle any occurrences of
5833 ; "\end{verbatim}" in text,
5834 ; it's special:
5835 (if (and body-content
5836 (setq bop (string-match "\\end{verbatim}" curr-line)))
5837 (setq curr-line (concat (substring curr-line 0 bop)
5839 (substring curr-line bop))))
5840 ;;(insert "|" (car body-lines) "|")
5841 (insert curr-line)
5842 (allout-latex-verbatim-quote-curr-line)
5843 (insert "\n")
5844 (setq body-lines (cdr body-lines)))
5845 (if body-content
5846 (setq body-content nil)
5847 (forward-char -1)
5848 (insert "\\ ")
5849 (forward-char 1))
5850 ;;(insert "\\endlines\n")
5851 (insert "\\end{verbatim}\n")
5853 ;;;_ > allout-latexify-exposed (arg &optional tobuf)
5854 (defun allout-latexify-exposed (arg &optional tobuf)
5855 "Format current topics exposed portions to TOBUF for LaTeX processing.
5856 TOBUF defaults to a buffer named the same as the current buffer, but
5857 with \"*\" prepended and \" latex-formed*\" appended.
5859 With repeat count, copy the exposed portions of entire buffer."
5861 (interactive "P")
5862 (if (not tobuf)
5863 (setq tobuf
5864 (get-buffer-create (concat "*" (buffer-name) " latexified*"))))
5865 (let* ((start-pt (point))
5866 (beg (if arg (point-min) (allout-back-to-current-heading)))
5867 (end (if arg (point-max) (allout-end-of-current-subtree)))
5868 (buf (current-buffer)))
5869 (set-buffer tobuf)
5870 (erase-buffer)
5871 (allout-insert-latex-header tobuf)
5872 (goto-char (point-max))
5873 (allout-process-exposed 'allout-latexify-one-item
5877 tobuf)
5878 (goto-char (point-max))
5879 (allout-insert-latex-trailer tobuf)
5880 (goto-char (point-min))
5881 (pop-to-buffer buf)
5882 (goto-char start-pt)))
5884 ;;;_ #8 Encryption
5885 ;;;_ > allout-toggle-current-subtree-encryption (&optional keymode-cue)
5886 (defun allout-toggle-current-subtree-encryption (&optional keymode-cue)
5887 "Encrypt clear or decrypt encoded topic text.
5889 Allout uses Emacs 'epg' library to perform encryption. Symmetric
5890 and keypair encryption are supported. All encryption is ascii
5891 armored.
5893 Entry encryption defaults to symmetric key mode unless keypair
5894 recipients are associated with the file (see
5895 `epa-file-encrypt-to') or the function is invoked with a
5896 \(KEYMODE-CUE) universal argument greater than 1.
5898 When encrypting, KEYMODE-CUE universal argument greater than 1
5899 causes prompting for recipients for public-key keypair
5900 encryption. Selecting no recipients results in symmetric key
5901 encryption.
5903 Further, encrypting with a KEYMODE-CUE universal argument greater
5904 than 4 - eg, preceded by a doubled Ctrl-U - causes association of
5905 the specified recipients with the file, replacing those currently
5906 associated with it. This can be used to dissociate any
5907 recipients with the file, by selecting no recipients in the
5908 dialog.
5910 Encrypted topic's bullets are set to a `~' to signal that the
5911 contents of the topic (body and subtopics, but not heading) is
5912 pending encryption or encrypted. `*' asterisk immediately after
5913 the bullet signals that the body is encrypted, its absence means
5914 the topic is meant to be encrypted but is not currently. When a
5915 file with topics pending encryption is saved, topics pending
5916 encryption are encrypted. See `allout-encrypt-unencrypted-on-saves'
5917 for auto-encryption specifics.
5919 \*NOTE WELL* that automatic encryption that happens during saves will
5920 default to symmetric encryption -- you must deliberately (re)encrypt key-pair
5921 encrypted topics if you want them to continue to use the key-pair cipher.
5923 Level-one topics, with prefix consisting solely of an `*' asterisk, cannot be
5924 encrypted. If you want to encrypt the contents of a top-level topic, use
5925 \\[allout-shift-in] to increase its depth."
5926 (interactive "P")
5927 (save-excursion
5928 (allout-back-to-current-heading)
5929 (allout-toggle-subtree-encryption keymode-cue)))
5930 ;;;_ > allout-toggle-subtree-encryption (&optional keymode-cue)
5931 (defun allout-toggle-subtree-encryption (&optional keymode-cue)
5932 "Encrypt clear text or decrypt encoded topic contents (body and subtopics.)
5934 Entry encryption defaults to symmetric key mode unless keypair
5935 recipients are associated with the file (see
5936 `epa-file-encrypt-to') or the function is invoked with a
5937 \(KEYMODE-CUE) universal argument greater than 1.
5939 When encrypting, KEYMODE-CUE universal argument greater than 1
5940 causes prompting for recipients for public-key keypair
5941 encryption. Selecting no recipients results in symmetric key
5942 encryption.
5944 Further, encrypting with a KEYMODE-CUE universal argument greater
5945 than 4 - eg, preceded by a doubled Ctrl-U - causes association of
5946 the specified recipients with the file, replacing those currently
5947 associated with it. This can be used to dissociate any
5948 recipients with the file, by selecting no recipients in the
5949 dialog.
5951 Encryption and decryption uses the Emacs 'epg' library.
5953 Encrypted text will be ascii-armored.
5955 See `allout-toggle-current-subtree-encryption' for more details."
5957 (interactive "P")
5958 (save-excursion
5959 (allout-end-of-prefix t)
5961 (if (= allout-recent-depth 1)
5962 (error (concat "Cannot encrypt or decrypt level 1 topics -"
5963 " shift it in to make it encryptable")))
5965 (let* ((allout-buffer (current-buffer))
5966 ;; for use with allout-auto-save-temporarily-disabled, if necessary:
5967 (was-buffer-saved-size buffer-saved-size)
5968 ;; Assess location:
5969 (bullet-pos allout-recent-prefix-beginning)
5970 (after-bullet-pos (point))
5971 (was-encrypted
5972 (progn (if (= (point-max) after-bullet-pos)
5973 (error "no body to encrypt"))
5974 (allout-encrypted-topic-p)))
5975 (was-collapsed (if (not (search-forward "\n" nil t))
5977 (backward-char 1)
5978 (allout-hidden-p)))
5979 (subtree-beg (1+ (point)))
5980 (subtree-end (allout-end-of-subtree))
5981 (subject-text (buffer-substring-no-properties subtree-beg
5982 subtree-end))
5983 (subtree-end-char (char-after (1- subtree-end)))
5984 (subtree-trailing-char (char-after subtree-end))
5985 ;; kluge -- result-text needs to be nil, but we also want to
5986 ;; check for the error condition
5987 (result-text (if (or (string= "" subject-text)
5988 (string= "\n" subject-text))
5989 (error "No topic contents to %scrypt"
5990 (if was-encrypted "de" "en"))
5991 nil))
5992 ;; Assess key parameters:
5993 (was-coding-system buffer-file-coding-system))
5995 (when (not was-encrypted)
5996 ;; ensure that non-ascii chars pending encryption are noticed before
5997 ;; they're encrypted, so the coding system is set to accommodate
5998 ;; them.
5999 (setq buffer-file-coding-system
6000 (allout-select-safe-coding-system subtree-beg subtree-end))
6001 ;; if the coding system for the text being encrypted is different
6002 ;; than that prevailing, then there a real risk that the coding
6003 ;; system can't be noticed by emacs when the file is visited. to
6004 ;; mitigate that, offer to preserve the coding system using a file
6005 ;; local variable.
6006 (if (and (not (equal buffer-file-coding-system
6007 was-coding-system))
6008 (yes-or-no-p
6009 (format (concat "Register coding system %s as file local"
6010 " var? Necessary when only encrypted text"
6011 " is in that coding system. ")
6012 buffer-file-coding-system)))
6013 (allout-adjust-file-variable "buffer-file-coding-system"
6014 buffer-file-coding-system)))
6016 (setq result-text
6017 (allout-encrypt-string subject-text was-encrypted
6018 (current-buffer) keymode-cue))
6020 ;; Replace the subtree with the processed product.
6021 (allout-unprotected
6022 (progn
6023 (set-buffer allout-buffer)
6024 (delete-region subtree-beg subtree-end)
6025 (insert result-text)
6026 (if was-collapsed
6027 (allout-flag-region (1- subtree-beg) (point) t))
6028 ;; adjust trailing-blank-lines to preserve topic spacing:
6029 (if (not was-encrypted)
6030 (if (and (= subtree-end-char ?\n)
6031 (= subtree-trailing-char ?\n))
6032 (insert subtree-trailing-char)))
6033 ;; Ensure that the item has an encrypted-entry bullet:
6034 (if (not (string= (buffer-substring-no-properties
6035 (1- after-bullet-pos) after-bullet-pos)
6036 allout-topic-encryption-bullet))
6037 (progn (goto-char (1- after-bullet-pos))
6038 (delete-char 1)
6039 (insert allout-topic-encryption-bullet)))
6040 (if was-encrypted
6041 ;; Remove the is-encrypted bullet qualifier:
6042 (progn (goto-char after-bullet-pos)
6043 (delete-char 1))
6044 ;; Add the is-encrypted bullet qualifier:
6045 (goto-char after-bullet-pos)
6046 (insert "*"))))
6048 ;; adjust buffer's auto-save eligibility:
6049 (if was-encrypted
6050 (allout-inhibit-auto-save-info-for-decryption was-buffer-saved-size)
6051 (allout-maybe-resume-auto-save-info-after-encryption))
6053 (run-hook-with-args 'allout-structure-added-functions
6054 bullet-pos subtree-end))))
6055 ;;;_ > allout-encrypt-string (text decrypt allout-buffer keymode-cue
6056 ;;; &optional rejected)
6057 (defun allout-encrypt-string (text decrypt allout-buffer keymode-cue
6058 &optional rejected)
6059 "Encrypt or decrypt message TEXT.
6061 Returns the resulting string, or nil if the transformation fails.
6063 If DECRYPT is true (default false), then decrypt instead of encrypt.
6065 ALLOUT-BUFFER identifies the buffer containing the text.
6067 Entry encryption defaults to symmetric key mode unless keypair
6068 recipients are associated with the file (see
6069 `epa-file-encrypt-to') or the function is invoked with a
6070 \(KEYMODE-CUE) universal argument greater than 1.
6072 When encrypting, KEYMODE-CUE universal argument greater than 1
6073 causes prompting for recipients for public-key keypair
6074 encryption. Selecting no recipients results in symmetric key
6075 encryption.
6077 Further, encrypting with a KEYMODE-CUE universal argument greater
6078 than 4 - eg, preceded by a doubled Ctrl-U - causes association of
6079 the specified recipients with the file, replacing those currently
6080 associated with it. This can be used to dissociate any
6081 recipients with the file, by selecting no recipients in the
6082 dialog.
6084 Optional REJECTED is for internal use, to convey the number of
6085 rejections due to matches against
6086 `allout-encryption-ciphertext-rejection-regexps', as limited by
6087 `allout-encryption-ciphertext-rejection-ceiling'.
6089 NOTE: A few GnuPG v2 versions improperly preserve incorrect
6090 symmetric decryption keys, preventing entry of the correct key on
6091 subsequent decryption attempts until the cache times-out. That
6092 can take several minutes. (Decryption of other entries is not
6093 affected.) Upgrade your EasyPG version, if you can, and you can
6094 deliberately clear your gpg-agent's cache by sending it a '-HUP'
6095 signal."
6097 (require 'epg)
6098 (require 'epa)
6100 (let* ((epg-context (let* ((context (epg-make-context nil t)))
6101 (epg-context-set-passphrase-callback
6102 context #'epa-passphrase-callback-function)
6103 context))
6105 (encoding (with-current-buffer allout-buffer
6106 buffer-file-coding-system))
6107 (multibyte (with-current-buffer allout-buffer
6108 enable-multibyte-characters))
6109 ;; "sanitization" avoids encryption results that are outline structure.
6110 (sani-regexps 'allout-encryption-plaintext-sanitization-regexps)
6111 (strip-plaintext-regexps (if (not decrypt)
6112 (allout-get-configvar-values
6113 sani-regexps)))
6114 (rejection-regexps 'allout-encryption-ciphertext-rejection-regexps)
6115 (reject-ciphertext-regexps (if (not decrypt)
6116 (allout-get-configvar-values
6117 rejection-regexps)))
6118 (rejected (or rejected 0))
6119 (rejections-left (- allout-encryption-ciphertext-rejection-ceiling
6120 rejected))
6121 (keypair-mode (cond (decrypt 'decrypting)
6122 ((<= (prefix-numeric-value keymode-cue) 1)
6123 'default)
6124 ((<= (prefix-numeric-value keymode-cue) 4)
6125 'prompt)
6126 ((> (prefix-numeric-value keymode-cue) 4)
6127 'prompt-save)))
6128 (keypair-message (concat "Select encryption recipients.\n"
6129 "Symmetric encryption is done if no"
6130 " recipients are selected. "))
6131 (encrypt-to (and (boundp 'epa-file-encrypt-to) epa-file-encrypt-to))
6132 recipients
6133 massaged-text
6134 result-text
6137 ;; Massage the subject text for encoding and filtering.
6138 (with-temp-buffer
6139 (insert text)
6140 ;; convey the text characteristics of the original buffer:
6141 (set-buffer-multibyte multibyte)
6142 (when encoding
6143 (set-buffer-file-coding-system encoding)
6144 (if (not decrypt)
6145 (encode-coding-region (point-min) (point-max) encoding)))
6147 ;; remove sanitization regexps matches before encrypting:
6148 (when (and strip-plaintext-regexps (not decrypt))
6149 (dolist (re strip-plaintext-regexps)
6150 (let ((re (if (listp re) (car re) re))
6151 (replacement (if (listp re) (cadr re) "")))
6152 (goto-char (point-min))
6153 (save-match-data
6154 (while (re-search-forward re nil t)
6155 (replace-match replacement nil nil))))))
6156 (setq massaged-text (buffer-substring-no-properties (point-min)
6157 (point-max))))
6158 ;; determine key mode and, if keypair, recipients:
6159 (setq recipients
6160 (case keypair-mode
6162 (decrypting nil)
6164 (default (if encrypt-to (epg-list-keys epg-context encrypt-to)))
6166 ((prompt prompt-save)
6167 (save-window-excursion
6168 (epa-select-keys epg-context keypair-message)))))
6170 (setq result-text
6171 (if decrypt
6172 (condition-case err
6173 (epg-decrypt-string epg-context
6174 (encode-coding-string massaged-text
6175 (or encoding 'utf-8)))
6176 (epg-error
6177 (signal 'egp-error
6178 (cons (concat (cadr err) " - gpg version problem?")
6179 (cddr err)))))
6180 (replace-regexp-in-string "\n$" ""
6181 (epg-encrypt-string epg-context
6182 (encode-coding-string massaged-text
6183 (or encoding 'utf-8))
6184 recipients))))
6186 ;; validate result -- non-empty
6187 (if (not result-text)
6188 (error "%scryption failed." (if decrypt "De" "En")))
6191 (when (eq keypair-mode 'prompt-save)
6192 ;; set epa-file-encrypt-to in the buffer:
6193 (setq epa-file-encrypt-to (mapcar (lambda (key)
6194 (epg-user-id-string
6195 (car (epg-key-user-id-list key))))
6196 recipients))
6197 ;; change the file variable:
6198 (allout-adjust-file-variable "epa-file-encrypt-to" epa-file-encrypt-to))
6200 (cond
6201 ;; Retry (within limit) if ciphertext contains rejections:
6202 ((and (not decrypt)
6203 ;; Check for disqualification of this ciphertext:
6204 (let ((regexps reject-ciphertext-regexps)
6205 reject-it)
6206 (while (and regexps (not reject-it))
6207 (setq reject-it (string-match (car regexps) result-text))
6208 (pop regexps))
6209 reject-it))
6210 (setq rejections-left (1- rejections-left))
6211 (if (<= rejections-left 0)
6212 (error (concat "Ciphertext rejected too many times"
6213 " (%s), per `%s'")
6214 allout-encryption-ciphertext-rejection-ceiling
6215 'allout-encryption-ciphertext-rejection-regexps)
6216 ;; try again (gpg-agent may have the key cached):
6217 (allout-encrypt-string text decrypt allout-buffer keypair-mode
6218 (1+ rejected))))
6220 ;; Barf if encryption yields extraordinary control chars:
6221 ((and (not decrypt)
6222 (string-match "[\C-a\C-k\C-o-\C-z\C-@]"
6223 result-text))
6224 (error (concat "Encryption produced non-armored text, which"
6225 "conflicts with allout mode -- reconfigure!")))
6226 (t result-text))))
6227 ;;;_ > allout-inhibit-auto-save-info-for-decryption
6228 (defun allout-inhibit-auto-save-info-for-decryption (was-buffer-saved-size)
6229 "Temporarily prevent auto-saves in this buffer when an item is decrypted.
6231 WAS-BUFFER-SAVED-SIZE is the value of `buffer-saved-size' *before*
6232 the decryption."
6233 (when (not (or (= buffer-saved-size -1) (= was-buffer-saved-size -1)))
6234 (setq allout-auto-save-temporarily-disabled was-buffer-saved-size
6235 buffer-saved-size -1)))
6236 ;;;_ > allout-maybe-resume-auto-save-info-after-encryption ()
6237 (defun allout-maybe-resume-auto-save-info-after-encryption ()
6238 "Restore auto-save info, *if* there are no topics pending encryption."
6239 (when (and allout-auto-save-temporarily-disabled
6240 (= buffer-saved-size -1)
6241 (save-excursion
6242 (save-restriction
6243 (widen)
6244 (goto-char (point-min))
6245 (not (allout-next-topic-pending-encryption)))))
6246 (setq buffer-saved-size allout-auto-save-temporarily-disabled
6247 allout-auto-save-temporarily-disabled nil)))
6249 ;;;_ > allout-encrypted-topic-p ()
6250 (defun allout-encrypted-topic-p ()
6251 "True if the current topic is encryptable and encrypted."
6252 (save-excursion
6253 (allout-end-of-prefix t)
6254 (and (string= (buffer-substring-no-properties (1- (point)) (point))
6255 allout-topic-encryption-bullet)
6256 (save-match-data (looking-at "\\*")))
6259 ;;;_ > allout-next-topic-pending-encryption ()
6260 (defun allout-next-topic-pending-encryption ()
6261 "Return the point of the next topic pending encryption, or nil if none.
6263 Such a topic has the `allout-topic-encryption-bullet' without an
6264 immediately following '*' that would mark the topic as being encrypted.
6265 It must also have content."
6266 (let (done got content-beg)
6267 (save-match-data
6268 (while (not done)
6270 (if (not (re-search-forward
6271 (format "\\(\\`\\|\n\\)%s *%s[^*]"
6272 (regexp-quote allout-header-prefix)
6273 (regexp-quote allout-topic-encryption-bullet))
6274 nil t))
6275 (setq got nil
6276 done t)
6277 (goto-char (setq got (match-beginning 0)))
6278 (if (save-match-data (looking-at "\n"))
6279 (forward-char 1))
6280 (setq got (point)))
6282 (cond ((not got)
6283 (setq done t))
6285 ((not (search-forward "\n"))
6286 (setq got nil
6287 done t))
6289 ((eobp)
6290 (setq got nil
6291 done t))
6294 (setq content-beg (point))
6295 (backward-char 1)
6296 (allout-end-of-subtree)
6297 (if (<= (point) content-beg)
6298 ;; Continue looking
6299 (setq got nil)
6300 ;; Got it!
6301 (setq done t)))
6304 (if got
6305 (goto-char got))
6309 ;;;_ > allout-encrypt-decrypted ()
6310 (defun allout-encrypt-decrypted ()
6311 "Encrypt topics pending encryption except those containing exemption point.
6313 If a topic that is currently being edited was encrypted, we return a list
6314 containing the location of the topic and the location of the cursor just
6315 before the topic was encrypted. This can be used, eg, to decrypt the topic
6316 and exactly resituate the cursor if this is being done as part of a file
6317 save. See `allout-encrypt-unencrypted-on-saves' for more info."
6319 (interactive "p")
6320 (save-match-data
6321 (save-excursion
6322 (let* ((current-mark (point-marker))
6323 (current-mark-position (marker-position current-mark))
6324 was-modified
6325 bo-subtree
6326 editing-topic editing-point)
6327 (goto-char (point-min))
6328 (while (allout-next-topic-pending-encryption)
6329 (setq was-modified (buffer-modified-p))
6330 (when (save-excursion
6331 (and (boundp 'allout-encrypt-unencrypted-on-saves)
6332 allout-encrypt-unencrypted-on-saves
6333 (setq bo-subtree (re-search-forward "$"))
6334 (not (allout-hidden-p))
6335 (>= current-mark (point))
6336 (allout-end-of-current-subtree)
6337 (<= current-mark (point))))
6338 (setq editing-topic (point)
6339 ;; we had to wait for this 'til now so prior topics are
6340 ;; encrypted, any relevant text shifts are in place:
6341 editing-point (- current-mark-position
6342 (count-trailing-whitespace-region
6343 bo-subtree current-mark-position))))
6344 (allout-toggle-subtree-encryption)
6345 (if (not was-modified)
6346 (set-buffer-modified-p nil))
6348 (if (not was-modified)
6349 (set-buffer-modified-p nil))
6350 (if editing-topic (list editing-topic editing-point))
6356 ;;;_ #9 miscellaneous
6357 ;;;_ : Mode:
6358 ;;;_ > outlineify-sticky ()
6359 ;; outlinify-sticky is correct spelling; provide this alias for sticklers:
6360 ;;;###autoload
6361 (defalias 'outlinify-sticky 'outlineify-sticky)
6362 ;;;###autoload
6363 (defun outlineify-sticky (&optional arg)
6364 "Activate outline mode and establish file var so it is started subsequently.
6366 See `allout-layout' and customization of `allout-auto-activation'
6367 for details on preparing Emacs for automatic allout activation."
6369 (interactive "P")
6371 (if (allout-mode-p) (allout-mode)) ; deactivate so we can re-activate...
6372 (allout-mode)
6374 (save-excursion
6375 (goto-char (point-min))
6376 (if (allout-goto-prefix)
6378 (allout-open-topic 2)
6379 (insert (concat "Dummy outline topic header -- see"
6380 "`allout-mode' docstring: `^Hm'."))
6381 (allout-adjust-file-variable
6382 "allout-layout" (or allout-layout '(-1 : 0))))))
6383 ;;;_ > allout-file-vars-section-data ()
6384 (defun allout-file-vars-section-data ()
6385 "Return data identifying the file-vars section, or nil if none.
6387 Returns a list of the form (BEGINNING-POINT PREFIX-STRING SUFFIX-STRING)."
6388 ;; minimally gleaned from emacs 21.4 files.el hack-local-variables function.
6389 (let (beg prefix suffix)
6390 (save-excursion
6391 (goto-char (point-max))
6392 (search-backward "\n\^L" (max (- (point-max) 3000) (point-min)) 'move)
6393 (if (let ((case-fold-search t))
6394 (not (search-forward "Local Variables:" nil t)))
6396 (setq beg (- (point) 16))
6397 (setq suffix (buffer-substring-no-properties
6398 (point)
6399 (progn (if (search-forward "\n" nil t)
6400 (forward-char -1))
6401 (point))))
6402 (setq prefix (buffer-substring-no-properties
6403 (progn (if (search-backward "\n" nil t)
6404 (forward-char 1))
6405 (point))
6406 beg))
6407 (list beg prefix suffix))
6411 ;;;_ > allout-adjust-file-variable (varname value)
6412 (defun allout-adjust-file-variable (varname value)
6413 "Adjust the setting of an Emacs file variable named VARNAME to VALUE.
6415 This activity is inhibited if either `enable-local-variables' or
6416 `allout-enable-file-variable-adjustment' are nil.
6418 When enabled, an entry for the variable is created if not already present,
6419 or changed if established with a different value. The section for the file
6420 variables, itself, is created if not already present. When created, the
6421 section lines (including the section line) exist as second-level topics in
6422 a top-level topic at the end of the file.
6424 `enable-local-variables' must be true for any of this to happen."
6425 (if (not (and enable-local-variables
6426 allout-enable-file-variable-adjustment))
6428 (save-excursion
6429 (let ((inhibit-field-text-motion t)
6430 (section-data (allout-file-vars-section-data))
6431 beg prefix suffix)
6432 (if section-data
6433 (setq beg (car section-data)
6434 prefix (cadr section-data)
6435 suffix (car (cddr section-data)))
6436 ;; create the section
6437 (goto-char (point-max))
6438 (open-line 1)
6439 (allout-open-topic 0)
6440 (end-of-line)
6441 (insert "Local emacs vars.\n")
6442 (allout-open-topic 1)
6443 (setq beg (point)
6444 suffix ""
6445 prefix (buffer-substring-no-properties (progn
6446 (beginning-of-line)
6447 (point))
6448 beg))
6449 (goto-char beg)
6450 (insert "Local variables:\n")
6451 (allout-open-topic 0)
6452 (insert "End:\n")
6454 ;; look for existing entry or create one, leaving point for insertion
6455 ;; of new value:
6456 (goto-char beg)
6457 (allout-show-to-offshoot)
6458 (if (search-forward (concat "\n" prefix varname ":") nil t)
6459 (let* ((value-beg (point))
6460 (line-end (progn (if (search-forward "\n" nil t)
6461 (forward-char -1))
6462 (point)))
6463 (value-end (- line-end (length suffix))))
6464 (if (> value-end value-beg)
6465 (delete-region value-beg value-end)))
6466 (end-of-line)
6467 (open-line 1)
6468 (forward-line 1)
6469 (insert (concat prefix varname ":")))
6470 (insert (format " %S%s" value suffix))
6475 ;;;_ > allout-get-configvar-values (varname)
6476 (defun allout-get-configvar-values (configvar-name)
6477 "Return a list of values of the symbols in list bound to CONFIGVAR-NAME.
6479 The user is prompted for removal of symbols that are unbound, and they
6480 otherwise are ignored.
6482 CONFIGVAR-NAME should be the name of the configuration variable,
6483 not its value."
6485 (let ((configvar-value (symbol-value configvar-name))
6486 got)
6487 (dolist (sym configvar-value)
6488 (if (not (boundp sym))
6489 (if (yes-or-no-p (format "%s entry `%s' is unbound -- remove it? "
6490 configvar-name sym))
6491 (delq sym (symbol-value configvar-name)))
6492 (push (symbol-value sym) got)))
6493 (reverse got)))
6494 ;;;_ : Topics:
6495 ;;;_ > allout-mark-topic ()
6496 (defun allout-mark-topic ()
6497 "Put the region around topic currently containing point."
6498 (interactive)
6499 (let ((inhibit-field-text-motion t))
6500 (beginning-of-line))
6501 (allout-goto-prefix-doublechecked)
6502 (push-mark (point))
6503 (allout-end-of-current-subtree)
6504 (exchange-point-and-mark))
6505 ;;;_ : UI:
6506 ;;;_ > solicit-char-in-string (prompt string &optional do-defaulting)
6507 (defun solicit-char-in-string (prompt string &optional do-defaulting)
6508 "Solicit (with first arg PROMPT) choice of a character from string STRING.
6510 Optional arg DO-DEFAULTING indicates to accept empty input (CR)."
6512 (let ((new-prompt prompt)
6513 got)
6515 (while (not got)
6516 (message "%s" new-prompt)
6518 ;; We do our own reading here, so we can circumvent, eg, special
6519 ;; treatment for `?' character. (Oughta use minibuffer keymap instead.)
6520 (setq got
6521 (char-to-string (let ((cursor-in-echo-area nil)) (read-char))))
6523 (setq got
6524 (cond ((string-match (regexp-quote got) string) got)
6525 ((and do-defaulting (string= got "\r"))
6526 ;; Return empty string to default:
6528 ((string= got "\C-g") (signal 'quit nil))
6530 (setq new-prompt (concat prompt
6532 " ...pick from: "
6533 string
6534 ""))
6535 nil))))
6536 ;; got something out of loop -- return it:
6537 got)
6539 ;;;_ : Strings:
6540 ;;;_ > regexp-sans-escapes (string)
6541 (defun regexp-sans-escapes (regexp &optional successive-backslashes)
6542 "Return a copy of REGEXP with all character escapes stripped out.
6544 Representations of actual backslashes -- '\\\\\\\\' -- are left as a
6545 single backslash.
6547 Optional arg SUCCESSIVE-BACKSLASHES is used internally for recursion."
6549 (if (string= regexp "")
6551 ;; Set successive-backslashes to number if current char is
6552 ;; backslash, or else to nil:
6553 (setq successive-backslashes
6554 (if (= (aref regexp 0) ?\\)
6555 (if successive-backslashes (1+ successive-backslashes) 1)
6556 nil))
6557 (if (or (not successive-backslashes) (= 2 successive-backslashes))
6558 ;; Include first char:
6559 (concat (substring regexp 0 1)
6560 (regexp-sans-escapes (substring regexp 1)))
6561 ;; Exclude first char, but maintain count:
6562 (regexp-sans-escapes (substring regexp 1) successive-backslashes))))
6563 ;;;_ > count-trailing-whitespace-region (beg end)
6564 (defun count-trailing-whitespace-region (beg end)
6565 "Return number of trailing whitespace chars between BEG and END.
6567 If BEG is bigger than END we return 0."
6568 (if (> beg end)
6570 (save-match-data
6571 (save-excursion
6572 (goto-char beg)
6573 (let ((count 0))
6574 (while (re-search-forward "[ ][ ]*$" end t)
6575 (goto-char (1+ (match-beginning 2)))
6576 (setq count (1+ count)))
6577 count)))))
6578 ;;;_ > allout-format-quote (string)
6579 (defun allout-format-quote (string)
6580 "Return a copy of string with all \"%\" characters doubled."
6581 (apply 'concat
6582 (mapcar (lambda (char) (if (= char ?%) "%%" (char-to-string char)))
6583 string)))
6584 ;;;_ : lists
6585 ;;;_ > allout-flatten (list)
6586 (defun allout-flatten (list)
6587 "Return a list of all atoms in list."
6588 ;; classic.
6589 (cond ((null list) nil)
6590 ((atom (car list)) (cons (car list) (allout-flatten (cdr list))))
6591 (t (append (allout-flatten (car list)) (allout-flatten (cdr list))))))
6592 ;;;_ : Compatibility:
6593 ;;;_ : xemacs undo-in-progress provision:
6594 (unless (boundp 'undo-in-progress)
6595 (defvar undo-in-progress nil
6596 "Placeholder defvar for XEmacs compatibility from allout.el.")
6597 (defadvice undo-more (around allout activate)
6598 ;; This defadvice used only in emacs that lack undo-in-progress, eg xemacs.
6599 (let ((undo-in-progress t)) ad-do-it)))
6601 ;;;_ > allout-mark-marker to accommodate divergent emacsen:
6602 (defun allout-mark-marker (&optional force buffer)
6603 "Accommodate the different signature for `mark-marker' across Emacsen.
6605 XEmacs takes two optional args, while Emacs does not,
6606 so pass them along when appropriate."
6607 (if (featurep 'xemacs)
6608 (apply 'mark-marker force buffer)
6609 (mark-marker)))
6610 ;;;_ > subst-char-in-string if necessary
6611 (if (not (fboundp 'subst-char-in-string))
6612 (defun subst-char-in-string (fromchar tochar string &optional inplace)
6613 "Replace FROMCHAR with TOCHAR in STRING each time it occurs.
6614 Unless optional argument INPLACE is non-nil, return a new string."
6615 (let ((i (length string))
6616 (newstr (if inplace string (copy-sequence string))))
6617 (while (> i 0)
6618 (setq i (1- i))
6619 (if (eq (aref newstr i) fromchar)
6620 (aset newstr i tochar)))
6621 newstr)))
6622 ;;;_ > wholenump if necessary
6623 (if (not (fboundp 'wholenump))
6624 (defalias 'wholenump 'natnump))
6625 ;;;_ > remove-overlays if necessary
6626 (if (not (fboundp 'remove-overlays))
6627 (defun remove-overlays (&optional beg end name val)
6628 "Clear BEG and END of overlays whose property NAME has value VAL.
6629 Overlays might be moved and/or split.
6630 BEG and END default respectively to the beginning and end of buffer."
6631 (unless beg (setq beg (point-min)))
6632 (unless end (setq end (point-max)))
6633 (if (< end beg)
6634 (setq beg (prog1 end (setq end beg))))
6635 (save-excursion
6636 (dolist (o (overlays-in beg end))
6637 (when (eq (overlay-get o name) val)
6638 ;; Either push this overlay outside beg...end
6639 ;; or split it to exclude beg...end
6640 ;; or delete it entirely (if it is contained in beg...end).
6641 (if (< (overlay-start o) beg)
6642 (if (> (overlay-end o) end)
6643 (progn
6644 (move-overlay (copy-overlay o)
6645 (overlay-start o) beg)
6646 (move-overlay o end (overlay-end o)))
6647 (move-overlay o (overlay-start o) beg))
6648 (if (> (overlay-end o) end)
6649 (move-overlay o end (overlay-end o))
6650 (delete-overlay o)))))))
6652 ;;;_ > copy-overlay if necessary -- xemacs ~ 21.4
6653 (if (not (fboundp 'copy-overlay))
6654 (defun copy-overlay (o)
6655 "Return a copy of overlay O."
6656 (let ((o1 (make-overlay (overlay-start o) (overlay-end o)
6657 ;; FIXME: there's no easy way to find the
6658 ;; insertion-type of the two markers.
6659 (overlay-buffer o)))
6660 (props (overlay-properties o)))
6661 (while props
6662 (overlay-put o1 (pop props) (pop props)))
6663 o1)))
6664 ;;;_ > add-to-invisibility-spec if necessary -- xemacs ~ 21.4
6665 (if (not (fboundp 'add-to-invisibility-spec))
6666 (defun add-to-invisibility-spec (element)
6667 "Add ELEMENT to `buffer-invisibility-spec'.
6668 See documentation for `buffer-invisibility-spec' for the kind of elements
6669 that can be added."
6670 (if (eq buffer-invisibility-spec t)
6671 (setq buffer-invisibility-spec (list t)))
6672 (setq buffer-invisibility-spec
6673 (cons element buffer-invisibility-spec))))
6674 ;;;_ > remove-from-invisibility-spec if necessary -- xemacs ~ 21.4
6675 (if (not (fboundp 'remove-from-invisibility-spec))
6676 (defun remove-from-invisibility-spec (element)
6677 "Remove ELEMENT from `buffer-invisibility-spec'."
6678 (if (consp buffer-invisibility-spec)
6679 (setq buffer-invisibility-spec (delete element
6680 buffer-invisibility-spec)))))
6681 ;;;_ > move-beginning-of-line if necessary -- older emacs, xemacs
6682 (if (not (fboundp 'move-beginning-of-line))
6683 (defun move-beginning-of-line (arg)
6684 "Move point to beginning of current line as displayed.
6685 \(This disregards invisible newlines such as those
6686 which are part of the text that an image rests on.)
6688 With argument ARG not nil or 1, move forward ARG - 1 lines first.
6689 If point reaches the beginning or end of buffer, it stops there.
6690 To ignore intangibility, bind `inhibit-point-motion-hooks' to t."
6691 (interactive "p")
6692 (or arg (setq arg 1))
6693 (if (/= arg 1)
6694 (condition-case nil (line-move (1- arg)) (error nil)))
6696 ;; Move to beginning-of-line, ignoring fields and invisible text.
6697 (skip-chars-backward "^\n")
6698 (while (and (not (bobp))
6699 (let ((prop
6700 (get-char-property (1- (point)) 'invisible)))
6701 (if (eq buffer-invisibility-spec t)
6702 prop
6703 (or (memq prop buffer-invisibility-spec)
6704 (assq prop buffer-invisibility-spec)))))
6705 (goto-char (if (featurep 'xemacs)
6706 (previous-property-change (point))
6707 (previous-char-property-change (point))))
6708 (skip-chars-backward "^\n"))
6709 (vertical-motion 0))
6711 ;;;_ > move-end-of-line if necessary -- Emacs < 22.1, xemacs
6712 (if (not (fboundp 'move-end-of-line))
6713 (defun move-end-of-line (arg)
6714 "Move point to end of current line as displayed.
6715 \(This disregards invisible newlines such as those
6716 which are part of the text that an image rests on.)
6718 With argument ARG not nil or 1, move forward ARG - 1 lines first.
6719 If point reaches the beginning or end of buffer, it stops there.
6720 To ignore intangibility, bind `inhibit-point-motion-hooks' to t."
6721 (interactive "p")
6722 (or arg (setq arg 1))
6723 (let (done)
6724 (while (not done)
6725 (let ((newpos
6726 (save-excursion
6727 (let ((goal-column 0))
6728 (and (condition-case nil
6729 (or (line-move arg) t)
6730 (error nil))
6731 (not (bobp))
6732 (progn
6733 (while
6734 (and
6735 (not (bobp))
6736 (let ((prop
6737 (get-char-property (1- (point))
6738 'invisible)))
6739 (if (eq buffer-invisibility-spec t)
6740 prop
6741 (or (memq prop
6742 buffer-invisibility-spec)
6743 (assq prop
6744 buffer-invisibility-spec)))))
6745 (goto-char
6746 (previous-char-property-change (point))))
6747 (backward-char 1)))
6748 (point)))))
6749 (goto-char newpos)
6750 (if (and (> (point) newpos)
6751 (eq (preceding-char) ?\n))
6752 (backward-char 1)
6753 (if (and (> (point) newpos) (not (eobp))
6754 (not (eq (following-char) ?\n)))
6755 ;; If we skipped something intangible
6756 ;; and now we're not really at eol,
6757 ;; keep going.
6758 (setq arg 1)
6759 (setq done t)))))))
6761 ;;;_ > allout-next-single-char-property-change -- alias unless lacking
6762 (defalias 'allout-next-single-char-property-change
6763 (if (fboundp 'next-single-char-property-change)
6764 'next-single-char-property-change
6765 'next-single-property-change)
6766 ;; No docstring because xemacs defalias doesn't support it.
6768 ;;;_ > allout-previous-single-char-property-change -- alias unless lacking
6769 (defalias 'allout-previous-single-char-property-change
6770 (if (fboundp 'previous-single-char-property-change)
6771 'previous-single-char-property-change
6772 'previous-single-property-change)
6773 ;; No docstring because xemacs defalias doesn't support it.
6775 ;;;_ > allout-select-safe-coding-system
6776 (defalias 'allout-select-safe-coding-system
6777 (if (fboundp 'select-safe-coding-system)
6778 'select-safe-coding-system
6779 'detect-coding-region)
6781 ;;;_ > allout-substring-no-properties
6782 ;; define as alias first, so byte compiler is happy.
6783 (defalias 'allout-substring-no-properties 'substring-no-properties)
6784 ;; then supplant with definition if underlying alias absent.
6785 (if (not (fboundp 'substring-no-properties))
6786 (defun allout-substring-no-properties (string &optional start end)
6787 (substring string (or start 0) end))
6790 ;;;_ #10 Unfinished
6791 ;;;_ > allout-bullet-isearch (&optional bullet)
6792 (defun allout-bullet-isearch (&optional bullet)
6793 "Isearch (regexp) for topic with bullet BULLET."
6794 (interactive)
6795 (if (not bullet)
6796 (setq bullet (solicit-char-in-string
6797 "ISearch for topic with bullet: "
6798 (regexp-sans-escapes allout-bullets-string))))
6800 (let ((isearch-regexp t)
6801 (isearch-string (concat "^"
6802 allout-header-prefix
6803 "[ \t]*"
6804 bullet)))
6805 (isearch-repeat 'forward)
6806 (isearch-mode t)))
6808 ;;;_ #11 Unit tests -- this should be last item before "Provide"
6809 ;;;_ > allout-run-unit-tests ()
6810 (defun allout-run-unit-tests ()
6811 "Run the various allout unit tests."
6812 (message "Running allout tests...")
6813 (allout-test-resumptions)
6814 (message "Running allout tests... Done.")
6815 (sit-for .5))
6816 ;;;_ : test resumptions:
6817 ;;;_ > allout-tests-obliterate-variable (name)
6818 (defun allout-tests-obliterate-variable (name)
6819 "Completely unbind variable with NAME."
6820 (if (local-variable-p name (current-buffer)) (kill-local-variable name))
6821 (while (boundp name) (makunbound name)))
6822 ;;;_ > allout-test-resumptions ()
6823 (defvar allout-tests-globally-unbound nil
6824 "Fodder for allout resumptions tests -- defvar just for byte compiler.")
6825 (defvar allout-tests-globally-true nil
6826 "Fodder for allout resumptions tests -- defvar just for byte compiler.")
6827 (defvar allout-tests-locally-true nil
6828 "Fodder for allout resumptions tests -- defvar just for byte compiler.")
6829 (defun allout-test-resumptions ()
6830 "Exercise allout resumptions."
6831 ;; for each resumption case, we also test that the right local/global
6832 ;; scopes are affected during resumption effects:
6834 ;; ensure that previously unbound variables return to the unbound state.
6835 (with-temp-buffer
6836 (allout-tests-obliterate-variable 'allout-tests-globally-unbound)
6837 (allout-add-resumptions '(allout-tests-globally-unbound t))
6838 (assert (not (default-boundp 'allout-tests-globally-unbound)))
6839 (assert (local-variable-p 'allout-tests-globally-unbound (current-buffer)))
6840 (assert (boundp 'allout-tests-globally-unbound))
6841 (assert (equal allout-tests-globally-unbound t))
6842 (allout-do-resumptions)
6843 (assert (not (local-variable-p 'allout-tests-globally-unbound
6844 (current-buffer))))
6845 (assert (not (boundp 'allout-tests-globally-unbound))))
6847 ;; ensure that variable with prior global value is resumed
6848 (with-temp-buffer
6849 (allout-tests-obliterate-variable 'allout-tests-globally-true)
6850 (setq allout-tests-globally-true t)
6851 (allout-add-resumptions '(allout-tests-globally-true nil))
6852 (assert (equal (default-value 'allout-tests-globally-true) t))
6853 (assert (local-variable-p 'allout-tests-globally-true (current-buffer)))
6854 (assert (equal allout-tests-globally-true nil))
6855 (allout-do-resumptions)
6856 (assert (not (local-variable-p 'allout-tests-globally-true
6857 (current-buffer))))
6858 (assert (boundp 'allout-tests-globally-true))
6859 (assert (equal allout-tests-globally-true t)))
6861 ;; ensure that prior local value is resumed
6862 (with-temp-buffer
6863 (allout-tests-obliterate-variable 'allout-tests-locally-true)
6864 (set (make-local-variable 'allout-tests-locally-true) t)
6865 (assert (not (default-boundp 'allout-tests-locally-true))
6866 nil (concat "Test setup mistake -- variable supposed to"
6867 " not have global binding, but it does."))
6868 (assert (local-variable-p 'allout-tests-locally-true (current-buffer))
6869 nil (concat "Test setup mistake -- variable supposed to have"
6870 " local binding, but it lacks one."))
6871 (allout-add-resumptions '(allout-tests-locally-true nil))
6872 (assert (not (default-boundp 'allout-tests-locally-true)))
6873 (assert (local-variable-p 'allout-tests-locally-true (current-buffer)))
6874 (assert (equal allout-tests-locally-true nil))
6875 (allout-do-resumptions)
6876 (assert (boundp 'allout-tests-locally-true))
6877 (assert (local-variable-p 'allout-tests-locally-true (current-buffer)))
6878 (assert (equal allout-tests-locally-true t))
6879 (assert (not (default-boundp 'allout-tests-locally-true))))
6881 ;; ensure that last of multiple resumptions holds, for various scopes.
6882 (with-temp-buffer
6883 (allout-tests-obliterate-variable 'allout-tests-globally-unbound)
6884 (allout-tests-obliterate-variable 'allout-tests-globally-true)
6885 (setq allout-tests-globally-true t)
6886 (allout-tests-obliterate-variable 'allout-tests-locally-true)
6887 (set (make-local-variable 'allout-tests-locally-true) t)
6888 (allout-add-resumptions '(allout-tests-globally-unbound t)
6889 '(allout-tests-globally-true nil)
6890 '(allout-tests-locally-true nil))
6891 (allout-add-resumptions '(allout-tests-globally-unbound 2)
6892 '(allout-tests-globally-true 3)
6893 '(allout-tests-locally-true 4))
6894 ;; reestablish many of the basic conditions are maintained after re-add:
6895 (assert (not (default-boundp 'allout-tests-globally-unbound)))
6896 (assert (local-variable-p 'allout-tests-globally-unbound (current-buffer)))
6897 (assert (equal allout-tests-globally-unbound 2))
6898 (assert (default-boundp 'allout-tests-globally-true))
6899 (assert (local-variable-p 'allout-tests-globally-true (current-buffer)))
6900 (assert (equal allout-tests-globally-true 3))
6901 (assert (not (default-boundp 'allout-tests-locally-true)))
6902 (assert (local-variable-p 'allout-tests-locally-true (current-buffer)))
6903 (assert (equal allout-tests-locally-true 4))
6904 (allout-do-resumptions)
6905 (assert (not (local-variable-p 'allout-tests-globally-unbound
6906 (current-buffer))))
6907 (assert (not (boundp 'allout-tests-globally-unbound)))
6908 (assert (not (local-variable-p 'allout-tests-globally-true
6909 (current-buffer))))
6910 (assert (boundp 'allout-tests-globally-true))
6911 (assert (equal allout-tests-globally-true t))
6912 (assert (boundp 'allout-tests-locally-true))
6913 (assert (local-variable-p 'allout-tests-locally-true (current-buffer)))
6914 (assert (equal allout-tests-locally-true t))
6915 (assert (not (default-boundp 'allout-tests-locally-true))))
6917 ;; ensure that deliberately unbinding registered variables doesn't foul things
6918 (with-temp-buffer
6919 (allout-tests-obliterate-variable 'allout-tests-globally-unbound)
6920 (allout-tests-obliterate-variable 'allout-tests-globally-true)
6921 (setq allout-tests-globally-true t)
6922 (allout-tests-obliterate-variable 'allout-tests-locally-true)
6923 (set (make-local-variable 'allout-tests-locally-true) t)
6924 (allout-add-resumptions '(allout-tests-globally-unbound t)
6925 '(allout-tests-globally-true nil)
6926 '(allout-tests-locally-true nil))
6927 (allout-tests-obliterate-variable 'allout-tests-globally-unbound)
6928 (allout-tests-obliterate-variable 'allout-tests-globally-true)
6929 (allout-tests-obliterate-variable 'allout-tests-locally-true)
6930 (allout-do-resumptions))
6932 ;;;_ % Run unit tests if `allout-run-unit-tests-after-load' is true:
6933 (when allout-run-unit-tests-on-load
6934 (allout-run-unit-tests))
6936 ;;;_ #12 Provide
6937 (provide 'allout)
6939 ;;;_* Local emacs vars.
6940 ;; The following `allout-layout' local variable setting:
6941 ;; - closes all topics from the first topic to just before the third-to-last,
6942 ;; - shows the children of the third to last (config vars)
6943 ;; - and the second to last (code section),
6944 ;; - and closes the last topic (this local-variables section).
6945 ;;Local variables:
6946 ;;allout-layout: (0 : -1 -1 0)
6947 ;;End:
6949 ;;; allout.el ends here