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