1 ;;; allout.el --- extensive outline mode for use alone and with other modes
3 ;; Copyright (C) 1992-1994, 2001-2011 Free Software Foundation, Inc.
5 ;; Author: Ken Manheimer <ken dot manheimer at gmail...>
6 ;; Maintainer: Ken Manheimer <ken dot manheimer at gmail...>
7 ;; Created: Dec 1991 -- first release to usenet
9 ;; Keywords: outlines, wp, languages, PGP, GnuPG
10 ;; Website: http://myriadicity.net/software-and-systems/craft/emacs-allout
12 ;; This file is part of GNU Emacs.
14 ;; GNU Emacs is free software: you can redistribute it and/or modify
15 ;; it under the terms of the GNU General Public License as published by
16 ;; the Free Software Foundation, either version 3 of the License, or
17 ;; (at your option) any later version.
19 ;; GNU Emacs is distributed in the hope that it will be useful,
20 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
22 ;; GNU General Public License for more details.
24 ;; You should have received a copy of the GNU General Public License
25 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
29 ;; Allout outline minor mode provides extensive outline formatting and
30 ;; and manipulation beyond standard emacs outline mode. Some features:
32 ;; - Classic outline-mode topic-oriented navigation and exposure adjustment
33 ;; - Topic-oriented editing including coherent topic and subtopic
34 ;; creation, promotion, demotion, cut/paste across depths, etc.
35 ;; - Incremental search with dynamic exposure and reconcealment of text
36 ;; - Customizable bullet format -- enables programming-language specific
37 ;; outlining, for code-folding editing. (Allout code itself is to try it;
38 ;; formatted as an outline -- do ESC-x eval-buffer in allout.el; but
39 ;; emacs local file variables need to be enabled when the
40 ;; file was visited -- see `enable-local-variables'.)
41 ;; - Configurable per-file initial exposure settings
42 ;; - Symmetric-key and key-pair topic encryption. Encryption is via the
43 ;; Emacs 'epg' library. See allout-toggle-current-subtree-encryption
45 ;; - Automatic topic-number maintenance
46 ;; - "Hot-spot" operation, for single-keystroke maneuvering and
47 ;; exposure control (see the allout-mode docstring)
48 ;; - Easy rendering of exposed portions into numbered, latex, indented, etc
50 ;; - Careful attention to whitespace -- enabling blank lines between items
51 ;; and maintenance of hanging indentation (in paragraph auto-fill and
52 ;; across topic promotion and demotion) of topic bodies consistent with
53 ;; indentation of their topic header.
57 ;; See the `allout-mode' function's docstring for an introduction to the
60 ;; Directions to the latest development version and helpful notes are
61 ;; available at http://myriadicity.net/Sundry/EmacsAllout .
63 ;; The outline menubar additions provide quick reference to many of the
64 ;; features. See the docstring of the variables `allout-layout' and
65 ;; `allout-auto-activation' for details on automatic activation of
66 ;; `allout-mode' as a minor mode. (`allout-init' is deprecated in favor of
67 ;; a purely customization-based method.)
69 ;; Note -- the lines beginning with `;;;_' are outline topic headers.
70 ;; Customize `allout-auto-activation' to enable, then revisit this
71 ;; buffer to give it a whirl.
73 ;; ken manheimer (ken dot manheimer at gmail dot com)
77 ;;;_* Dependency loads
80 ;; Most of the requires here are for stuff covered by autoloads, which
81 ;; byte-compiling doesn't trigger.
85 ;; `cl' is required for `assert'. `assert' is not covered by a standard
86 ;; autoload, but it is a macro, so that eval-when-compile is sufficient
87 ;; to byte-compile it in, or to do the require when the buffer evalled.
91 ;;;_* USER CUSTOMIZATION VARIABLES:
93 ;;;_ > defgroup allout, allout-keybindings
95 "Extensive outline minor-mode, for use stand-alone and with other modes.
97 See Allout Auto Activation for automatic activation."
100 (defgroup allout-keybindings nil
101 "Allout outline mode keyboard bindings configuration."
104 ;;;_ + Layout, Mode, and Topic Header Configuration
106 (defvar allout-command-prefix
) ; defined below
108 ;;;_ > allout-keybindings incidentals:
109 ;;;_ : internal key binding stuff - in this section for load-order.
110 ;;;_ = allout-mode-map
111 (defvar allout-mode-map
'allout-mode-map
112 "Keybindings place-holder for (allout) outline minor mode.
114 Do NOT set the value of this variable. Instead, customize
115 `allout-command-prefix', `allout-prefixed-keybindings', and
116 `allout-unprefixed-keybindings'.")
117 ;;;_ = allout-mode-map-value
118 (defvar allout-mode-map-value nil
119 "Keymap for allout outline minor mode.
121 Do NOT set the value of this variable. Instead, customize
122 `allout-command-prefix', `allout-prefixed-keybindings', and
123 `allout-unprefixed-keybindings'.")
124 ;;;_ = make allout-mode-map-value an alias for allout-mode-map:
125 ;; this needs to be revised when the value is changed, sigh.
126 (defalias 'allout-mode-map allout-mode-map-value
)
127 ;;;_ > allout-compose-and-institute-keymap (&optional varname value)
128 (defun allout-compose-and-institute-keymap (&optional varname value
)
129 "Create the allout keymap according to the keybinding specs, and set it.
131 Useful standalone or to effect customizations of the
132 respective allout-mode keybinding variables, `allout-command-prefix',
133 `allout-prefixed-keybindings', and `allout-unprefixed-keybindings'"
134 ;; Set the customization variable, if any:
136 (set-default varname value
))
137 (let ((map (make-sparse-keymap)))
138 (when (boundp 'allout-prefixed-keybindings
)
139 ;; tolerate first definitions of the variables:
140 (dolist (entry allout-prefixed-keybindings
)
142 ;; XXX vector vs non-vector key descriptions?
143 (vconcat allout-command-prefix
144 (car (read-from-string (car entry
))))
146 (when (boundp 'allout-unprefixed-keybindings
)
147 (dolist (entry allout-unprefixed-keybindings
)
148 (define-key map
(car (read-from-string (car entry
))) (cadr entry
))))
149 (substitute-key-definition 'beginning-of-line
'allout-beginning-of-line
151 (substitute-key-definition 'move-beginning-of-line
'allout-beginning-of-line
153 (substitute-key-definition 'end-of-line
'allout-end-of-line
155 (substitute-key-definition 'move-end-of-line
'allout-end-of-line
157 (allout-institute-keymap map
)))
158 ;;;_ > allout-institute-keymap (map)
159 (defun allout-institute-keymap (map)
160 "Associate allout-mode bindings with allout as a minor mode."
162 ;; allout-mode-map var is a keymap by virtue of being a defalias for
163 ;; allout-mode-map-value, which has the actual keymap value.
164 ;; allout-mode-map's symbol value is just 'allout-mode-map, so it can be
165 ;; used in minor-mode-map-alist to indirect to the actual
166 ;; allout-mode-map-var value, which can be adjusted and reassigned.
168 ;; allout-mode-map-value for keymap reference in various places:
169 (setq allout-mode-map-value map
)
170 ;; the function value keymap of allout-mode-map is used in
171 ;; minor-mode-map-alist - update it:
172 (fset allout-mode-map allout-mode-map-value
))
173 ;;;_ * initialize the mode map:
174 ;; ensure that allout-mode-map has some setting even if allout-mode hasn't
176 (allout-compose-and-institute-keymap)
177 ;;;_ = allout-command-prefix
178 (defcustom allout-command-prefix
"\C-c "
179 "Key sequence to be used as prefix for outline mode command key bindings.
181 Default is '\C-c<space>'; just '\C-c' is more short-and-sweet, if you're
182 willing to let allout use a bunch of \C-c keybindings."
184 :group
'allout-keybindings
185 :set
'allout-compose-and-institute-keymap
)
186 ;;;_ = allout-keybindings-binding
187 (define-widget 'allout-keybindings-binding
'lazy
188 "Structure of allout keybindings customization items."
190 (list (string :tag
"Key" :value
"[(meta control shift ?f)]")
191 (function :tag
"Function name"
192 :value allout-forward-current-level
))))
193 ;;;_ = allout-prefixed-keybindings
194 (defcustom allout-prefixed-keybindings
195 '(("[(control ?n)]" allout-next-visible-heading
)
196 ("[(control ?p)]" allout-previous-visible-heading
)
197 ("[(control ?u)]" allout-up-current-level
)
198 ("[(control ?f)]" allout-forward-current-level
)
199 ("[(control ?b)]" allout-backward-current-level
)
200 ("[(control ?a)]" allout-beginning-of-current-entry
)
201 ("[(control ?e)]" allout-end-of-entry
)
202 ("[(control ?i)]" allout-show-children
)
203 ("[(control ?s)]" allout-show-current-subtree
)
204 ("[(control ?t)]" allout-toggle-current-subtree-exposure
)
205 ;; Let user customize if they want to preempt describe-prefix-bindings ^h use.
206 ;; ("[(control ?h)]" allout-hide-current-subtree)
207 ("[?h]" allout-hide-current-subtree
)
208 ("[(control ?o)]" allout-show-current-entry
)
209 ("[?!]" allout-show-all
)
210 ("[?x]" allout-toggle-current-subtree-encryption
)
211 ("[? ]" allout-open-sibtopic
)
212 ("[?.]" allout-open-subtopic
)
213 ("[?,]" allout-open-supertopic
)
214 ("[?']" allout-shift-in
)
215 ("[?>]" allout-shift-in
)
216 ("[?<]" allout-shift-out
)
217 ("[(control ?m)]" allout-rebullet-topic
)
218 ("[?*]" allout-rebullet-current-heading
)
219 ("[?#]" allout-number-siblings
)
220 ("[(control ?k)]" allout-kill-topic
)
221 ("[(meta ?k)]" allout-copy-topic-as-kill
)
222 ("[?@]" allout-resolve-xref
)
223 ("[?=?c]" allout-copy-exposed-to-buffer
)
224 ("[?=?i]" allout-indented-exposed-to-buffer
)
225 ("[?=?t]" allout-latexify-exposed
)
226 ("[?=?p]" allout-flatten-exposed-to-buffer
)
228 "Allout-mode key bindings that are prefixed with `allout-command-prefix'.
230 See `allout-unprefixed-keybindings' for the list of keybindings
231 that are not prefixed.
233 Use vector format for the keys:
234 - put literal keys after a '?' question mark, eg: '?a', '?.'
235 - enclose control, shift, or meta-modified keys as sequences within
236 parentheses, with the literal key, as above, preceded by the name(s)
237 of the modifiers, eg: [(control ?a)]
238 See the existing keys for examples.
240 Functions can be bound to multiple keys, but binding keys to
241 multiple functions will not work - the last binding for a key
243 :type
'allout-keybindings-binding
244 :group
'allout-keybindings
245 :set
'allout-compose-and-institute-keymap
247 ;;;_ = allout-unprefixed-keybindings
248 (defcustom allout-unprefixed-keybindings
249 '(("[(control ?k)]" allout-kill-line
)
250 ("[(meta ?k)]" allout-copy-line-as-kill
)
251 ("[(control ?y)]" allout-yank
)
252 ("[(meta ?y)]" allout-yank-pop
)
254 "Allout-mode functions bound to keys without any added prefix.
256 This is in contrast to the majority of allout-mode bindings on
257 `allout-prefixed-bindings', whose bindings are created with a
258 preceding command key.
260 Use vector format for the keys:
261 - put literal keys after a '?' question mark, eg: '?a', '?.'
262 - enclose control, shift, or meta-modified keys as sequences within
263 parentheses, with the literal key, as above, preceded by the name(s)
264 of the modifiers, eg: [(control ?a)]
265 See the existing keys for examples."
266 :type
'allout-keybindings-binding
267 :group
'allout-keybindings
268 :set
'allout-compose-and-institute-keymap
271 ;;;_ > allout-auto-activation-helper (var value)
273 (defun allout-auto-activation-helper (var value
)
274 "Institute `allout-auto-activation'.
276 Intended to be used as the `allout-auto-activation' :set function."
277 (set-default var value
)
279 ;;;_ > allout-setup ()
281 (defun allout-setup ()
282 "Do fundamental Emacs session for allout auto-activation.
284 Establishes allout processing as part of visiting a file if
285 `allout-auto-activation' is non-nil, or removes it otherwise.
287 The proper way to use this is through customizing the setting of
288 `allout-auto-activation'."
289 (if (not allout-auto-activation
)
290 (remove-hook 'find-file-hook
'allout-find-file-hook
)
291 (add-hook 'find-file-hook
'allout-find-file-hook
)))
292 ;;;_ = allout-auto-activation
294 (defcustom allout-auto-activation nil
295 "Configure allout outline mode auto-activation.
297 Control whether and how allout outline mode is automatically
298 activated when files are visited with non-nil buffer-specific
299 file variable `allout-layout'.
301 When allout-auto-activation is \"On\" (t), allout mode is
302 activated in buffers with non-nil `allout-layout', and the
303 specified layout is applied.
305 With value \"ask\", auto-mode-activation is enabled, and endorsement for
306 performing auto-layout is asked of the user each time.
308 With value \"activate\", only auto-mode-activation is enabled.
311 With value nil, inhibit any automatic allout-mode activation."
312 :set
'allout-auto-activation-helper
313 ;; FIXME: Using strings here is unusual and less efficient than symbols.
314 :type
'(choice (const :tag
"On" t
)
315 (const :tag
"Ask about layout" "ask")
316 (const :tag
"Mode only" "activate")
317 (const :tag
"Off" nil
))
320 ;;;_ = allout-default-layout
321 (defcustom allout-default-layout
'(-2 : 0)
322 "Default allout outline layout specification.
324 This setting specifies the outline exposure to use when
325 `allout-layout' has the local value `t'. This docstring describes the
326 layout specifications.
328 A list value specifies a default layout for the current buffer,
329 to be applied upon activation of `allout-mode'. Any non-nil
330 value will automatically trigger `allout-mode', provided
331 `allout-auto-activation' has been customized to enable it.
333 The types of elements in the layout specification are:
335 INTEGER -- dictate the relative depth to open the corresponding topic(s),
337 -- negative numbers force the topic to be closed before opening
338 to the absolute value of the number, so all siblings are open
340 -- positive numbers open to the relative depth indicated by the
341 number, but do not force already opened subtopics to be closed.
342 -- 0 means to close topic -- hide all subitems.
343 : -- repeat spec -- apply the preceding element to all siblings at
344 current level, *up to* those siblings that would be covered by specs
345 following the `:' on the list. Ie, apply to all topics at level but
346 trailing ones accounted for by trailing specs. (Only the first of
347 multiple colons at the same level is honored -- later ones are ignored.)
348 * -- completely exposes the topic, including bodies
349 + -- exposes all subtopics, but not the bodies
350 - -- exposes the body of the corresponding topic, but not subtopics
351 LIST -- a nested layout spec, to be applied intricately to its
352 corresponding item(s)
356 Collapse the top-level topics to show their children and
357 grandchildren, but completely collapse the final top-level topic.
359 Close the first topic so only the immediate subtopics are shown,
360 leave the subsequent topics exposed as they are until the second
361 second to last topic, which is exposed at least one level, and
362 completely close the last topic.
364 Expose children and grandchildren of all topics at current
365 level except the last two; expose children of the second to
366 last and completely expose the last one, including its subtopics.
368 See `allout-expose-topic' for more about the exposure process.
370 Also, allout's mode-specific provisions will make topic prefixes default
371 to the comment-start string, if any, of the language of the file. This
372 is modulo the setting of `allout-use-mode-specific-leader', which see."
373 :type
'allout-layout-type
375 ;;;_ : allout-layout-type
376 (define-widget 'allout-layout-type
'lazy
377 "Allout layout format customization basic building blocks."
379 (choice (integer :tag
"integer (<= zero is strict)")
380 (const :tag
": (repeat prior)" :)
381 (const :tag
"* (completely expose)" *)
382 (const :tag
"+ (expose all offspring, headlines only)" +)
383 (const :tag
"- (expose topic body but not offspring)" -
)
384 (allout-layout-type :tag
"<Nested layout>"))))
386 ;;;_ = allout-inhibit-auto-fill
387 (defcustom allout-inhibit-auto-fill nil
388 "If non-nil, auto-fill will be inhibited in the allout buffers.
390 You can customize this setting to set it for all allout buffers, or set it
391 in individual buffers if you want to inhibit auto-fill only in particular
392 buffers. (You could use a function on `allout-mode-hook' to inhibit
393 auto-fill according, eg, to the major mode.)
395 If you don't set this and auto-fill-mode is enabled, allout will use the
396 value that `normal-auto-fill-function', if any, when allout mode starts, or
397 else allout's special hanging-indent maintaining auto-fill function,
401 (make-variable-buffer-local 'allout-inhibit-auto-fill
)
402 ;;;_ = allout-inhibit-auto-fill-on-headline
403 (defcustom allout-inhibit-auto-fill-on-headline nil
404 "If non-nil, auto-fill will be inhibited while on topic's header line."
407 (make-variable-buffer-local 'allout-inhibit-auto-fill-on-headline
)
408 ;;;_ = allout-use-hanging-indents
409 (defcustom allout-use-hanging-indents t
410 "If non-nil, topic body text auto-indent defaults to indent of the header.
411 Ie, it is indented to be just past the header prefix. This is
412 relevant mostly for use with `indented-text-mode', or other situations
413 where auto-fill occurs."
416 (make-variable-buffer-local 'allout-use-hanging-indents
)
418 (put 'allout-use-hanging-indents
'safe-local-variable
419 (if (fboundp 'booleanp
) 'booleanp
(lambda (x) (member x
'(t nil
)))))
420 ;;;_ = allout-reindent-bodies
421 (defcustom allout-reindent-bodies
(if allout-use-hanging-indents
423 "Non-nil enables auto-adjust of topic body hanging indent with depth shifts.
425 When active, topic body lines that are indented even with or beyond
426 their topic header are reindented to correspond with depth shifts of
429 A value of t enables reindent in non-programming-code buffers, ie
430 those that do not have the variable `comment-start' set. A value of
431 `force' enables reindent whether or not `comment-start' is set."
432 :type
'(choice (const nil
) (const t
) (const text
) (const force
))
435 (make-variable-buffer-local 'allout-reindent-bodies
)
437 (put 'allout-reindent-bodies
'safe-local-variable
438 (lambda (x) (memq x
'(nil t text force
))))
440 ;;;_ = allout-show-bodies
441 (defcustom allout-show-bodies nil
442 "If non-nil, show entire body when exposing a topic, rather than
446 (make-variable-buffer-local 'allout-show-bodies
)
448 (put 'allout-show-bodies
'safe-local-variable
449 (if (fboundp 'booleanp
) 'booleanp
(lambda (x) (member x
'(t nil
)))))
451 ;;;_ = allout-beginning-of-line-cycles
452 (defcustom allout-beginning-of-line-cycles t
453 "If non-nil, \\[allout-beginning-of-line] will cycle through smart-placement options.
455 Cycling only happens on when the command is repeated, not when it
456 follows a different command.
458 Smart-placement means that repeated calls to this function will
461 - if the cursor is on a non-headline body line and not on the first column:
462 then it goes to the first column
463 - if the cursor is on the first column of a non-headline body line:
464 then it goes to the start of the headline within the item body
465 - if the cursor is on the headline and not the start of the headline:
466 then it goes to the start of the headline
467 - if the cursor is on the start of the headline:
468 then it goes to the bullet character (for hotspot navigation)
469 - if the cursor is on the bullet character:
470 then it goes to the first column of that line (the headline)
471 - if the cursor is on the first column of the headline:
472 then it goes to the start of the headline within the item body.
474 In this fashion, you can use the beginning-of-line command to do
475 its normal job and then, when repeated, advance through the
476 entry, cycling back to start.
478 If this configuration variable is nil, then the cursor is just
479 advanced to the beginning of the line and remains there on
481 :type
'boolean
:group
'allout
)
482 ;;;_ = allout-end-of-line-cycles
483 (defcustom allout-end-of-line-cycles t
484 "If non-nil, \\[allout-end-of-line] will cycle through smart-placement options.
486 Cycling only happens on when the command is repeated, not when it
487 follows a different command.
489 Smart placement means that repeated calls to this function will
492 - if the cursor is not on the end-of-line,
493 then it goes to the end-of-line
494 - if the cursor is on the end-of-line but not the end-of-entry,
495 then it goes to the end-of-entry, exposing it if necessary
496 - if the cursor is on the end-of-entry,
497 then it goes to the end of the head line
499 In this fashion, you can use the end-of-line command to do its
500 normal job and then, when repeated, advance through the entry,
501 cycling back to start.
503 If this configuration variable is nil, then the cursor is just
504 advanced to the end of the line and remains there on repeated
506 :type
'boolean
:group
'allout
)
508 ;;;_ = allout-header-prefix
509 (defcustom allout-header-prefix
"."
510 ;; this string is treated as literal match. it will be `regexp-quote'd, so
511 ;; one cannot use regular expressions to match varying header prefixes.
512 "Leading string which helps distinguish topic headers.
514 Outline topic header lines are identified by a leading topic
515 header prefix, which mostly have the value of this var at their front.
516 Level 1 topics are exceptions. They consist of only a single
517 character, which is typically set to the `allout-primary-bullet'."
520 (make-variable-buffer-local 'allout-header-prefix
)
522 (put 'allout-header-prefix
'safe-local-variable
'stringp
)
523 ;;;_ = allout-primary-bullet
524 (defcustom allout-primary-bullet
"*"
525 "Bullet used for top-level outline topics.
527 Outline topic header lines are identified by a leading topic header
528 prefix, which is concluded by bullets that includes the value of this
529 var and the respective allout-*-bullets-string vars.
531 The value of an asterisk (`*') provides for backwards compatibility
532 with the original Emacs outline mode. See `allout-plain-bullets-string'
533 and `allout-distinctive-bullets-string' for the range of available
537 (make-variable-buffer-local 'allout-primary-bullet
)
539 (put 'allout-primary-bullet
'safe-local-variable
'stringp
)
540 ;;;_ = allout-plain-bullets-string
541 (defcustom allout-plain-bullets-string
".,"
542 "The bullets normally used in outline topic prefixes.
544 See `allout-distinctive-bullets-string' for the other kind of
547 DO NOT include the close-square-bracket, `]', as a bullet.
549 Outline mode has to be reactivated in order for changes to the value
550 of this var to take effect."
553 (make-variable-buffer-local 'allout-plain-bullets-string
)
555 (put 'allout-plain-bullets-string
'safe-local-variable
'stringp
)
556 ;;;_ = allout-distinctive-bullets-string
557 (defcustom allout-distinctive-bullets-string
"*+-=>()[{}&!?#%\"X@$~_\\:;^"
558 "Persistent outline header bullets used to distinguish special topics.
560 These bullets are distinguish topics with particular character.
561 They are not used by default in the topic creation routines, but
562 are offered as options when you modify topic creation with a
563 universal argument (\\[universal-argument]), or during rebulleting (\\[allout-rebullet-current-heading]).
565 Distinctive bullets are not cycled when topics are shifted or
566 otherwise automatically rebulleted, so their marking is
567 persistent until deliberately changed. Their significance is
568 purely by convention, however. Some conventions suggest
571 `(' - open paren -- an aside or incidental point
572 `?' - question mark -- uncertain or outright question
573 `!' - exclamation point/bang -- emphatic
574 `[' - open square bracket -- meta-note, about item instead of item's subject
575 `\"' - double quote -- a quotation or other citation
576 `=' - equal sign -- an assignment, some kind of definition
577 `^' - carat -- relates to something above
579 Some are more elusive, but their rationale may be recognizable:
581 `+' - plus -- pending consideration, completion
582 `_' - underscore -- done, completed
583 `&' - ampersand -- addendum, furthermore
585 \(Some other non-plain bullets have special meaning to the
586 software. By default:
588 `~' marks encryptable topics -- see `allout-topic-encryption-bullet'
589 `#' marks auto-numbered bullets -- see `allout-numbered-bullet'.)
591 See `allout-plain-bullets-string' for the standard, alternating
594 You must run `set-allout-regexp' in order for outline mode to
595 adopt changes of this value.
597 DO NOT include the close-square-bracket, `]', on either of the bullet
601 (make-variable-buffer-local 'allout-distinctive-bullets-string
)
603 (put 'allout-distinctive-bullets-string
'safe-local-variable
'stringp
)
605 ;;;_ = allout-use-mode-specific-leader
606 (defcustom allout-use-mode-specific-leader t
607 "When non-nil, use mode-specific topic-header prefixes.
609 Allout outline mode will use the mode-specific `allout-mode-leaders' or
610 comment-start string, if any, to lead the topic prefix string, so topic
611 headers look like comments in the programming language. It will also use
612 the comment-start string, with an '_' appended, for `allout-primary-bullet'.
614 String values are used as literals, not regular expressions, so
615 do not escape any regular-expression characters.
617 Value t means to first check for assoc value in `allout-mode-leaders'
618 alist, then use comment-start string, if any, then use default (`.').
619 \(See note about use of comment-start strings, below.)
621 Set to the symbol for either of `allout-mode-leaders' or
622 `comment-start' to use only one of them, respectively.
624 Value nil means to always use the default (`.') and leave
625 `allout-primary-bullet' unaltered.
627 comment-start strings that do not end in spaces are tripled in
628 the header-prefix, and an `_' underscore is tacked on the end, to
629 distinguish them from regular comment strings. comment-start
630 strings that do end in spaces are not tripled, but an underscore
631 is substituted for the space. [This presumes that the space is
632 for appearance, not comment syntax. You can use
633 `allout-mode-leaders' to override this behavior, when
635 :type
'(choice (const t
) (const nil
) string
636 (const allout-mode-leaders
)
637 (const comment-start
))
640 (put 'allout-use-mode-specific-leader
'safe-local-variable
641 (lambda (x) (or (memq x
'(t nil allout-mode-leaders comment-start
))
643 ;;;_ = allout-mode-leaders
644 (defvar allout-mode-leaders
'()
645 "Specific allout-prefix leading strings per major modes.
647 Use this if the mode's comment-start string isn't what you
648 prefer, or if the mode lacks a comment-start string. See
649 `allout-use-mode-specific-leader' for more details.
651 If you're constructing a string that will comment-out outline
652 structuring so it can be included in program code, append an extra
653 character, like an \"_\" underscore, to distinguish the lead string
654 from regular comments that start at the beginning-of-line.")
656 ;;;_ = allout-old-style-prefixes
657 (defcustom allout-old-style-prefixes nil
658 "When non-nil, use only old-and-crusty `outline-mode' `*' topic prefixes.
660 Non-nil restricts the topic creation and modification
661 functions to asterix-padded prefixes, so they look exactly
662 like the original Emacs-outline style prefixes.
664 Whatever the setting of this variable, both old and new style prefixes
665 are always respected by the topic maneuvering functions."
668 (make-variable-buffer-local 'allout-old-style-prefixes
)
670 (put 'allout-old-style-prefixes
'safe-local-variable
671 (if (fboundp 'booleanp
) 'booleanp
(lambda (x) (member x
'(t nil
)))))
672 ;;;_ = allout-stylish-prefixes -- alternating bullets
673 (defcustom allout-stylish-prefixes t
674 "Do fancy stuff with topic prefix bullets according to level, etc.
676 Non-nil enables topic creation, modification, and repositioning
677 functions to vary the topic bullet char (the char that marks the topic
678 depth) just preceding the start of the topic text) according to level.
679 Otherwise, only asterisks (`*') and distinctive bullets are used.
681 This is how an outline can look (but sans indentation) with stylish
686 . + One level 3 subtopic
687 . . One level 4 subtopic
688 . . A second 4 subtopic
689 . + Another level 3 subtopic
690 . #1 A numbered level 4 subtopic
692 . ! Another level 4 subtopic with a different distinctive bullet
693 . #4 And another numbered level 4 subtopic
695 This would be an outline with stylish prefixes inhibited (but the
696 numbered and other distinctive bullets retained):
700 . * One level 3 subtopic
701 . * One level 4 subtopic
702 . * A second 4 subtopic
703 . * Another level 3 subtopic
704 . #1 A numbered level 4 subtopic
706 . ! Another level 4 subtopic with a different distinctive bullet
707 . #4 And another numbered level 4 subtopic
709 Stylish and constant prefixes (as well as old-style prefixes) are
710 always respected by the topic maneuvering functions, regardless of
711 this variable setting.
713 The setting of this var is not relevant when `allout-old-style-prefixes'
717 (make-variable-buffer-local 'allout-stylish-prefixes
)
719 (put 'allout-stylish-prefixes
'safe-local-variable
720 (if (fboundp 'booleanp
) 'booleanp
(lambda (x) (member x
'(t nil
)))))
722 ;;;_ = allout-numbered-bullet
723 (defcustom allout-numbered-bullet
"#"
724 "String designating bullet of topics that have auto-numbering; nil for none.
726 Topics having this bullet have automatic maintenance of a sibling
727 sequence-number tacked on, just after the bullet. Conventionally set
728 to \"#\", you can set it to a bullet of your choice. A nil value
729 disables numbering maintenance."
730 :type
'(choice (const nil
) string
)
732 (make-variable-buffer-local 'allout-numbered-bullet
)
734 (put 'allout-numbered-bullet
'safe-local-variable
735 (if (fboundp 'string-or-null-p
)
737 (lambda (x) (or (stringp x
) (null x
)))))
738 ;;;_ = allout-file-xref-bullet
739 (defcustom allout-file-xref-bullet
"@"
740 "Bullet signifying file cross-references, for `allout-resolve-xref'.
742 Set this var to the bullet you want to use for file cross-references."
743 :type
'(choice (const nil
) string
)
746 (put 'allout-file-xref-bullet
'safe-local-variable
747 (if (fboundp 'string-or-null-p
)
749 (lambda (x) (or (stringp x
) (null x
)))))
750 ;;;_ = allout-presentation-padding
751 (defcustom allout-presentation-padding
2
752 "Presentation-format white-space padding factor, for greater indent."
756 (make-variable-buffer-local 'allout-presentation-padding
)
758 (put 'allout-presentation-padding
'safe-local-variable
'integerp
)
760 ;;;_ = allout-flattened-numbering-abbreviation
761 (define-obsolete-variable-alias 'allout-abbreviate-flattened-numbering
762 'allout-flattened-numbering-abbreviation
"24.1")
763 (defcustom allout-flattened-numbering-abbreviation nil
764 "If non-nil, `allout-flatten-exposed-to-buffer' abbreviates topic
765 numbers to minimal amount with some context. Otherwise, entire
766 numbers are always used."
770 ;;;_ + LaTeX formatting
771 ;;;_ - allout-number-pages
772 (defcustom allout-number-pages nil
773 "Non-nil turns on page numbering for LaTeX formatting of an outline."
776 ;;;_ - allout-label-style
777 (defcustom allout-label-style
"\\large\\bf"
778 "Font and size of labels for LaTeX formatting of an outline."
781 ;;;_ - allout-head-line-style
782 (defcustom allout-head-line-style
"\\large\\sl "
783 "Font and size of entries for LaTeX formatting of an outline."
786 ;;;_ - allout-body-line-style
787 (defcustom allout-body-line-style
" "
788 "Font and size of entries for LaTeX formatting of an outline."
791 ;;;_ - allout-title-style
792 (defcustom allout-title-style
"\\Large\\bf"
793 "Font and size of titles for LaTeX formatting of an outline."
797 (defcustom allout-title
'(or buffer-file-name
(buffer-name))
798 "Expression to be evaluated to determine the title for LaTeX
802 ;;;_ - allout-line-skip
803 (defcustom allout-line-skip
".05cm"
804 "Space between lines for LaTeX formatting of an outline."
808 (defcustom allout-indent
".3cm"
809 "LaTeX formatted depth-indent spacing."
813 ;;;_ + Topic encryption
814 ;;;_ = allout-encryption group
815 (defgroup allout-encryption nil
816 "Settings for topic encryption features of allout outliner."
818 ;;;_ = allout-topic-encryption-bullet
819 (defcustom allout-topic-encryption-bullet
"~"
820 "Bullet signifying encryption of the entry's body."
821 :type
'(choice (const nil
) string
)
823 :group
'allout-encryption
)
824 ;;;_ = allout-encrypt-unencrypted-on-saves
825 (defcustom allout-encrypt-unencrypted-on-saves t
826 "If non-nil, topics pending encryption are encrypted during buffer saves.
828 This prevents file-system exposure of un-encrypted contents of
829 items marked for encryption.
831 When non-nil, if the topic currently being edited is decrypted,
832 it will be encrypted for saving but automatically decrypted
833 before any subsequent user interaction, so it is once again clear
834 text for editing though the file system copy is encrypted.
836 \(Auto-saves are handled differently. Buffers with plain-text
837 exposed encrypted topics are exempted from auto saves until all
838 such topics are encrypted.)"
842 :group
'allout-encryption
)
843 (make-variable-buffer-local 'allout-encrypt-unencrypted-on-saves
)
844 (defvar allout-auto-save-temporarily-disabled nil
845 "True while topic encryption is pending and auto-saving was active.
847 The value of `buffer-saved-size' at the time of decryption is used,
848 for restoring when all encryptions are established.")
849 (defvar allout-just-did-undo nil
850 "True just after undo commands, until allout-post-command-business.")
851 (make-variable-buffer-local 'allout-just-did-undo
)
854 ;;;_ = allout-developer group
855 (defgroup allout-developer nil
856 "Allout settings developers care about, including topic encryption and more."
858 ;;;_ = allout-run-unit-tests-on-load
859 (defcustom allout-run-unit-tests-on-load nil
860 "When non-nil, unit tests will be run at end of loading the allout module.
862 Generally, allout code developers are the only ones who'll want to set this.
864 \(If set, this makes it an even better practice to exercise changes by
865 doing byte-compilation with a repeat count, so the file is loaded after
868 See `allout-run-unit-tests' to see what's run."
870 :group
'allout-developer
)
872 ;;;_ + Miscellaneous customization
874 ;;;_ = allout-enable-file-variable-adjustment
875 (defcustom allout-enable-file-variable-adjustment t
876 "If non-nil, some allout outline actions edit Emacs local file var text.
878 This can range from changes to existing entries, addition of new ones,
879 and creation of a new local variables section when necessary.
881 Emacs file variables adjustments are also inhibited if `enable-local-variables'
884 Operations potentially causing edits include allout encryption routines.
885 For details, see `allout-toggle-current-subtree-encryption's docstring."
888 (make-variable-buffer-local 'allout-enable-file-variable-adjustment
)
890 ;;;_* CODE -- no user customizations below.
892 ;;;_ #1 Internal Outline Formatting and Configuration
894 ;;;_ = allout-version
895 (defvar allout-version
"2.3"
896 "Version of currently loaded outline package. (allout.el)")
897 ;;;_ > allout-version
898 (defun allout-version (&optional here
)
899 "Return string describing the loaded outline version."
901 (let ((msg (concat "Allout Outline Mode v " allout-version
)))
902 (if here
(insert msg
))
905 ;;;_ : Mode activation (defined here because it's referenced early)
907 (defvar allout-mode nil
"Allout outline mode minor-mode flag.")
908 (make-variable-buffer-local 'allout-mode
)
909 ;;;_ = allout-layout nil
910 (defvar allout-layout nil
; LEAVE GLOBAL VALUE NIL -- see docstring.
911 "Buffer-specific setting for allout layout.
913 In buffers where this is non-nil (and if `allout-auto-activation'
914 has been customized to enable this behavior), `allout-mode' will be
915 automatically activated. The layout dictated by the value will be used to
916 set the initial exposure when `allout-mode' is activated.
918 \*You should not setq-default this variable non-nil unless you want every
919 visited file to be treated as an allout file.*
921 The value would typically be set by a file local variable. For
922 example, the following lines at the bottom of an Emacs Lisp file:
925 ;;;allout-layout: (0 : -1 -1 0)
928 dictate activation of `allout-mode' mode when the file is visited
929 \(presuming proper `allout-auto-activation' customization),
930 followed by the equivalent of `(allout-expose-topic 0 : -1 -1 0)'.
931 \(This is the layout used for the allout.el source file.)
933 `allout-default-layout' describes the specification format.
934 `allout-layout' can additionally have the value `t', in which
935 case the value of `allout-default-layout' is used.")
936 (make-variable-buffer-local 'allout-layout
)
938 (put 'allout-layout
'safe-local-variable
939 (lambda (x) (or (numberp x
) (listp x
) (memq x
'(: * + -
)))))
941 ;;;_ : Topic header format
943 (defvar allout-regexp
""
944 "*Regular expression to match the beginning of a heading line.
946 Any line whose beginning matches this regexp is considered a
947 heading. This var is set according to the user configuration vars
948 by `set-allout-regexp'.")
949 (make-variable-buffer-local 'allout-regexp
)
950 ;;;_ = allout-bullets-string
951 (defvar allout-bullets-string
""
952 "A string dictating the valid set of outline topic bullets.
954 This var should *not* be set by the user -- it is set by `set-allout-regexp',
955 and is produced from the elements of `allout-plain-bullets-string'
956 and `allout-distinctive-bullets-string'.")
957 (make-variable-buffer-local 'allout-bullets-string
)
958 ;;;_ = allout-bullets-string-len
959 (defvar allout-bullets-string-len
0
960 "Length of current buffers' `allout-plain-bullets-string'.")
961 (make-variable-buffer-local 'allout-bullets-string-len
)
962 ;;;_ = allout-depth-specific-regexp
963 (defvar allout-depth-specific-regexp
""
964 "*Regular expression to match a heading line prefix for a particular depth.
966 This expression is used to search for depth-specific topic
967 headers at depth 2 and greater. Use `allout-depth-one-regexp'
968 for to seek topics at depth one.
970 This var is set according to the user configuration vars by
971 `set-allout-regexp'. It is prepared with format strings for two
972 decimal numbers, which should each be one less than the depth of the
973 topic prefix to be matched.")
974 (make-variable-buffer-local 'allout-depth-specific-regexp
)
975 ;;;_ = allout-depth-one-regexp
976 (defvar allout-depth-one-regexp
""
977 "*Regular expression to match a heading line prefix for depth one.
979 This var is set according to the user configuration vars by
980 `set-allout-regexp'. It is prepared with format strings for two
981 decimal numbers, which should each be one less than the depth of the
982 topic prefix to be matched.")
983 (make-variable-buffer-local 'allout-depth-one-regexp
)
984 ;;;_ = allout-line-boundary-regexp
985 (defvar allout-line-boundary-regexp
()
986 "`allout-regexp' prepended with a newline for the search target.
988 This is properly set by `set-allout-regexp'.")
989 (make-variable-buffer-local 'allout-line-boundary-regexp
)
990 ;;;_ = allout-bob-regexp
991 (defvar allout-bob-regexp
()
992 "Like `allout-line-boundary-regexp', for headers at beginning of buffer.")
993 (make-variable-buffer-local 'allout-bob-regexp
)
994 ;;;_ = allout-header-subtraction
995 (defvar allout-header-subtraction
(1- (length allout-header-prefix
))
996 "Allout-header prefix length to subtract when computing topic depth.")
997 (make-variable-buffer-local 'allout-header-subtraction
)
998 ;;;_ = allout-plain-bullets-string-len
999 (defvar allout-plain-bullets-string-len
(length allout-plain-bullets-string
)
1000 "Length of `allout-plain-bullets-string', updated by `set-allout-regexp'.")
1001 (make-variable-buffer-local 'allout-plain-bullets-string-len
)
1003 ;;;_ = allout-doublecheck-at-and-shallower
1004 (defconst allout-doublecheck-at-and-shallower
3
1005 "Validate apparent topics of this depth and shallower as being non-aberrant.
1007 Verified with `allout-aberrant-container-p'. The usefulness of
1008 this check is limited to shallow depths, because the
1009 determination of aberrance is according to the mistaken item
1010 being followed by a legitimate item of excessively greater depth.
1012 The classic example of a mistaken item, for a standard allout
1013 outline configuration, is a body line that begins with an '...'
1014 ellipsis. This happens to contain a legitimate depth-2 header
1015 prefix, constituted by two '..' dots at the beginning of the
1016 line. The only thing that can distinguish it *in principle* from
1017 a legitimate one is if the following real header is at a depth
1018 that is discontinuous from the depth of 2 implied by the
1019 ellipsis, ie depth 4 or more. As the depth being tested gets
1020 greater, the likelihood of this kind of disqualification is
1021 lower, and the usefulness of this test is lower.
1023 Extending the depth of the doublecheck increases the amount it is
1024 applied, increasing the cost of the test - on casual estimation,
1025 for outlines with many deep topics, geometrically (O(n)?).
1026 Taken together with decreasing likelihood that the test will be
1027 useful at greater depths, more modest doublecheck limits are more
1028 suitably economical.")
1029 ;;;_ X allout-reset-header-lead (header-lead)
1030 (defun allout-reset-header-lead (header-lead)
1031 "Reset the leading string used to identify topic headers."
1032 (interactive "sNew lead string: ")
1033 (setq allout-header-prefix header-lead
)
1034 (setq allout-header-subtraction
(1- (length allout-header-prefix
)))
1035 (set-allout-regexp))
1036 ;;;_ X allout-lead-with-comment-string (header-lead)
1037 (defun allout-lead-with-comment-string (&optional header-lead
)
1038 "Set the topic-header leading string to specified string.
1040 Useful for encapsulating outline structure in programming
1041 language comments. Returns the leading string."
1044 (if (not (stringp header-lead
))
1045 (setq header-lead
(read-string
1046 "String prefix for topic headers: ")))
1047 (setq allout-reindent-bodies nil
)
1048 (allout-reset-header-lead header-lead
)
1050 ;;;_ > allout-infer-header-lead-and-primary-bullet ()
1051 (defun allout-infer-header-lead-and-primary-bullet ()
1052 "Determine appropriate `allout-header-prefix' and `allout-primary-bullet'.
1054 Works according to settings of:
1057 `allout-header-prefix' (default)
1058 `allout-use-mode-specific-leader'
1059 and `allout-mode-leaders'.
1061 Apply this via (re)activation of `allout-mode', rather than
1062 invoking it directly."
1063 (let* ((use-leader (and (boundp 'allout-use-mode-specific-leader
)
1064 (if (or (stringp allout-use-mode-specific-leader
)
1065 (memq allout-use-mode-specific-leader
1066 '(allout-mode-leaders
1069 allout-use-mode-specific-leader
1070 ;; Oops -- garbled value, equate with effect of t:
1074 ((not use-leader
) nil
)
1075 ;; Use the explicitly designated leader:
1076 ((stringp use-leader
) use-leader
)
1077 (t (or (and (memq use-leader
'(t allout-mode-leaders
))
1078 ;; Get it from outline mode leaders?
1079 (cdr (assq major-mode allout-mode-leaders
)))
1080 ;; ... didn't get from allout-mode-leaders...
1081 (and (memq use-leader
'(t comment-start
))
1083 ;; Use comment-start, maybe tripled, and with
1087 (substring comment-start
1088 (1- (length comment-start
))))
1089 ;; Use comment-start, sans trailing space:
1090 (substring comment-start
0 -
1)
1091 (concat comment-start comment-start comment-start
))
1092 ;; ... and append underscore, whichever:
1096 (setq allout-header-prefix leader
)
1097 (if (not allout-old-style-prefixes
)
1098 ;; setting allout-primary-bullet makes the top level topics use --
1099 ;; actually, be -- the special prefix:
1100 (setq allout-primary-bullet leader
))
1101 allout-header-prefix
)))
1102 (defalias 'allout-infer-header-lead
1103 'allout-infer-header-lead-and-primary-bullet
)
1104 ;;;_ > allout-infer-body-reindent ()
1105 (defun allout-infer-body-reindent ()
1106 "Determine proper setting for `allout-reindent-bodies'.
1108 Depends on default setting of `allout-reindent-bodies' (which see)
1109 and presence of setting for `comment-start', to tell whether the
1110 file is programming code."
1111 (if (and allout-reindent-bodies
1113 (not (eq 'force allout-reindent-bodies
)))
1114 (setq allout-reindent-bodies nil
)))
1115 ;;;_ > set-allout-regexp ()
1116 (defun set-allout-regexp ()
1117 "Generate proper topic-header regexp form for outline functions.
1119 Works with respect to `allout-plain-bullets-string' and
1120 `allout-distinctive-bullets-string'.
1122 Also refresh various data structures that hinge on the regexp."
1125 ;; Derive allout-bullets-string from user configured components:
1126 (setq allout-bullets-string
"")
1127 (let ((strings (list 'allout-plain-bullets-string
1128 'allout-distinctive-bullets-string
1129 'allout-primary-bullet
))
1136 (setq cur-len
(length (setq cur-string
(symbol-value (car strings
)))))
1137 (while (< index cur-len
)
1138 (setq cur-char
(aref cur-string index
))
1139 (setq allout-bullets-string
1140 (concat allout-bullets-string
1142 ; Single dash would denote a
1143 ; sequence, repeated denotes
1145 ((eq cur-char ?-
) "--")
1146 ; literal close-square-bracket
1147 ; doesn't work right in the
1149 ((eq cur-char ?\
]) "")
1150 (t (regexp-quote (char-to-string cur-char
))))))
1151 (setq index
(1+ index
)))
1152 (setq strings
(cdr strings
)))
1154 ;; Derive next for repeated use in allout-pending-bullet:
1155 (setq allout-plain-bullets-string-len
(length allout-plain-bullets-string
))
1156 (setq allout-header-subtraction
(1- (length allout-header-prefix
)))
1158 (let (new-part old-part formfeed-part
)
1159 (setq new-part
(concat "\\("
1160 (regexp-quote allout-header-prefix
)
1162 ;; already regexp-quoted in a custom way:
1163 "[" allout-bullets-string
"]"
1165 old-part
(concat "\\("
1166 (regexp-quote allout-primary-bullet
)
1168 (regexp-quote allout-header-prefix
)
1171 " ?[^" allout-primary-bullet
"]")
1172 formfeed-part
"\\(\^L\\)"
1174 allout-regexp
(concat new-part
1180 allout-line-boundary-regexp
(concat "\n" new-part
1186 allout-bob-regexp
(concat "\\`" new-part
1193 (setq allout-depth-specific-regexp
1194 (concat "\\(^\\|\\`\\)"
1197 ;; new-style spacers-then-bullet string:
1199 (allout-format-quote (regexp-quote allout-header-prefix
))
1201 "[" (allout-format-quote allout-bullets-string
) "]"
1204 ;; old-style all-bullets string, if primary not multi-char:
1205 (if (< 0 allout-header-subtraction
)
1208 (allout-format-quote
1209 (regexp-quote allout-primary-bullet
))
1210 (allout-format-quote
1211 (regexp-quote allout-primary-bullet
))
1212 (allout-format-quote
1213 (regexp-quote allout-primary-bullet
))
1215 ;; disqualify greater depths:
1217 (allout-format-quote allout-primary-bullet
)
1222 (setq allout-depth-one-regexp
1223 (concat "\\(^\\|\\`\\)"
1227 (regexp-quote allout-header-prefix
)
1228 ;; disqualify any bullet char following any amount of
1229 ;; intervening whitespace:
1231 (concat "[^ " allout-bullets-string
"]")
1233 (if (< 0 allout-header-subtraction
)
1234 ;; Need not support anything like the old
1235 ;; bullet style if the prefix is multi-char.
1238 (regexp-quote allout-primary-bullet
)
1239 ;; disqualify deeper primary-bullet sequences:
1240 "[^" allout-primary-bullet
"]"))
1244 (defvar allout-mode-exposure-menu
)
1245 (defvar allout-mode-editing-menu
)
1246 (defvar allout-mode-navigation-menu
)
1247 (defvar allout-mode-misc-menu
)
1248 (defun produce-allout-mode-menubar-entries ()
1250 (easy-menu-define allout-mode-exposure-menu
1251 allout-mode-map-value
1252 "Allout outline exposure menu."
1254 ["Show Entry" allout-show-current-entry t
]
1255 ["Show Children" allout-show-children t
]
1256 ["Show Subtree" allout-show-current-subtree t
]
1257 ["Hide Subtree" allout-hide-current-subtree t
]
1258 ["Hide Leaves" allout-hide-current-leaves t
]
1260 ["Show All" allout-show-all t
]))
1261 (easy-menu-define allout-mode-editing-menu
1262 allout-mode-map-value
1263 "Allout outline editing menu."
1265 ["Open Sibling" allout-open-sibtopic t
]
1266 ["Open Subtopic" allout-open-subtopic t
]
1267 ["Open Supertopic" allout-open-supertopic t
]
1269 ["Shift Topic In" allout-shift-in t
]
1270 ["Shift Topic Out" allout-shift-out t
]
1271 ["Rebullet Topic" allout-rebullet-topic t
]
1272 ["Rebullet Heading" allout-rebullet-current-heading t
]
1273 ["Number Siblings" allout-number-siblings t
]
1275 ["Toggle Topic Encryption"
1276 allout-toggle-current-subtree-encryption
1277 (> (allout-current-depth) 1)]))
1278 (easy-menu-define allout-mode-navigation-menu
1279 allout-mode-map-value
1280 "Allout outline navigation menu."
1282 ["Next Visible Heading" allout-next-visible-heading t
]
1283 ["Previous Visible Heading"
1284 allout-previous-visible-heading t
]
1286 ["Up Level" allout-up-current-level t
]
1287 ["Forward Current Level" allout-forward-current-level t
]
1288 ["Backward Current Level"
1289 allout-backward-current-level t
]
1291 ["Beginning of Entry"
1292 allout-beginning-of-current-entry t
]
1293 ["End of Entry" allout-end-of-entry t
]
1294 ["End of Subtree" allout-end-of-current-subtree t
]))
1295 (easy-menu-define allout-mode-misc-menu
1296 allout-mode-map-value
1297 "Allout outlines miscellaneous bindings."
1299 ["Version" allout-version t
]
1301 ["Duplicate Exposed" allout-copy-exposed-to-buffer t
]
1302 ["Duplicate Exposed, numbered"
1303 allout-flatten-exposed-to-buffer t
]
1304 ["Duplicate Exposed, indented"
1305 allout-indented-exposed-to-buffer t
]
1307 ["Set Header Lead" allout-reset-header-lead t
]
1308 ["Set New Exposure" allout-expose-topic t
])))
1309 ;;;_ : Allout Modal-Variables Utilities
1310 ;;;_ = allout-mode-prior-settings
1311 (defvar allout-mode-prior-settings nil
1312 "Internal `allout-mode' use; settings to be resumed on mode deactivation.
1314 See `allout-add-resumptions' and `allout-do-resumptions'.")
1315 (make-variable-buffer-local 'allout-mode-prior-settings
)
1316 ;;;_ > allout-add-resumptions (&rest pairs)
1317 (defun allout-add-resumptions (&rest pairs
)
1318 "Set name/value PAIRS.
1320 Old settings are preserved for later resumption using `allout-do-resumptions'.
1322 The new values are set as a buffer local. On resumption, the prior buffer
1323 scope of the variable is restored along with its value. If it was a void
1324 buffer-local value, then it is left as nil on resumption.
1326 The pairs are lists whose car is the name of the variable and car of the
1327 cdr is the new value: '(some-var some-value)'. The pairs can actually be
1328 triples, where the third element qualifies the disposition of the setting,
1329 as described further below.
1331 If the optional third element is the symbol 'extend, then the new value
1332 created by `cons'ing the second element of the pair onto the front of the
1335 If the optional third element is the symbol 'append, then the new value is
1336 extended from the existing one by `append'ing a list containing the second
1337 element of the pair onto the end of the existing value.
1339 Extension, and resumptions in general, should not be used for hook
1340 functions -- use the 'local mode of `add-hook' for that, instead.
1342 The settings are stored on `allout-mode-prior-settings'."
1344 (let* ((pair (pop pairs
))
1347 (qualifier (if (> (length pair
) 2)
1350 (if (not (symbolp name
))
1351 (error "Pair's name, %S, must be a symbol, not %s"
1352 name
(type-of name
)))
1353 (setq prior-value
(condition-case nil
1355 (void-variable nil
)))
1356 (when (not (assoc name allout-mode-prior-settings
))
1357 ;; Not already added as a resumption, create the prior setting entry.
1358 (if (local-variable-p name
(current-buffer))
1359 ;; is already local variable -- preserve the prior value:
1360 (push (list name prior-value
) allout-mode-prior-settings
)
1361 ;; wasn't local variable, indicate so for resumption by killing
1362 ;; local value, and make it local:
1363 (push (list name
) allout-mode-prior-settings
)
1364 (make-local-variable name
)))
1366 (cond ((eq qualifier
'extend
)
1367 (if (not (listp prior-value
))
1368 (error "extension of non-list prior value attempted")
1369 (set name
(cons value prior-value
))))
1370 ((eq qualifier
'append
)
1371 (if (not (listp prior-value
))
1372 (error "appending of non-list prior value attempted")
1373 (set name
(append prior-value
(list value
)))))
1374 (t (error "unrecognized setting qualifier `%s' encountered"
1376 (set name value
)))))
1377 ;;;_ > allout-do-resumptions ()
1378 (defun allout-do-resumptions ()
1379 "Resume all name/value settings registered by `allout-add-resumptions'.
1381 This is used when concluding allout-mode, to resume selected variables to
1382 their settings before allout-mode was started."
1384 (while allout-mode-prior-settings
1385 (let* ((pair (pop allout-mode-prior-settings
))
1387 (value-cell (cdr pair
)))
1388 (if (not value-cell
)
1389 ;; Prior value was global:
1390 (kill-local-variable name
)
1391 ;; Prior value was explicit:
1392 (set name
(car value-cell
))))))
1393 ;;;_ : Mode-specific incidentals
1394 ;;;_ > allout-unprotected (expr)
1395 (defmacro allout-unprotected
(expr)
1396 "Enable internal outline operations to alter invisible text."
1397 `(let ((inhibit-read-only (if (not buffer-read-only
) t
))
1398 (inhibit-field-text-motion t
))
1400 ;;;_ = allout-mode-hook
1401 (defvar allout-mode-hook nil
1402 "*Hook that's run when allout mode starts.")
1403 ;;;_ = allout-mode-deactivate-hook
1404 (defvar allout-mode-deactivate-hook nil
1405 "*Hook that's run when allout mode ends.")
1406 (define-obsolete-variable-alias 'allout-mode-deactivate-hook
1407 'allout-mode-off-hook
"24.1")
1408 ;;;_ = allout-exposure-category
1409 (defvar allout-exposure-category nil
1410 "Symbol for use as allout invisible-text overlay category.")
1411 ;;;_ = allout-exposure-change-hook
1412 (defvar allout-exposure-change-hook nil
1413 "*Hook that's run after allout outline subtree exposure changes.
1415 It is run at the conclusion of `allout-flag-region'.
1417 Functions on the hook must take three arguments:
1419 - FROM -- integer indicating the point at the start of the change.
1420 - TO -- integer indicating the point of the end of the change.
1421 - FLAG -- change mode: nil for exposure, otherwise concealment.
1423 This hook might be invoked multiple times by a single command.")
1424 ;;;_ = allout-structure-added-hook
1425 (defvar allout-structure-added-hook nil
1426 "*Hook that's run after addition of items to the outline.
1428 Functions on the hook should take two arguments:
1430 - NEW-START -- integer indicating position of start of the first new item.
1431 - NEW-END -- integer indicating position of end of the last new item.
1433 This hook might be invoked multiple times by a single command.")
1434 ;;;_ = allout-structure-deleted-hook
1435 (defvar allout-structure-deleted-hook nil
1436 "*Hook that's run after disciplined deletion of subtrees from the outline.
1438 Functions on the hook must take two arguments:
1440 - DEPTH -- integer indicating the depth of the subtree that was deleted.
1441 - REMOVED-FROM -- integer indicating the point where the subtree was removed.
1443 Some edits that remove or invalidate items may be missed by this hook:
1444 specifically edits that native allout routines do not control.
1446 This hook might be invoked multiple times by a single command.")
1447 ;;;_ = allout-structure-shifted-hook
1448 (defvar allout-structure-shifted-hook nil
1449 "*Hook that's run after shifting of items in the outline.
1451 Functions on the hook should take two arguments:
1453 - DEPTH-CHANGE -- integer indicating depth increase, negative for decrease
1454 - START -- integer indicating the start point of the shifted parent item.
1456 Some edits that shift items can be missed by this hook: specifically edits
1457 that native allout routines do not control.
1459 This hook might be invoked multiple times by a single command.")
1460 ;;;_ = allout-after-copy-or-kill-hook
1461 (defvar allout-after-copy-or-kill-hook nil
1462 "*Hook that's run after copying outline text.
1464 Functions on the hook should not require any arguments.")
1465 ;;;_ = allout-post-undo-hook
1466 (defvar allout-post-undo-hook nil
1467 "*Hook that's run after undo activity.
1469 The item that's current when the hook is run *may* be the one
1470 that was affected by the undo.
1472 Functions on the hook should not require any arguments.")
1473 ;;;_ = allout-outside-normal-auto-fill-function
1474 (defvar allout-outside-normal-auto-fill-function nil
1475 "Value of `normal-auto-fill-function' outside of allout mode.
1477 Used by `allout-auto-fill' to do the mandated `normal-auto-fill-function'
1478 wrapped within allout's automatic `fill-prefix' setting.")
1479 (make-variable-buffer-local 'allout-outside-normal-auto-fill-function
)
1480 ;;;_ = prevent redundant activation by desktop mode:
1481 (add-to-list 'desktop-minor-mode-handlers
'(allout-mode . nil
))
1482 ;;;_ = allout-passphrase-verifier-string
1483 (defvar allout-passphrase-verifier-string nil
1484 "Setting used to test solicited encryption passphrases against the one
1485 already associated with a file.
1487 It consists of an encrypted random string useful only to verify that a
1488 passphrase entered by the user is effective for decryption. The passphrase
1489 itself is \*not* recorded in the file anywhere, and the encrypted contents
1490 are random binary characters to avoid exposing greater susceptibility to
1493 The verifier string is retained as an Emacs file variable, as well as in
1494 the Emacs buffer state, if file variable adjustments are enabled. See
1495 `allout-enable-file-variable-adjustment' for details about that.")
1496 (make-variable-buffer-local 'allout-passphrase-verifier-string
)
1497 (make-obsolete 'allout-passphrase-verifier-string
1498 'allout-passphrase-verifier-string
"23.3")
1500 (put 'allout-passphrase-verifier-string
'safe-local-variable
'stringp
)
1501 ;;;_ = allout-passphrase-hint-string
1502 (defvar allout-passphrase-hint-string
""
1503 "Variable used to retain reminder string for file's encryption passphrase.
1505 See the description of `allout-passphrase-hint-handling' for details about how
1506 the reminder is deployed.
1508 The hint is retained as an Emacs file variable, as well as in the Emacs buffer
1509 state, if file variable adjustments are enabled. See
1510 `allout-enable-file-variable-adjustment' for details about that.")
1511 (make-variable-buffer-local 'allout-passphrase-hint-string
)
1512 (setq-default allout-passphrase-hint-string
"")
1513 (make-obsolete 'allout-passphrase-hint-string
1514 'allout-passphrase-hint-string
"23.3")
1516 (put 'allout-passphrase-hint-string
'safe-local-variable
'stringp
)
1517 ;;;_ = allout-after-save-decrypt
1518 (defvar allout-after-save-decrypt nil
1519 "Internal variable, is nil or has the value of two points:
1521 - the location of a topic to be decrypted after saving is done
1522 - where to situate the cursor after the decryption is performed
1524 This is used to decrypt the topic that was currently being edited, if it
1525 was encrypted automatically as part of a file write or autosave.")
1526 (make-variable-buffer-local 'allout-after-save-decrypt
)
1527 ;;;_ = allout-encryption-plaintext-sanitization-regexps
1528 (defvar allout-encryption-plaintext-sanitization-regexps nil
1529 "List of regexps whose matches are removed from plaintext before encryption.
1531 This is for the sake of removing artifacts, like escapes, that are added on
1532 and not actually part of the original plaintext. The removal is done just
1533 prior to encryption.
1535 Entries must be symbols that are bound to the desired values.
1537 Each value can be a regexp or a list with a regexp followed by a
1538 substitution string. If it's just a regexp, all its matches are removed
1539 before the text is encrypted. If it's a regexp and a substitution, the
1540 substitution is used against the regexp matches, a la `replace-match'.")
1541 (make-variable-buffer-local 'allout-encryption-text-removal-regexps
)
1542 ;;;_ = allout-encryption-ciphertext-rejection-regexps
1543 (defvar allout-encryption-ciphertext-rejection-regexps nil
1544 "Variable for regexps matching plaintext to remove before encryption.
1546 This is used to detect strings in encryption results that would
1547 register as allout mode structural elements, for example, as a
1550 Entries must be symbols that are bound to the desired regexp values.
1552 Encryptions that result in matches will be retried, up to
1553 `allout-encryption-ciphertext-rejection-limit' times, after which
1554 an error is raised.")
1556 (make-variable-buffer-local 'allout-encryption-ciphertext-rejection-regexps
)
1557 ;;;_ = allout-encryption-ciphertext-rejection-ceiling
1558 (defvar allout-encryption-ciphertext-rejection-ceiling
5
1559 "Limit on number of times encryption ciphertext is rejected.
1561 See `allout-encryption-ciphertext-rejection-regexps' for rejection reasons.")
1562 (make-variable-buffer-local 'allout-encryption-ciphertext-rejection-ceiling
)
1563 ;;;_ > allout-mode-p ()
1564 ;; Must define this macro above any uses, or byte compilation will lack
1565 ;; proper def, if file isn't loaded -- eg, during emacs build!
1567 (defmacro allout-mode-p
()
1568 "Return t if `allout-mode' is active in current buffer."
1570 ;;;_ > allout-write-contents-hook-handler ()
1571 (defun allout-write-contents-hook-handler ()
1572 "Implement `allout-encrypt-unencrypted-on-saves' for file writes
1574 Return nil if all goes smoothly, or else return an informative
1575 message if an error is encountered. The message will serve as a
1576 non-nil return on `write-contents-functions' to prevent saving of
1577 the buffer while it has decrypted content.
1579 This behavior depends on Emacs versions that implement the
1580 `write-contents-functions' hook."
1582 (if (or (not (allout-mode-p))
1583 (not (boundp 'allout-encrypt-unencrypted-on-saves
))
1584 (not allout-encrypt-unencrypted-on-saves
))
1586 (if (save-excursion (goto-char (point-min))
1587 (allout-next-topic-pending-encryption))
1589 (message "auto-encrypting pending topics")
1591 (condition-case failure
1593 (setq allout-after-save-decrypt
1594 (allout-encrypt-decrypted))
1595 ;; aok - return nil:
1598 ;; whoops - probably some still-decrypted items, return non-nil:
1599 (let ((text (format (concat "%s contents write inhibited due to"
1600 " encrypted topic encryption error:"
1602 (buffer-name (current-buffer))
1604 (message text
)(sit-for 2)
1607 ;;;_ > allout-after-saves-handler ()
1608 (defun allout-after-saves-handler ()
1609 "Decrypt topic encrypted for save, if it's currently being edited.
1611 Ie, if it was pending encryption and contained the point in its body before
1614 We use values stored in `allout-after-save-decrypt' to locate the topic
1615 and the place for the cursor after the decryption is done."
1616 (if (not (and (allout-mode-p)
1617 (boundp 'allout-after-save-decrypt
)
1618 allout-after-save-decrypt
))
1620 (goto-char (car allout-after-save-decrypt
))
1621 (let ((was-modified (buffer-modified-p)))
1622 (allout-toggle-subtree-encryption)
1623 (if (not was-modified
)
1624 (set-buffer-modified-p nil
)))
1625 (goto-char (cadr allout-after-save-decrypt
))
1626 (setq allout-after-save-decrypt nil
))
1628 ;;;_ > allout-called-interactively-p ()
1629 (defmacro allout-called-interactively-p
()
1630 "A version of `called-interactively-p' independent of Emacs version."
1631 ;; ... to ease maintenance of allout without betraying deprecation.
1632 (if (equal (subr-arity (symbol-function 'called-interactively-p
))
1634 '(called-interactively-p)
1635 '(called-interactively-p 'interactive
)))
1636 ;;;_ = allout-inhibit-aberrance-doublecheck nil
1637 ;; In some exceptional moments, disparate topic depths need to be allowed
1638 ;; momentarily, eg when one topic is being yanked into another and they're
1639 ;; about to be reconciled. let-binding allout-inhibit-aberrance-doublecheck
1640 ;; prevents the aberrance doublecheck to allow, eg, the reconciliation
1641 ;; processing to happen in the presence of such discrepancies. It should
1642 ;; almost never be needed, however.
1643 (defvar allout-inhibit-aberrance-doublecheck nil
1644 "Internal state, for momentarily inhibits aberrance doublecheck.
1646 This should only be momentarily let-bound non-nil, not set
1647 non-nil in a lasting way.")
1649 ;;;_ #2 Mode environment and activation
1650 ;;;_ = allout-explicitly-deactivated
1651 (defvar allout-explicitly-deactivated nil
1652 "If t, `allout-mode's last deactivation was deliberate.
1653 So `allout-post-command-business' should not reactivate it...")
1654 (make-variable-buffer-local 'allout-explicitly-deactivated
)
1655 ;;;_ > allout-init (mode)
1656 (defun allout-init (mode)
1657 "DEPRECATED - configure allout activation by customizing
1658 `allout-auto-activation'. This function remains around, limited
1659 from what it did before, for backwards compatibility.
1661 MODE is the activation mode - see `allout-auto-activation' for
1664 (custom-set-variables (list 'allout-auto-activation
(format "%s" mode
)))
1666 (make-obsolete 'allout-init
1667 "customize 'allout-auto-activation' instead." "23.3")
1668 ;;;_ > allout-setup-menubar ()
1669 (defun allout-setup-menubar ()
1670 "Populate the current buffer's menubar with `allout-mode' stuff."
1671 (let ((menus (list allout-mode-exposure-menu
1672 allout-mode-editing-menu
1673 allout-mode-navigation-menu
1674 allout-mode-misc-menu
))
1677 (setq cur
(car menus
)
1679 (easy-menu-add cur
))))
1680 ;;;_ > allout-overlay-preparations
1681 (defun allout-overlay-preparations ()
1682 "Set the properties of the allout invisible-text overlay and others."
1683 (setplist 'allout-exposure-category nil
)
1684 (put 'allout-exposure-category
'invisible
'allout
)
1685 (put 'allout-exposure-category
'evaporate t
)
1686 ;; ??? We use isearch-open-invisible *and* isearch-mode-end-hook. The
1687 ;; latter would be sufficient, but it seems that a separate behavior --
1688 ;; the _transient_ opening of invisible text during isearch -- is keyed to
1689 ;; presence of the isearch-open-invisible property -- even though this
1690 ;; property controls the isearch _arrival_ behavior. This is the case at
1691 ;; least in emacs 21, 22.1, and xemacs 21.4.
1692 (put 'allout-exposure-category
'isearch-open-invisible
1693 'allout-isearch-end-handler
)
1694 (if (featurep 'xemacs
)
1695 (put 'allout-exposure-category
'start-open t
)
1696 (put 'allout-exposure-category
'insert-in-front-hooks
1697 '(allout-overlay-insert-in-front-handler)))
1698 (put 'allout-exposure-category
'modification-hooks
1699 '(allout-overlay-interior-modification-handler)))
1700 ;;;_ > define-minor-mode allout-mode
1703 (define-minor-mode allout-mode
1705 "Toggle Allout outline mode.
1706 With a prefix argument ARG, enable Allout outline mode if ARG is
1707 positive, and disable it otherwise. If called from Lisp, enable
1708 the mode if ARG is omitted or nil.
1710 \\<allout-mode-map-value>
1711 Allout outline mode is a minor mode that provides extensive
1712 outline oriented formatting and manipulation. It enables
1713 structural editing of outlines, as well as navigation and
1714 exposure. It also is specifically aimed at accommodating
1715 syntax-sensitive text like programming languages. (For example,
1716 see the allout code itself, which is organized as an allout
1719 In addition to typical outline navigation and exposure, allout includes:
1721 - topic-oriented authoring, including keystroke-based topic creation,
1722 repositioning, promotion/demotion, cut, and paste
1723 - incremental search with dynamic exposure and reconcealment of hidden text
1724 - adjustable format, so programming code can be developed in outline-structure
1725 - easy topic encryption and decryption, symmetric or key-pair
1726 - \"Hot-spot\" operation, for single-keystroke maneuvering and exposure control
1727 - integral outline layout, for automatic initial exposure when visiting a file
1728 - independent extensibility, using comprehensive exposure and authoring hooks
1730 and many other features.
1732 Below is a description of the key bindings, and then description
1733 of special `allout-mode' features and terminology. See also the
1734 outline menubar additions for quick reference to many of the
1735 features. Customize `allout-auto-activation' to prepare your
1736 Emacs session for automatic activation of `allout-mode'.
1738 The bindings are those listed in `allout-prefixed-keybindings'
1739 and `allout-unprefixed-keybindings'. We recommend customizing
1740 `allout-command-prefix' to use just `\\C-c' as the command
1741 prefix, if the allout bindings don't conflict with any personal
1742 bindings you have on \\C-c. In any case, outline structure
1743 navigation and authoring is simplified by positioning the cursor
1744 on an item's bullet character, the \"hot-spot\" -- then you can
1745 invoke allout commands with just the un-prefixed,
1746 un-control-shifted command letters. This is described further in
1747 the HOT-SPOT Operation section.
1751 \\[allout-hide-current-subtree] `allout-hide-current-subtree'
1752 \\[allout-show-children] `allout-show-children'
1753 \\[allout-show-current-subtree] `allout-show-current-subtree'
1754 \\[allout-show-current-entry] `allout-show-current-entry'
1755 \\[allout-show-all] `allout-show-all'
1759 \\[allout-next-visible-heading] `allout-next-visible-heading'
1760 \\[allout-previous-visible-heading] `allout-previous-visible-heading'
1761 \\[allout-up-current-level] `allout-up-current-level'
1762 \\[allout-forward-current-level] `allout-forward-current-level'
1763 \\[allout-backward-current-level] `allout-backward-current-level'
1764 \\[allout-end-of-entry] `allout-end-of-entry'
1765 \\[allout-beginning-of-current-entry] `allout-beginning-of-current-entry' (alternately, goes to hot-spot)
1766 \\[allout-beginning-of-line] `allout-beginning-of-line' -- like regular beginning-of-line, but
1767 if immediately repeated cycles to the beginning of the current item
1768 and then to the hot-spot (if `allout-beginning-of-line-cycles' is set).
1771 Topic Header Production:
1772 -----------------------
1773 \\[allout-open-sibtopic] `allout-open-sibtopic' Create a new sibling after current topic.
1774 \\[allout-open-subtopic] `allout-open-subtopic' ... an offspring of current topic.
1775 \\[allout-open-supertopic] `allout-open-supertopic' ... a sibling of the current topic's parent.
1777 Topic Level and Prefix Adjustment:
1778 ---------------------------------
1779 \\[allout-shift-in] `allout-shift-in' Shift current topic and all offspring deeper
1780 \\[allout-shift-out] `allout-shift-out' ... less deep
1781 \\[allout-rebullet-current-heading] `allout-rebullet-current-heading' Prompt for alternate bullet for
1783 \\[allout-rebullet-topic] `allout-rebullet-topic' Reconcile bullets of topic and
1784 its offspring -- distinctive bullets are not changed, others
1785 are alternated according to nesting depth.
1786 \\[allout-number-siblings] `allout-number-siblings' Number bullets of topic and siblings --
1787 the offspring are not affected.
1788 With repeat count, revoke numbering.
1790 Topic-oriented Killing and Yanking:
1791 ----------------------------------
1792 \\[allout-kill-topic] `allout-kill-topic' Kill current topic, including offspring.
1793 \\[allout-copy-topic-as-kill] `allout-copy-topic-as-kill' Copy current topic, including offspring.
1794 \\[allout-kill-line] `allout-kill-line' Kill line, attending to outline structure.
1795 \\[allout-copy-line-as-kill] `allout-copy-line-as-kill' Copy line but don't delete it.
1796 \\[allout-yank] `allout-yank' Yank, adjusting depth of yanked topic to
1797 depth of heading if yanking into bare topic
1798 heading (ie, prefix sans text).
1799 \\[allout-yank-pop] `allout-yank-pop' Is to `allout-yank' as `yank-pop' is to `yank'.
1801 Topic-oriented Encryption:
1802 -------------------------
1803 \\[allout-toggle-current-subtree-encryption] `allout-toggle-current-subtree-encryption'
1804 Encrypt/Decrypt topic content
1808 M-x outlineify-sticky Activate outline mode for current buffer,
1809 and establish a default file-var setting
1810 for `allout-layout'.
1811 \\[allout-mark-topic] `allout-mark-topic'
1812 \\[allout-copy-exposed-to-buffer] `allout-copy-exposed-to-buffer'
1813 Duplicate outline, sans concealed text, to
1814 buffer with name derived from derived from that
1815 of current buffer -- \"*BUFFERNAME exposed*\".
1816 \\[allout-flatten-exposed-to-buffer] `allout-flatten-exposed-to-buffer'
1817 Like above 'copy-exposed', but convert topic
1818 prefixes to section.subsection... numeric
1820 \\[customize-variable] allout-auto-activation
1821 Prepare Emacs session for allout outline mode
1826 Outline mode supports gpg encryption of topics, with support for
1827 symmetric and key-pair modes, and auto-encryption of topics
1828 pending encryption on save.
1830 Topics pending encryption are, by default, automatically
1831 encrypted during file saves, including checkpoint saves, to avoid
1832 exposing the plain text of encrypted topics in the file system.
1833 If the content of the topic containing the cursor was encrypted
1834 for a save, it is automatically decrypted for continued editing.
1836 NOTE: A few GnuPG v2 versions improperly preserve incorrect
1837 symmetric decryption keys, preventing entry of the correct key on
1838 subsequent decryption attempts until the cache times-out. That
1839 can take several minutes. (Decryption of other entries is not
1840 affected.) Upgrade your EasyPG version, if you can, and you can
1841 deliberately clear your gpg-agent's cache by sending it a '-HUP'
1844 See `allout-toggle-current-subtree-encryption' function docstring
1845 and `allout-encrypt-unencrypted-on-saves' customization variable
1850 Hot-spot operation provides a means for easy, single-keystroke outline
1851 navigation and exposure control.
1853 When the text cursor is positioned directly on the bullet character of
1854 a topic, regular characters (a to z) invoke the commands of the
1855 corresponding allout-mode keymap control chars. For example, \"f\"
1856 would invoke the command typically bound to \"C-c<space>C-f\"
1857 \(\\[allout-forward-current-level] `allout-forward-current-level').
1859 Thus, by positioning the cursor on a topic bullet, you can
1860 execute the outline navigation and manipulation commands with a
1861 single keystroke. Regular navigation keys (eg, \\[forward-char], \\[next-line]) don't get
1862 this special translation, so you can use them to get out of the
1863 hot-spot and back to normal editing operation.
1865 In allout-mode, the normal beginning-of-line command (\\[allout-beginning-of-line]) is
1866 replaced with one that makes it easy to get to the hot-spot. If you
1867 repeat it immediately it cycles (if `allout-beginning-of-line-cycles'
1868 is set) to the beginning of the item and then, if you hit it again
1869 immediately, to the hot-spot. Similarly, `allout-beginning-of-current-entry'
1870 \(\\[allout-beginning-of-current-entry]) moves to the hot-spot when the cursor is already located
1871 at the beginning of the current entry.
1875 Allout exposure and authoring activites all have associated
1876 hooks, by which independent code can cooperate with allout
1877 without changes to the allout core. Here are key ones:
1880 `allout-mode-deactivate-hook' (deprecated)
1881 `allout-mode-off-hook'
1882 `allout-exposure-change-hook'
1883 `allout-structure-added-hook'
1884 `allout-structure-deleted-hook'
1885 `allout-structure-shifted-hook'
1886 `allout-after-copy-or-kill-hook'
1887 `allout-post-undo-hook'
1891 Topic hierarchy constituents -- TOPICS and SUBTOPICS:
1893 ITEM: A unitary outline element, including the HEADER and ENTRY text.
1894 TOPIC: An ITEM and any ITEMs contained within it, ie having greater DEPTH
1895 and with no intervening items of lower DEPTH than the container.
1897 The visible ITEM most immediately containing the cursor.
1898 DEPTH: The degree of nesting of an ITEM; it increases with containment.
1899 The DEPTH is determined by the HEADER PREFIX. The DEPTH is also
1901 LEVEL: The same as DEPTH.
1904 Those ITEMs whose TOPICs contain an ITEM.
1905 PARENT: An ITEM's immediate ANCESTOR. It has a DEPTH one less than that
1908 The ITEMs contained within an ITEM's TOPIC.
1910 An OFFSPRING of its ANCESTOR TOPICs.
1912 An immediate SUBTOPIC of its PARENT.
1914 TOPICs having the same PARENT and DEPTH.
1916 Topic text constituents:
1918 HEADER: The first line of an ITEM, include the ITEM PREFIX and HEADER
1920 ENTRY: The text content of an ITEM, before any OFFSPRING, but including
1921 the HEADER text and distinct from the ITEM PREFIX.
1922 BODY: Same as ENTRY.
1923 PREFIX: The leading text of an ITEM which distinguishes it from normal
1924 ENTRY text. Allout recognizes the outline structure according
1925 to the strict PREFIX format. It consists of a PREFIX-LEAD string,
1926 PREFIX-PADDING, and a BULLET. The BULLET might be followed by a
1927 number, indicating the ordinal number of the topic among its
1928 siblings, or an asterisk indicating encryption, plus an optional
1929 space. After that is the ITEM HEADER text, which is not part of
1932 The relative length of the PREFIX determines the nesting DEPTH
1935 The string at the beginning of a HEADER PREFIX, by default a `.'.
1936 It can be customized by changing the setting of
1937 `allout-header-prefix' and then reinitializing `allout-mode'.
1939 When the PREFIX-LEAD is set to the comment-string of a
1940 programming language, outline structuring can be embedded in
1941 program code without interfering with processing of the text
1942 (by Emacs or the language processor) as program code. This
1943 setting happens automatically when allout mode is used in
1944 programming-mode buffers. See `allout-use-mode-specific-leader'
1945 docstring for more detail.
1947 Spaces or asterisks which separate the PREFIX-LEAD and the
1948 bullet, determining the ITEM's DEPTH.
1949 BULLET: A character at the end of the ITEM PREFIX, it must be one of
1950 the characters listed on `allout-plain-bullets-string' or
1951 `allout-distinctive-bullets-string'. When creating a TOPIC,
1952 plain BULLETs are by default used, according to the DEPTH of the
1953 TOPIC. Choice among the distinctive BULLETs is offered when you
1954 provide a universal argument (\\[universal-argument]) to the
1955 TOPIC creation command, or when explicitly rebulleting a TOPIC. The
1956 significance of the various distinctive bullets is purely by
1957 convention. See the documentation for the above bullet strings for
1960 The state of a TOPIC which determines the on-screen visibility
1961 of its OFFSPRING and contained ENTRY text.
1963 TOPICs and ENTRY text whose EXPOSURE is inhibited. Concealed
1964 text is represented by \"...\" ellipses.
1966 CONCEALED TOPICs are effectively collapsed within an ANCESTOR.
1967 CLOSED: A TOPIC whose immediate OFFSPRING and body-text is CONCEALED.
1968 OPEN: A TOPIC that is not CLOSED, though its OFFSPRING or BODY may be."
1971 :keymap
'allout-mode-map
1973 (let ((use-layout (if (listp allout-layout
)
1975 allout-default-layout
)))
1977 (if (not (allout-mode-p))
1981 ; Activation not explicitly
1982 ; requested, and either in
1983 ; active state or *de*activation
1984 ; specifically requested:
1985 (allout-do-resumptions)
1987 (remove-from-invisibility-spec '(allout . t
))
1988 (remove-hook 'pre-command-hook
'allout-pre-command-business t
)
1989 (remove-hook 'post-command-hook
'allout-post-command-business t
)
1990 (remove-hook 'before-change-functions
'allout-before-change-handler t
)
1991 (remove-hook 'isearch-mode-end-hook
'allout-isearch-end-handler t
)
1992 (remove-hook 'write-contents-functions
1993 'allout-write-contents-hook-handler t
)
1995 (remove-overlays (point-min) (point-max)
1996 'category
'allout-exposure-category
))
1999 (if allout-old-style-prefixes
2000 ;; Inhibit all the fancy formatting:
2001 (allout-add-resumptions '(allout-primary-bullet "*")))
2003 (allout-overlay-preparations) ; Doesn't hurt to redo this.
2005 (allout-infer-header-lead-and-primary-bullet)
2006 (allout-infer-body-reindent)
2009 (allout-add-resumptions '(allout-encryption-ciphertext-rejection-regexps
2010 allout-line-boundary-regexp
2012 '(allout-encryption-ciphertext-rejection-regexps
2016 (allout-compose-and-institute-keymap)
2017 (produce-allout-mode-menubar-entries)
2019 (add-to-invisibility-spec '(allout . t
))
2021 (allout-add-resumptions '(line-move-ignore-invisible t
))
2022 (add-hook 'pre-command-hook
'allout-pre-command-business nil t
)
2023 (add-hook 'post-command-hook
'allout-post-command-business nil t
)
2024 (add-hook 'before-change-functions
'allout-before-change-handler nil t
)
2025 (add-hook 'isearch-mode-end-hook
'allout-isearch-end-handler nil t
)
2026 (add-hook 'write-contents-functions
'allout-write-contents-hook-handler
2029 ;; Stash auto-fill settings and adjust so custom allout auto-fill
2030 ;; func will be used if auto-fill is active or activated. (The
2031 ;; custom func respects topic headline, maintains hanging-indents,
2033 (allout-add-resumptions (list 'allout-former-auto-filler
2035 ;; Register allout-auto-fill to be used if
2036 ;; filling is active:
2037 (list 'allout-outside-normal-auto-fill-function
2038 normal-auto-fill-function
)
2039 '(normal-auto-fill-function allout-auto-fill
)
2040 ;; Paragraphs are broken by topic headlines.
2041 (list 'paragraph-start
2042 (concat paragraph-start
"\\|^\\("
2043 allout-regexp
"\\)"))
2044 (list 'paragraph-separate
2045 (concat paragraph-separate
"\\|^\\("
2046 allout-regexp
"\\)")))
2047 (if (and auto-fill-function
(not allout-inhibit-auto-fill
))
2048 ;; allout-auto-fill will use the stashed values and so forth.
2049 (allout-add-resumptions '(auto-fill-function allout-auto-fill
)))
2051 (allout-setup-menubar)
2053 ;; Do auto layout if warranted:
2054 (when (and allout-layout
2055 allout-auto-activation
2057 (and (not (string= allout-auto-activation
"activate"))
2058 (if (string= allout-auto-activation
"ask")
2059 (if (y-or-n-p (format "Expose %s with layout '%s'? "
2063 (message "Skipped %s layout." (buffer-name))
2067 (message "Adjusting '%s' exposure..." (buffer-name))
2069 (allout-this-or-next-heading)
2072 (apply 'allout-expose-topic
(list use-layout
))
2073 (message "Adjusting '%s' exposure... done."
2075 ;; Problem applying exposure -- notify user, but don't
2076 ;; interrupt, eg, file visit:
2077 (error (message "%s" (car (cdr err
)))
2079 ) ; when allout-layout
2080 ) ; if (allout-mode-p)
2082 ) ; define-minor-mode
2083 ;;;_ > allout-minor-mode alias
2084 (defalias 'allout-minor-mode
'allout-mode
)
2085 ;;;_ > allout-unload-function
2086 (defun allout-unload-function ()
2087 "Unload the allout outline library."
2088 (save-current-buffer
2089 (dolist (buffer (buffer-list))
2091 (when (allout-mode-p) (allout-mode -
1))))
2092 ;; continue standard unloading
2095 ;;;_ - Position Assessment
2096 ;;;_ > allout-hidden-p (&optional pos)
2097 (defsubst allout-hidden-p
(&optional pos
)
2098 "Non-nil if the character after point was made invisible by allout."
2099 (eq (get-char-property (or pos
(point)) 'invisible
) 'allout
))
2101 ;;;_ > allout-overlay-insert-in-front-handler (ol after beg end
2102 ;;; &optional prelen)
2103 (defun allout-overlay-insert-in-front-handler (ol after beg end
2105 "Shift the overlay so stuff inserted in front of it is excluded."
2107 ;; ??? Shouldn't moving the overlay should be unnecessary, if overlay
2108 ;; front-advance on the overlay worked as expected?
2109 (move-overlay ol
(1+ beg
) (overlay-end ol
))))
2110 ;;;_ > allout-overlay-interior-modification-handler (ol after beg end
2111 ;;; &optional prelen)
2112 (defun allout-overlay-interior-modification-handler (ol after beg end
2114 "Get confirmation before making arbitrary changes to invisible text.
2116 We expose the invisible text and ask for confirmation. Refusal or
2117 `keyboard-quit' abandons the changes, with keyboard-quit additionally
2118 reclosing the opened text.
2120 No confirmation is necessary when `inhibit-read-only' is set -- eg, allout
2121 internal functions use this feature cohesively bunch changes."
2123 (when (and (not inhibit-read-only
) (not after
))
2124 (let ((start (point))
2125 (ol-start (overlay-start ol
))
2126 (ol-end (overlay-end ol
))
2129 (while (< (point) end
)
2130 (when (allout-hidden-p)
2131 (allout-show-to-offshoot)
2132 (if (allout-hidden-p)
2133 (save-excursion (forward-char 1)
2134 (allout-show-to-offshoot)))
2136 (setq first
(point))))
2137 (goto-char (if (featurep 'xemacs
)
2138 (next-property-change (1+ (point)) nil end
)
2139 (next-char-property-change (1+ (point)) end
))))
2145 (substitute-command-keys
2146 (concat "Modify concealed text? (\"no\" just aborts,"
2147 " \\[keyboard-quit] also reconceals) "))))
2148 (progn (goto-char start
)
2149 (error "Concealed-text change refused")))
2150 (quit (allout-flag-region ol-start ol-end nil
)
2151 (allout-flag-region ol-start ol-end t
)
2152 (error "Concealed-text change abandoned, text reconcealed"))))
2153 (goto-char start
))))
2154 ;;;_ > allout-before-change-handler (beg end)
2155 (defun allout-before-change-handler (beg end
)
2156 "Protect against changes to invisible text.
2158 See `allout-overlay-interior-modification-handler' for details."
2160 (when (and (allout-mode-p) undo-in-progress
)
2161 (setq allout-just-did-undo t
)
2162 (if (allout-hidden-p)
2163 (allout-show-children)))
2165 ;; allout-overlay-interior-modification-handler on an overlay handles
2166 ;; this in other emacs, via `allout-exposure-category's 'modification-hooks.
2167 (when (and (featurep 'xemacs
) (allout-mode-p))
2168 ;; process all of the pending overlays:
2171 (let ((overlay (allout-get-invisibility-overlay)))
2173 (allout-overlay-interior-modification-handler
2174 overlay nil beg end nil
))))))
2175 ;;;_ > allout-isearch-end-handler (&optional overlay)
2176 (defun allout-isearch-end-handler (&optional overlay
)
2177 "Reconcile allout outline exposure on arriving in hidden text after isearch.
2179 Optional OVERLAY parameter is for when this function is used by
2180 `isearch-open-invisible' overlay property. It is otherwise unused, so this
2181 function can also be used as an `isearch-mode-end-hook'."
2183 (if (and (allout-mode-p) (allout-hidden-p))
2184 (allout-show-to-offshoot)))
2186 ;;;_ #3 Internal Position State-Tracking -- "allout-recent-*" funcs
2187 ;; All the basic outline functions that directly do string matches to
2188 ;; evaluate heading prefix location set the variables
2189 ;; `allout-recent-prefix-beginning' and `allout-recent-prefix-end'
2190 ;; when successful. Functions starting with `allout-recent-' all
2191 ;; use this state, providing the means to avoid redundant searches
2192 ;; for just-established data. This optimization can provide
2193 ;; significant speed improvement, but it must be employed carefully.
2194 ;;;_ = allout-recent-prefix-beginning
2195 (defvar allout-recent-prefix-beginning
0
2196 "Buffer point of the start of the last topic prefix encountered.")
2197 (make-variable-buffer-local 'allout-recent-prefix-beginning
)
2198 ;;;_ = allout-recent-prefix-end
2199 (defvar allout-recent-prefix-end
0
2200 "Buffer point of the end of the last topic prefix encountered.")
2201 (make-variable-buffer-local 'allout-recent-prefix-end
)
2202 ;;;_ = allout-recent-depth
2203 (defvar allout-recent-depth
0
2204 "Depth of the last topic prefix encountered.")
2205 (make-variable-buffer-local 'allout-recent-depth
)
2206 ;;;_ = allout-recent-end-of-subtree
2207 (defvar allout-recent-end-of-subtree
0
2208 "Buffer point last returned by `allout-end-of-current-subtree'.")
2209 (make-variable-buffer-local 'allout-recent-end-of-subtree
)
2210 ;;;_ > allout-prefix-data ()
2211 (defsubst allout-prefix-data
()
2212 "Register allout-prefix state data.
2214 For reference by `allout-recent' funcs. Return
2215 the new value of `allout-recent-prefix-beginning'."
2216 (setq allout-recent-prefix-end
(or (match-end 1) (match-end 2) (match-end 3))
2217 allout-recent-prefix-beginning
(or (match-beginning 1)
2219 (match-beginning 3))
2220 allout-recent-depth
(max 1 (- allout-recent-prefix-end
2221 allout-recent-prefix-beginning
2222 allout-header-subtraction
)))
2223 allout-recent-prefix-beginning
)
2224 ;;;_ > nullify-allout-prefix-data ()
2225 (defsubst nullify-allout-prefix-data
()
2226 "Mark allout prefix data as being uninformative."
2227 (setq allout-recent-prefix-end
(point)
2228 allout-recent-prefix-beginning
(point)
2229 allout-recent-depth
0)
2230 allout-recent-prefix-beginning
)
2231 ;;;_ > allout-recent-depth ()
2232 (defsubst allout-recent-depth
()
2233 "Return depth of last heading encountered by an outline maneuvering function.
2235 All outline functions which directly do string matches to assess
2236 headings set the variables `allout-recent-prefix-beginning' and
2237 `allout-recent-prefix-end' if successful. This function uses those settings
2238 to return the current depth."
2240 allout-recent-depth
)
2241 ;;;_ > allout-recent-prefix ()
2242 (defsubst allout-recent-prefix
()
2243 "Like `allout-recent-depth', but returns text of last encountered prefix.
2245 All outline functions which directly do string matches to assess
2246 headings set the variables `allout-recent-prefix-beginning' and
2247 `allout-recent-prefix-end' if successful. This function uses those settings
2248 to return the current prefix."
2249 (buffer-substring-no-properties allout-recent-prefix-beginning
2250 allout-recent-prefix-end
))
2251 ;;;_ > allout-recent-bullet ()
2252 (defmacro allout-recent-bullet
()
2253 "Like `allout-recent-prefix', but returns bullet of last encountered prefix.
2255 All outline functions which directly do string matches to assess
2256 headings set the variables `allout-recent-prefix-beginning' and
2257 `allout-recent-prefix-end' if successful. This function uses those settings
2258 to return the current depth of the most recently matched topic."
2259 '(buffer-substring-no-properties (1- allout-recent-prefix-end
)
2260 allout-recent-prefix-end
))
2264 ;;;_ - Position Assessment
2265 ;;;_ : Location Predicates
2266 ;;;_ > allout-do-doublecheck ()
2267 (defsubst allout-do-doublecheck
()
2268 "True if current item conditions qualify for checking on topic aberrance."
2270 ;; presume integrity of outline and yanked content during yank -- necessary
2271 ;; to allow for level disparity of yank location and yanked text:
2272 (not allout-inhibit-aberrance-doublecheck
)
2273 ;; allout-doublecheck-at-and-shallower is ceiling for doublecheck:
2274 (<= allout-recent-depth allout-doublecheck-at-and-shallower
)))
2275 ;;;_ > allout-aberrant-container-p ()
2276 (defun allout-aberrant-container-p ()
2277 "True if topic, or next sibling with children, contains them discontinuously.
2279 Discontinuous means an immediate offspring that is nested more
2280 than one level deeper than the topic.
2282 If topic has no offspring, then the next sibling with offspring will
2283 determine whether or not this one is determined to be aberrant.
2285 If true, then the allout-recent-* settings are calibrated on the
2286 offspring that qualifies it as aberrant, ie with depth that
2287 exceeds the topic by more than one."
2289 ;; This is most clearly understood when considering standard-prefix-leader
2290 ;; low-level topics, which can all too easily match text not intended as
2291 ;; headers. For example, any line with a leading '.' or '*' and lacking a
2292 ;; following bullet qualifies without this protection. (A sequence of
2293 ;; them can occur naturally, eg a typical textual bullet list.) We
2294 ;; disqualify such low-level sequences when they are followed by a
2295 ;; discontinuously contained child, inferring that the sequences are not
2296 ;; actually connected with their prospective context.
2298 (let ((depth (allout-depth))
2299 (start-point (point))
2303 (while (and (not done
)
2304 (re-search-forward allout-line-boundary-regexp nil
0))
2305 (allout-prefix-data)
2306 (goto-char allout-recent-prefix-beginning
)
2308 ;; sibling -- continue:
2309 ((eq allout-recent-depth depth
))
2310 ;; first offspring is excessive -- aberrant:
2311 ((> allout-recent-depth
(1+ depth
))
2312 (setq done t aberrant t
))
2313 ;; next non-sibling is lower-depth -- not aberrant:
2314 (t (setq done t
))))))
2317 (goto-char start-point
)
2318 ;; recalibrate allout-recent-*
2321 ;;;_ > allout-on-current-heading-p ()
2322 (defun allout-on-current-heading-p ()
2323 "Return non-nil if point is on current visible topics' header line.
2325 Actually, returns prefix beginning point."
2327 (allout-beginning-of-current-line)
2329 (and (looking-at allout-regexp
)
2330 (allout-prefix-data)
2331 (or (not (allout-do-doublecheck))
2332 (not (allout-aberrant-container-p)))))))
2333 ;;;_ > allout-on-heading-p ()
2334 (defalias 'allout-on-heading-p
'allout-on-current-heading-p
)
2335 ;;;_ > allout-e-o-prefix-p ()
2336 (defun allout-e-o-prefix-p ()
2337 "True if point is located where current topic prefix ends, heading begins."
2338 (and (save-match-data
2339 (save-excursion (let ((inhibit-field-text-motion t
))
2340 (beginning-of-line))
2341 (looking-at allout-regexp
))
2342 (= (point) (save-excursion (allout-end-of-prefix)(point))))))
2343 ;;;_ : Location attributes
2344 ;;;_ > allout-depth ()
2345 (defun allout-depth ()
2346 "Return depth of topic most immediately containing point.
2348 Does not do doublecheck for aberrant topic header.
2350 Return zero if point is not within any topic.
2352 Like `allout-current-depth', but respects hidden as well as visible topics."
2354 (let ((start-point (point)))
2355 (if (and (allout-goto-prefix)
2356 (not (< start-point
(point))))
2359 ;; Oops, no prefix, nullify it:
2360 (nullify-allout-prefix-data)
2361 ;; ... and return 0:
2363 ;;;_ > allout-current-depth ()
2364 (defun allout-current-depth ()
2365 "Return depth of visible topic most immediately containing point.
2367 Return zero if point is not within any topic."
2369 (if (allout-back-to-current-heading)
2371 (- allout-recent-prefix-end
2372 allout-recent-prefix-beginning
2373 allout-header-subtraction
))
2375 ;;;_ > allout-get-current-prefix ()
2376 (defun allout-get-current-prefix ()
2377 "Topic prefix of the current topic."
2379 (if (allout-goto-prefix)
2380 (allout-recent-prefix))))
2381 ;;;_ > allout-get-bullet ()
2382 (defun allout-get-bullet ()
2383 "Return bullet of containing topic (visible or not)."
2385 (and (allout-goto-prefix)
2386 (allout-recent-bullet))))
2387 ;;;_ > allout-current-bullet ()
2388 (defun allout-current-bullet ()
2389 "Return bullet of current (visible) topic heading, or none if none found."
2392 (allout-back-to-current-heading)
2393 (buffer-substring-no-properties (- allout-recent-prefix-end
1)
2394 allout-recent-prefix-end
))
2395 ;; Quick and dirty provision, ostensibly for missing bullet:
2396 (args-out-of-range nil
))
2398 ;;;_ > allout-get-prefix-bullet (prefix)
2399 (defun allout-get-prefix-bullet (prefix)
2400 "Return the bullet of the header prefix string PREFIX."
2401 ;; Doesn't make sense if we're old-style prefixes, but this just
2402 ;; oughtn't be called then, so forget about it...
2403 (if (string-match allout-regexp prefix
)
2404 (substring prefix
(1- (match-end 2)) (match-end 2))))
2405 ;;;_ > allout-sibling-index (&optional depth)
2406 (defun allout-sibling-index (&optional depth
)
2407 "Item number of this prospective topic among its siblings.
2409 If optional arg DEPTH is greater than current depth, then we're
2410 opening a new level, and return 0.
2412 If less than this depth, ascend to that depth and count..."
2415 (cond ((and depth
(<= depth
0) 0))
2416 ((or (null depth
) (= depth
(allout-depth)))
2418 (while (allout-previous-sibling allout-recent-depth nil
)
2419 (setq index
(1+ index
)))
2421 ((< depth allout-recent-depth
)
2422 (allout-ascend-to-depth depth
)
2423 (allout-sibling-index))
2425 ;;;_ > allout-topic-flat-index ()
2426 (defun allout-topic-flat-index ()
2427 "Return a list indicating point's numeric section.subsect.subsubsect...
2428 Outermost is first."
2429 (let* ((depth (allout-depth))
2430 (next-index (allout-sibling-index depth
))
2432 (while (> next-index
0)
2433 (setq rev-sibls
(cons next-index rev-sibls
))
2434 (setq depth
(1- depth
))
2435 (setq next-index
(allout-sibling-index depth
)))
2439 ;;;_ - Navigation routines
2440 ;;;_ > allout-beginning-of-current-line ()
2441 (defun allout-beginning-of-current-line ()
2442 "Like beginning of line, but to visible text."
2444 ;; This combination of move-beginning-of-line and beginning-of-line is
2445 ;; deliberate, but the (beginning-of-line) may now be superfluous.
2446 (let ((inhibit-field-text-motion t
))
2447 (move-beginning-of-line 1)
2449 (while (and (not (bobp)) (or (not (bolp)) (allout-hidden-p)))
2451 (if (or (allout-hidden-p) (not (bolp)))
2452 (forward-char -
1)))))
2453 ;;;_ > allout-end-of-current-line ()
2454 (defun allout-end-of-current-line ()
2455 "Move to the end of line, past concealed text if any."
2456 ;; This is for symmetry with `allout-beginning-of-current-line' --
2457 ;; `move-end-of-line' doesn't suffer the same problem as
2458 ;; `move-beginning-of-line'.
2459 (let ((inhibit-field-text-motion t
))
2461 (while (allout-hidden-p)
2463 (if (allout-hidden-p) (forward-char 1)))))
2464 ;;;_ > allout-beginning-of-line ()
2465 (defun allout-beginning-of-line ()
2466 "Beginning-of-line with `allout-beginning-of-line-cycles' behavior, if set."
2470 (if (or (not allout-beginning-of-line-cycles
)
2471 (not (equal last-command this-command
)))
2473 (if (and (not (bolp))
2474 (allout-hidden-p (1- (point))))
2475 (goto-char (allout-previous-single-char-property-change
2476 (1- (point)) 'invisible
)))
2477 (move-beginning-of-line 1))
2479 (let ((beginning-of-body
2481 (while (and (allout-do-doublecheck)
2482 (allout-aberrant-container-p)
2483 (allout-previous-visible-heading 1)))
2484 (allout-beginning-of-current-entry)
2486 (cond ((= (current-column) 0)
2487 (goto-char beginning-of-body
))
2488 ((< (point) beginning-of-body
)
2489 (allout-beginning-of-current-line))
2490 ((= (point) beginning-of-body
)
2491 (goto-char (allout-current-bullet-pos)))
2492 (t (allout-beginning-of-current-line)
2493 (if (< (point) beginning-of-body
)
2494 ;; we were on the headline after its start:
2495 (goto-char beginning-of-body
)))))))
2496 ;;;_ > allout-end-of-line ()
2497 (defun allout-end-of-line ()
2498 "End-of-line with `allout-end-of-line-cycles' behavior, if set."
2502 (if (or (not allout-end-of-line-cycles
)
2503 (not (equal last-command this-command
)))
2504 (allout-end-of-current-line)
2505 (let ((end-of-entry (save-excursion
2506 (allout-end-of-entry)
2509 (allout-end-of-current-line))
2510 ((or (allout-hidden-p) (save-excursion
2513 (allout-back-to-current-heading)
2514 (allout-show-current-entry)
2515 (allout-show-children)
2516 (allout-end-of-entry))
2517 ((>= (point) end-of-entry
)
2518 (allout-back-to-current-heading)
2519 (allout-end-of-current-line))
2521 (if (not (allout-mark-active-p))
2523 (allout-end-of-entry))))))
2524 ;;;_ > allout-mark-active-p ()
2525 (defun allout-mark-active-p ()
2526 "True if the mark is currently or always active."
2527 ;; `(cond (boundp...))' (or `(if ...)') invokes special byte-compiler
2528 ;; provisions, at least in GNU Emacs to prevent warnings about lack of,
2529 ;; eg, region-active-p.
2530 (cond ((boundp 'mark-active
)
2532 ((fboundp 'region-active-p
)
2535 ;;;_ > allout-next-heading ()
2536 (defsubst allout-next-heading
()
2537 "Move to the heading for the topic (possibly invisible) after this one.
2539 Returns the location of the heading, or nil if none found.
2541 We skip anomalous low-level topics, a la `allout-aberrant-container-p'."
2544 (if (looking-at allout-regexp
)
2547 (when (re-search-forward allout-line-boundary-regexp nil
0)
2548 (allout-prefix-data)
2549 (goto-char allout-recent-prefix-beginning
)
2552 (and (allout-do-doublecheck)
2553 ;; this will set allout-recent-* on the first non-aberrant topic,
2554 ;; whether it's the current one or one that disqualifies it:
2555 (allout-aberrant-container-p))
2556 ;; this may or may not be the same as above depending on doublecheck:
2557 (goto-char allout-recent-prefix-beginning
))))
2558 ;;;_ > allout-this-or-next-heading
2559 (defun allout-this-or-next-heading ()
2560 "Position cursor on current or next heading."
2561 ;; A throwaway non-macro that is defined after allout-next-heading
2562 ;; and usable by allout-mode.
2563 (if (not (allout-goto-prefix-doublechecked)) (allout-next-heading)))
2564 ;;;_ > allout-previous-heading ()
2565 (defun allout-previous-heading ()
2566 "Move to the prior (possibly invisible) heading line.
2568 Return the location of the beginning of the heading, or nil if not found.
2570 We skip anomalous low-level topics, a la `allout-aberrant-container-p'."
2574 (let ((start-point (point)))
2575 ;; allout-goto-prefix-doublechecked calls us, so we can't use it here.
2576 (allout-goto-prefix)
2578 (when (or (re-search-backward allout-line-boundary-regexp nil
0)
2579 (looking-at allout-bob-regexp
))
2580 (goto-char (allout-prefix-data))
2581 (if (and (allout-do-doublecheck)
2582 (allout-aberrant-container-p))
2583 (or (allout-previous-heading)
2584 (and (goto-char start-point
)
2585 ;; recalibrate allout-recent-*:
2589 ;;;_ > allout-get-invisibility-overlay ()
2590 (defun allout-get-invisibility-overlay ()
2591 "Return the overlay at point that dictates allout invisibility."
2592 (let ((overlays (overlays-at (point)))
2594 (while (and overlays
(not got
))
2595 (if (equal (overlay-get (car overlays
) 'invisible
) 'allout
)
2596 (setq got
(car overlays
))
2599 ;;;_ > allout-back-to-visible-text ()
2600 (defun allout-back-to-visible-text ()
2601 "Move to most recent prior character that is visible, and return point."
2602 (if (allout-hidden-p)
2603 (goto-char (overlay-start (allout-get-invisibility-overlay))))
2606 ;;;_ - Subtree Charting
2607 ;;;_ " These routines either produce or assess charts, which are
2608 ;;; nested lists of the locations of topics within a subtree.
2610 ;;; Charts enable efficient subtree navigation by providing a reusable basis
2611 ;;; for elaborate, compound assessment and adjustment of a subtree.
2613 ;;;_ > allout-chart-subtree (&optional levels visible orig-depth prev-depth)
2614 (defun allout-chart-subtree (&optional levels visible orig-depth prev-depth
)
2615 "Produce a location \"chart\" of subtopics of the containing topic.
2617 Optional argument LEVELS specifies a depth limit (relative to start
2618 depth) for the chart. Null LEVELS means no limit.
2620 When optional argument VISIBLE is non-nil, the chart includes
2621 only the visible subelements of the charted subjects.
2623 The remaining optional args are for internal use by the function.
2625 Point is left at the end of the subtree.
2627 Charts are used to capture outline structure, so that outline-altering
2628 routines need to assess the structure only once, and then use the chart
2629 for their elaborate manipulations.
2631 The chart entries for the topics are in reverse order, so the
2632 last topic is listed first. The entry for each topic consists of
2633 an integer indicating the point at the beginning of the topic
2634 prefix. Charts for offspring consist of a list containing,
2635 recursively, the charts for the respective subtopics. The chart
2636 for a topics' offspring precedes the entry for the topic itself.
2638 The other function parameters are for internal recursion, and should
2639 not be specified by external callers. ORIG-DEPTH is depth of topic at
2640 starting point, and PREV-DEPTH is depth of prior topic."
2642 (let ((original (not orig-depth
)) ; `orig-depth' set only in recursion.
2645 (if original
; Just starting?
2646 ; Register initial settings and
2647 ; position to first offspring:
2648 (progn (setq orig-depth
(allout-depth))
2649 (or prev-depth
(setq prev-depth
(1+ orig-depth
)))
2651 (allout-next-visible-heading 1)
2652 (allout-next-heading))))
2654 ;; Loop over the current levels' siblings. Besides being more
2655 ;; efficient than tail-recursing over a level, it avoids exceeding
2656 ;; the typically quite constrained Emacs max-lisp-eval-depth.
2658 ;; Probably would speed things up to implement loop-based stack
2659 ;; operation rather than recursing for lower levels. Bah.
2661 (while (and (not (eobp))
2662 ; Still within original topic?
2663 (< orig-depth
(setq curr-depth allout-recent-depth
))
2664 (cond ((= prev-depth curr-depth
)
2665 ;; Register this one and move on:
2666 (setq chart
(cons allout-recent-prefix-beginning chart
))
2667 (if (and levels
(<= levels
1))
2668 ;; At depth limit -- skip sublevels:
2669 (or (allout-next-sibling curr-depth
)
2670 ;; or no more siblings -- proceed to
2671 ;; next heading at lesser depth:
2672 (while (and (<= curr-depth
2673 allout-recent-depth
)
2675 (allout-next-visible-heading 1)
2676 (allout-next-heading)))))
2678 (allout-next-visible-heading 1)
2679 (allout-next-heading))))
2681 ((and (< prev-depth curr-depth
)
2684 ;; Recurse on deeper level of curr topic:
2686 (cons (allout-chart-subtree (and levels
2692 ;; ... then continue with this one.
2695 ;; ... else nil if we've ascended back to prev-depth.
2699 (if original
; We're at the last sibling on
2700 ; the original level. Position
2702 (progn (and (not (eobp)) (forward-char -
1))
2703 (and (= (preceding-char) ?
\n)
2704 (= (aref (buffer-substring (max 1 (- (point) 3))
2709 (setq allout-recent-end-of-subtree
(point))))
2711 chart
; (nreverse chart) not necessary,
2712 ; and maybe not preferable.
2714 ;;;_ > allout-chart-siblings (&optional start end)
2715 (defun allout-chart-siblings (&optional start end
)
2716 "Produce a list of locations of this and succeeding sibling topics.
2717 Effectively a top-level chart of siblings. See `allout-chart-subtree'
2718 for an explanation of charts."
2720 (when (allout-goto-prefix-doublechecked)
2721 (let ((chart (list (point))))
2722 (while (allout-next-sibling)
2723 (setq chart
(cons (point) chart
)))
2724 (if chart
(setq chart
(nreverse chart
)))))))
2725 ;;;_ > allout-chart-to-reveal (chart depth)
2726 (defun allout-chart-to-reveal (chart depth
)
2728 "Return a flat list of hidden points in subtree CHART, up to DEPTH.
2730 If DEPTH is nil, include hidden points at any depth.
2732 Note that point can be left at any of the points on chart, or at the
2736 (while (and (or (null depth
) (> depth
0))
2738 (setq here
(car chart
))
2740 (let ((further (allout-chart-to-reveal here
(if (null depth
)
2743 ;; We're on the start of a subtree -- recurse with it, if there's
2744 ;; more depth to go:
2745 (if further
(setq result
(append further result
)))
2746 (setq chart
(cdr chart
)))
2748 (if (allout-hidden-p)
2749 (setq result
(cons here result
)))
2750 (setq chart
(cdr chart
))))
2752 ;;;_ X allout-chart-spec (chart spec &optional exposing)
2753 ;; (defun allout-chart-spec (chart spec &optional exposing)
2754 ;; "Not yet (if ever) implemented.
2756 ;; Produce exposure directives given topic/subtree CHART and an exposure SPEC.
2758 ;; Exposure spec indicates the locations to be exposed and the prescribed
2759 ;; exposure status. Optional arg EXPOSING is an integer, with 0
2760 ;; indicating pending concealment, anything higher indicating depth to
2761 ;; which subtopic headers should be exposed, and negative numbers
2762 ;; indicating (negative of) the depth to which subtopic headers and
2763 ;; bodies should be exposed.
2765 ;; The produced list can have two types of entries. Bare numbers
2766 ;; indicate points in the buffer where topic headers that should be
2769 ;; - bare negative numbers indicates that the topic starting at the
2770 ;; point which is the negative of the number should be opened,
2771 ;; including their entries.
2772 ;; - bare positive values indicate that this topic header should be
2774 ;; - Lists signify the beginning and end points of regions that should
2775 ;; be flagged, and the flag to employ. (For concealment: `(\?r)', and
2778 ;; (cond ((listp spec)
2781 ;; (setq spec (cdr spec)))
2785 ;;;_ > allout-goto-prefix ()
2786 (defun allout-goto-prefix ()
2787 "Put point at beginning of immediately containing outline topic.
2789 Goes to most immediate subsequent topic if none immediately containing.
2791 Not sensitive to topic visibility.
2793 Returns the point at the beginning of the prefix, or nil if none."
2797 (while (and (not done
)
2798 (search-backward "\n" nil
1))
2800 (if (looking-at allout-regexp
)
2801 (setq done
(allout-prefix-data))
2804 (cond ((looking-at allout-regexp
)
2805 (allout-prefix-data))
2806 ((allout-next-heading))
2809 ;;;_ > allout-goto-prefix-doublechecked ()
2810 (defun allout-goto-prefix-doublechecked ()
2811 "Put point at beginning of immediately containing outline topic.
2813 Like `allout-goto-prefix', but shallow topics (according to
2814 `allout-doublecheck-at-and-shallower') are checked and
2815 disqualified for child containment discontinuity, according to
2816 `allout-aberrant-container-p'."
2817 (if (allout-goto-prefix)
2818 (if (and (allout-do-doublecheck)
2819 (allout-aberrant-container-p))
2820 (allout-previous-heading)
2823 ;;;_ > allout-end-of-prefix ()
2824 (defun allout-end-of-prefix (&optional ignore-decorations
)
2825 "Position cursor at beginning of header text.
2827 If optional IGNORE-DECORATIONS is non-nil, put just after bullet,
2828 otherwise skip white space between bullet and ensuing text."
2830 (if (not (allout-goto-prefix-doublechecked))
2832 (goto-char allout-recent-prefix-end
)
2834 (if ignore-decorations
2836 (while (looking-at "[0-9]") (forward-char 1))
2837 (if (and (not (eolp)) (looking-at "\\s-")) (forward-char 1))))
2838 ;; Reestablish where we are:
2839 (allout-current-depth)))
2840 ;;;_ > allout-current-bullet-pos ()
2841 (defun allout-current-bullet-pos ()
2842 "Return position of current (visible) topic's bullet."
2844 (if (not (allout-current-depth))
2846 (1- allout-recent-prefix-end
)))
2847 ;;;_ > allout-back-to-current-heading (&optional interactive)
2848 (defun allout-back-to-current-heading (&optional interactive
)
2849 "Move to heading line of current topic, or beginning if not in a topic.
2851 If interactive, we position at the end of the prefix.
2853 Return value of resulting point, unless we started outside
2854 of (before any) topics, in which case we return nil."
2858 (allout-beginning-of-current-line)
2859 (let ((bol-point (point)))
2860 (when (allout-goto-prefix-doublechecked)
2861 (if (<= (point) bol-point
)
2863 (setq bol-point
(point))
2864 (allout-beginning-of-current-line)
2865 (if (not (= bol-point
(point)))
2866 (if (looking-at allout-regexp
)
2867 (allout-prefix-data)))
2869 (allout-end-of-prefix)
2871 (goto-char (point-min))
2873 ;;;_ > allout-back-to-heading ()
2874 (defalias 'allout-back-to-heading
'allout-back-to-current-heading
)
2875 ;;;_ > allout-pre-next-prefix ()
2876 (defun allout-pre-next-prefix ()
2877 "Skip forward to just before the next heading line.
2879 Returns that character position."
2881 (if (allout-next-heading)
2882 (goto-char (1- allout-recent-prefix-beginning
))))
2883 ;;;_ > allout-end-of-subtree (&optional current include-trailing-blank)
2884 (defun allout-end-of-subtree (&optional current include-trailing-blank
)
2885 "Put point at the end of the last leaf in the containing topic.
2887 Optional CURRENT means put point at the end of the containing
2890 Optional INCLUDE-TRAILING-BLANK means include a trailing blank line, if
2891 any, as part of the subtree. Otherwise, that trailing blank will be
2892 excluded as delimiting whitespace between topics.
2894 Returns the value of point."
2897 (allout-back-to-current-heading)
2898 (allout-goto-prefix-doublechecked))
2899 (let ((level allout-recent-depth
))
2900 (allout-next-heading)
2901 (while (and (not (eobp))
2902 (> allout-recent-depth level
))
2903 (allout-next-heading))
2905 (allout-end-of-entry)
2907 (if (and (not include-trailing-blank
) (= ?
\n (preceding-char)))
2909 (setq allout-recent-end-of-subtree
(point))))
2910 ;;;_ > allout-end-of-current-subtree (&optional include-trailing-blank)
2911 (defun allout-end-of-current-subtree (&optional include-trailing-blank
)
2913 "Put point at end of last leaf in currently visible containing topic.
2915 Optional INCLUDE-TRAILING-BLANK means include a trailing blank line, if
2916 any, as part of the subtree. Otherwise, that trailing blank will be
2917 excluded as delimiting whitespace between topics.
2919 Returns the value of point."
2921 (allout-end-of-subtree t include-trailing-blank
))
2922 ;;;_ > allout-beginning-of-current-entry (&optional interactive)
2923 (defun allout-beginning-of-current-entry (&optional interactive
)
2924 "When not already there, position point at beginning of current topic header.
2926 If already there, move cursor to bullet for hot-spot operation.
2927 \(See `allout-mode' doc string for details of hot-spot operation.)"
2929 (let ((start-point (point)))
2930 (move-beginning-of-line 1)
2931 (if (< 0 (allout-current-depth))
2932 (goto-char allout-recent-prefix-end
)
2933 (goto-char (point-min)))
2934 (allout-end-of-prefix)
2935 (if (and interactive
2936 (= (point) start-point
))
2937 (goto-char (allout-current-bullet-pos)))))
2938 ;;;_ > allout-end-of-entry (&optional inclusive)
2939 (defun allout-end-of-entry (&optional inclusive
)
2940 "Position the point at the end of the current topics' entry.
2942 Optional INCLUSIVE means also include trailing empty line, if any. When
2943 unset, whitespace between items separates them even when the items are
2946 (allout-pre-next-prefix)
2947 (if (and (not inclusive
) (not (bobp)) (= ?
\n (preceding-char)))
2950 ;;;_ > allout-end-of-current-heading ()
2951 (defun allout-end-of-current-heading ()
2953 (allout-beginning-of-current-entry)
2954 (search-forward "\n" nil t
)
2956 (defalias 'allout-end-of-heading
'allout-end-of-current-heading
)
2957 ;;;_ > allout-get-body-text ()
2958 (defun allout-get-body-text ()
2959 "Return the unmangled body text of the topic immediately containing point."
2961 (allout-end-of-prefix)
2962 (if (not (search-forward "\n" nil t
))
2965 (let ((pre-body (point)))
2968 (allout-end-of-entry t
)
2969 (if (not (= pre-body
(point)))
2970 (buffer-substring-no-properties (1+ pre-body
) (point))))
2977 ;;;_ > allout-ascend-to-depth (depth)
2978 (defun allout-ascend-to-depth (depth)
2979 "Ascend to depth DEPTH, returning depth if successful, nil if not."
2980 (if (and (> depth
0)(<= depth
(allout-depth)))
2981 (let (last-ascended)
2982 (while (and (< depth allout-recent-depth
)
2983 (setq last-ascended
(allout-ascend))))
2984 (goto-char allout-recent-prefix-beginning
)
2985 (if (allout-called-interactively-p) (allout-end-of-prefix))
2986 (and last-ascended allout-recent-depth
))))
2987 ;;;_ > allout-ascend (&optional dont-move-if-unsuccessful)
2988 (defun allout-ascend (&optional dont-move-if-unsuccessful
)
2989 "Ascend one level, returning resulting depth if successful, nil if not.
2991 Point is left at the beginning of the level whether or not
2992 successful, unless optional DONT-MOVE-IF-UNSUCCESSFUL is set, in
2993 which case point is returned to its original starting location."
2994 (if dont-move-if-unsuccessful
2995 (setq dont-move-if-unsuccessful
(point)))
2997 (if (allout-beginning-of-level)
2998 (let ((bolevel (point))
2999 (bolevel-depth allout-recent-depth
))
3000 (allout-previous-heading)
3001 (cond ((< allout-recent-depth bolevel-depth
)
3002 allout-recent-depth
)
3003 ((= allout-recent-depth bolevel-depth
)
3004 (if dont-move-if-unsuccessful
3005 (goto-char dont-move-if-unsuccessful
))
3009 ;; some topic after very first is lower depth than first:
3013 (if (allout-called-interactively-p) (allout-end-of-prefix))))
3014 ;;;_ > allout-descend-to-depth (depth)
3015 (defun allout-descend-to-depth (depth)
3016 "Descend to depth DEPTH within current topic.
3018 Returning depth if successful, nil if not."
3019 (let ((start-point (point))
3020 (start-depth (allout-depth)))
3022 (and (> (allout-depth) 0)
3023 (not (= depth allout-recent-depth
)) ; ... not there yet
3024 (allout-next-heading) ; ... go further
3025 (< start-depth allout-recent-depth
))) ; ... still in topic
3026 (if (and (> (allout-depth) 0)
3027 (= allout-recent-depth depth
))
3029 (goto-char start-point
)
3032 ;;;_ > allout-up-current-level (arg)
3033 (defun allout-up-current-level (arg)
3034 "Move out ARG levels from current visible topic."
3036 (let ((start-point (point)))
3037 (allout-back-to-current-heading)
3038 (if (not (allout-ascend))
3039 (progn (goto-char start-point
)
3040 (error "Can't ascend past outermost level"))
3041 (if (allout-called-interactively-p) (allout-end-of-prefix))
3042 allout-recent-prefix-beginning
)))
3045 ;;;_ > allout-next-sibling (&optional depth backward)
3046 (defun allout-next-sibling (&optional depth backward
)
3047 "Like `allout-forward-current-level', but respects invisible topics.
3049 Traverse at optional DEPTH, or current depth if none specified.
3051 Go backward if optional arg BACKWARD is non-nil.
3053 Return the start point of the new topic if successful, nil otherwise."
3055 (if (if backward
(bobp) (eobp))
3057 (let ((target-depth (or depth
(allout-depth)))
3058 (start-point (point))
3059 (start-prefix-beginning allout-recent-prefix-beginning
)
3064 ;; done too few single steps to resort to the leap routine:
3067 (not (if backward
(bobp) (eobp)))
3068 ;; still traversable:
3069 (if backward
(allout-previous-heading) (allout-next-heading))
3070 ;; we're below the target depth
3071 (> (setq last-depth allout-recent-depth
) target-depth
))
3072 (setq count
(1+ count
))
3073 (if (> count
7) ; lists are commonly 7 +- 2, right?-)
3076 (or (allout-next-sibling-leap target-depth backward
)
3078 (goto-char start-point
)
3079 (if depth
(allout-depth) target-depth
)
3082 (and (> (or last-depth
(allout-depth)) 0)
3083 (= allout-recent-depth target-depth
))
3084 (not (= start-prefix-beginning
3085 allout-recent-prefix-beginning
)))
3086 allout-recent-prefix-beginning
)
3088 (goto-char start-point
)
3089 (if depth
(allout-depth) target-depth
)
3091 ;;;_ > allout-next-sibling-leap (&optional depth backward)
3092 (defun allout-next-sibling-leap (&optional depth backward
)
3093 "Like `allout-next-sibling', but by direct search for topic at depth.
3095 Traverse at optional DEPTH, or current depth if none specified.
3097 Go backward if optional arg BACKWARD is non-nil.
3099 Return the start point of the new topic if successful, nil otherwise.
3101 Costs more than regular `allout-next-sibling' for short traversals:
3103 - we have to check the prior (next, if traveling backwards)
3104 item to confirm connectivity with the prior topic, and
3105 - if confirmed, we have to reestablish the allout-recent-* settings with
3106 some extra navigation
3107 - if confirmation fails, we have to do more work to recover
3109 It is an increasingly big win when there are many intervening
3110 offspring before the next sibling, however, so
3111 `allout-next-sibling' resorts to this if it finds itself in that
3114 (if (if backward
(bobp) (eobp))
3116 (let* ((start-point (point))
3117 (target-depth (or depth
(allout-depth)))
3118 (search-whitespace-regexp nil
)
3119 (depth-biased (- target-depth
2))
3120 (expression (if (<= target-depth
1)
3121 allout-depth-one-regexp
3122 (format allout-depth-specific-regexp
3123 depth-biased depth-biased
)))
3127 (setq found
(save-match-data
3129 (re-search-backward expression nil
'to-limit
)
3131 (re-search-forward expression nil
'to-limit
))))
3132 (if (and found
(allout-aberrant-container-p))
3134 (setq done
(or found
(if backward
(bobp) (eobp)))))
3136 (progn (goto-char start-point
)
3138 ;; rationale: if any intervening items were at a lower depth, we
3139 ;; would now be on the first offspring at the target depth -- ie,
3140 ;; the preceding item (per the search direction) must be at a
3141 ;; lesser depth. that's all we need to check.
3142 (if backward
(allout-next-heading) (allout-previous-heading))
3143 (if (< allout-recent-depth target-depth
)
3144 ;; return to start and reestablish allout-recent-*:
3146 (goto-char start-point
)
3150 ;; locate cursor and set allout-recent-*:
3151 (allout-goto-prefix))))))
3152 ;;;_ > allout-previous-sibling (&optional depth backward)
3153 (defun allout-previous-sibling (&optional depth backward
)
3154 "Like `allout-forward-current-level' backwards, respecting invisible topics.
3156 Optional DEPTH specifies depth to traverse, default current depth.
3158 Optional BACKWARD reverses direction.
3160 Return depth if successful, nil otherwise."
3161 (allout-next-sibling depth
(not backward
))
3163 ;;;_ > allout-snug-back ()
3164 (defun allout-snug-back ()
3165 "Position cursor at end of previous topic.
3167 Presumes point is at the start of a topic prefix."
3168 (if (or (bobp) (eobp))
3171 (if (or (bobp) (not (= ?
\n (preceding-char))))
3175 ;;;_ > allout-beginning-of-level ()
3176 (defun allout-beginning-of-level ()
3177 "Go back to the first sibling at this level, visible or not."
3178 (allout-end-of-level 'backward
))
3179 ;;;_ > allout-end-of-level (&optional backward)
3180 (defun allout-end-of-level (&optional backward
)
3181 "Go to the last sibling at this level, visible or not."
3183 (let ((depth (allout-depth)))
3184 (while (allout-previous-sibling depth nil
))
3185 (prog1 allout-recent-depth
3186 (if (allout-called-interactively-p) (allout-end-of-prefix)))))
3187 ;;;_ > allout-next-visible-heading (arg)
3188 (defun allout-next-visible-heading (arg)
3189 "Move to the next ARGth visible heading line, backward if ARG is negative.
3191 Move to buffer limit in indicated direction if headings are exhausted."
3194 (let* ((inhibit-field-text-motion t
)
3195 (backward (if (< arg
0) (setq arg
(* -
1 arg
))))
3196 (step (if backward -
1 1))
3197 (progress (allout-current-bullet-pos))
3202 ;; Boundary condition:
3203 (not (if backward
(bobp)(eobp)))
3204 ;; Move, skipping over all concealed lines in one fell swoop:
3205 (prog1 (condition-case nil
(or (line-move step
) t
)
3207 (allout-beginning-of-current-line)
3208 ;; line-move can wind up on the same line if long.
3209 ;; when moving forward, that would yield no-progress
3210 (when (and (not backward
)
3211 (<= (point) progress
))
3212 ;; ensure progress by doing line-move from end-of-line:
3214 (condition-case nil
(or (line-move step
) t
)
3216 (allout-beginning-of-current-line)
3217 (setq progress
(point))))
3218 ;; Deal with apparent header line:
3220 (if (not (looking-at allout-regexp
))
3221 ;; not a header line, keep looking:
3223 (allout-prefix-data)
3224 (if (and (allout-do-doublecheck)
3225 (allout-aberrant-container-p))
3226 ;; skip this aberrant prospective header line:
3228 ;; this prospective headerline qualifies -- register:
3229 (setq got allout-recent-prefix-beginning
)
3230 ;; and break the loop:
3232 ;; Register this got, it may be the last:
3233 (if got
(setq prev got
))
3234 (setq arg
(1- arg
)))
3235 (cond (got ; Last move was to a prefix:
3236 (allout-end-of-prefix))
3237 (prev ; Last move wasn't, but prev was:
3239 (allout-end-of-prefix))
3240 ((not backward
) (end-of-line) nil
))))
3241 ;;;_ > allout-previous-visible-heading (arg)
3242 (defun allout-previous-visible-heading (arg)
3243 "Move to the previous heading line.
3245 With argument, repeats or can move forward if negative.
3246 A heading line is one that starts with a `*' (or that `allout-regexp'
3249 (prog1 (allout-next-visible-heading (- arg
))
3250 (if (allout-called-interactively-p) (allout-end-of-prefix))))
3251 ;;;_ > allout-forward-current-level (arg)
3252 (defun allout-forward-current-level (arg)
3253 "Position point at the next heading of the same level.
3255 Takes optional repeat-count, goes backward if count is negative.
3257 Returns resulting position, else nil if none found."
3259 (let ((start-depth (allout-current-depth))
3261 (backward (> 0 arg
)))
3262 (if (= 0 start-depth
)
3263 (error "No siblings, not in a topic..."))
3264 (if backward
(setq arg
(* -
1 arg
)))
3265 (allout-back-to-current-heading)
3266 (while (and (not (zerop arg
))
3268 (allout-previous-sibling)
3269 (allout-next-sibling)))
3270 (setq arg
(1- arg
)))
3271 (if (not (allout-called-interactively-p))
3273 (allout-end-of-prefix)
3274 (if (not (zerop arg
))
3275 (error "Hit %s level %d topic, traversed %d of %d requested"
3276 (if backward
"first" "last")
3278 (- (abs start-arg
) arg
)
3279 (abs start-arg
))))))
3280 ;;;_ > allout-backward-current-level (arg)
3281 (defun allout-backward-current-level (arg)
3282 "Inverse of `allout-forward-current-level'."
3284 (if (allout-called-interactively-p)
3285 (let ((current-prefix-arg (* -
1 arg
)))
3286 (call-interactively 'allout-forward-current-level
))
3287 (allout-forward-current-level (* -
1 arg
))))
3292 ;;;_ = allout-post-goto-bullet
3293 (defvar allout-post-goto-bullet nil
3294 "Outline internal var, for `allout-pre-command-business' hot-spot operation.
3296 When set, tells post-processing to reposition on topic bullet, and
3297 then unset it. Set by `allout-pre-command-business' when implementing
3298 hot-spot operation, where literal characters typed over a topic bullet
3299 are mapped to the command of the corresponding control-key on the
3300 `allout-mode-map-value'.")
3301 (make-variable-buffer-local 'allout-post-goto-bullet
)
3302 ;;;_ = allout-command-counter
3303 (defvar allout-command-counter
0
3304 "Counter that monotonically increases in allout-mode buffers.
3306 Set by `allout-pre-command-business', to support allout addons in
3307 coordinating with allout activity.")
3308 (make-variable-buffer-local 'allout-command-counter
)
3309 ;;;_ = allout-this-command-hid-text
3310 (defvar allout-this-command-hid-text nil
3311 "True if the most recent allout-mode command hid any text.")
3312 (make-variable-buffer-local 'allout-this-command-hid-text
)
3313 ;;;_ > allout-post-command-business ()
3314 (defun allout-post-command-business ()
3315 "Outline `post-command-hook' function.
3317 - Implement (and clear) `allout-post-goto-bullet', for hot-spot
3320 - Move the cursor to the beginning of the entry if it is hidden
3321 and collapsing activity just happened.
3323 - If the command we're following was an undo, check for change in
3324 the status of encrypted items and adjust auto-save inhibitions
3327 - Decrypt topic currently being edited if it was encrypted for a save."
3329 (if (not (allout-mode-p)) ; In allout-mode.
3332 (when allout-just-did-undo
3333 (setq allout-just-did-undo nil
)
3334 (run-hooks 'allout-post-undo-hook
)
3335 (cond ((and (= buffer-saved-size -
1)
3336 allout-auto-save-temporarily-disabled
)
3337 ;; user possibly undid a decryption, deinhibit auto-save:
3338 (allout-maybe-resume-auto-save-info-after-encryption))
3342 (goto-char (point-min))
3343 (not (allout-next-topic-pending-encryption))))
3344 ;; plain-text encrypted items are present, inhibit auto-save:
3345 (allout-inhibit-auto-save-info-for-decryption (buffer-size)))))
3347 (if (and (boundp 'allout-after-save-decrypt
)
3348 allout-after-save-decrypt
)
3349 (allout-after-saves-handler))
3351 ;; Implement allout-post-goto-bullet, if set:
3352 (if (and allout-post-goto-bullet
3353 (allout-current-bullet-pos))
3354 (progn (goto-char (allout-current-bullet-pos))
3355 (setq allout-post-goto-bullet nil
))
3356 (when (and (allout-hidden-p) allout-this-command-hid-text
)
3357 (allout-beginning-of-current-entry)))))
3358 ;;;_ > allout-pre-command-business ()
3359 (defun allout-pre-command-business ()
3360 "Outline `pre-command-hook' function for outline buffers.
3362 Among other things, implements special behavior when the cursor is on the
3363 topic bullet character.
3365 When the cursor is on the bullet character, self-insert
3366 characters are reinterpreted as the corresponding
3367 control-character in the `allout-mode-map-value'. The
3368 `allout-mode' `post-command-hook' insures that the cursor which
3369 has moved as a result of such reinterpretation is positioned on
3370 the bullet character of the destination topic.
3372 The upshot is that you can get easy, single (ie, unmodified) key
3373 outline maneuvering operations by positioning the cursor on the bullet
3374 char. When in this mode you can use regular cursor-positioning
3375 command/keystrokes to relocate the cursor off of a bullet character to
3376 return to regular interpretation of self-insert characters."
3378 (if (not (allout-mode-p))
3380 (setq allout-command-counter
(1+ allout-command-counter
))
3381 (setq allout-this-command-hid-text nil
)
3382 ;; Do hot-spot navigation.
3383 (if (and (eq this-command
'self-insert-command
)
3384 (eq (point)(allout-current-bullet-pos)))
3385 (allout-hotspot-key-handler))))
3386 ;;;_ > allout-hotspot-key-handler ()
3387 (defun allout-hotspot-key-handler ()
3388 "Catchall handling of key bindings in hot-spots.
3390 Translates unmodified keystrokes to corresponding allout commands, when
3391 they would qualify if prefixed with the `allout-command-prefix', and sets
3392 `this-command' accordingly.
3394 Returns the qualifying command, if any, else nil."
3396 (let* ((modified (event-modifiers last-command-event
))
3397 (key-num (cond ((numberp last-command-event
) last-command-event
)
3398 ;; for XEmacs character type:
3399 ((and (fboundp 'characterp
)
3400 (apply 'characterp
(list last-command-event
)))
3401 (apply 'char-to-int
(list last-command-event
)))
3409 ;; exclude control chars and escape:
3412 (setq mapped-binding
3414 ;; try control-modified versions of keys:
3415 (key-binding (vconcat allout-command-prefix
3417 (if (and (<= 97 key-num
) ; "a"
3418 (>= 122 key-num
)) ; "z"
3419 (- key-num
96) key-num
)))
3421 ;; try non-modified versions of keys:
3422 (key-binding (vconcat allout-command-prefix
3425 ;; Qualified as an allout command -- do hot-spot operation.
3426 (setq allout-post-goto-bullet t
)
3427 ;; accept-defaults nil, or else we get allout-item-icon-key-handler.
3428 (setq mapped-binding
(key-binding (vector key-num
))))
3430 (while (keymapp mapped-binding
)
3431 (setq mapped-binding
3432 (lookup-key mapped-binding
(vector (read-char)))))
3434 (when mapped-binding
3435 (setq this-command mapped-binding
)))))
3437 ;;;_ > allout-find-file-hook ()
3438 (defun allout-find-file-hook ()
3439 "Activate `allout-mode' on non-nil `allout-auto-activation', `allout-layout'.
3441 See `allout-auto-activation' for setup instructions."
3442 (if (and allout-auto-activation
3443 (not (allout-mode-p))
3447 ;;;_ - Topic Format Assessment
3448 ;;;_ > allout-solicit-alternate-bullet (depth &optional current-bullet)
3449 (defun allout-solicit-alternate-bullet (depth &optional current-bullet
)
3451 "Prompt for and return a bullet char as an alternative to the current one.
3453 Offer one suitable for current depth DEPTH as default."
3455 (let* ((default-bullet (or (and (stringp current-bullet
) current-bullet
)
3456 (allout-bullet-for-depth depth
)))
3457 (sans-escapes (regexp-sans-escapes allout-bullets-string
))
3460 (goto-char (allout-current-bullet-pos))
3461 (setq choice
(solicit-char-in-string
3462 (format "Select bullet: %s ('%s' default): "
3464 (allout-substring-no-properties default-bullet
))
3468 (if (string= choice
"") default-bullet choice
))
3470 ;;;_ > allout-distinctive-bullet (bullet)
3471 (defun allout-distinctive-bullet (bullet)
3472 "True if BULLET is one of those on `allout-distinctive-bullets-string'."
3473 (string-match (regexp-quote bullet
) allout-distinctive-bullets-string
))
3474 ;;;_ > allout-numbered-type-prefix (&optional prefix)
3475 (defun allout-numbered-type-prefix (&optional prefix
)
3476 "True if current header prefix bullet is numbered bullet."
3477 (and allout-numbered-bullet
3478 (string= allout-numbered-bullet
3480 (allout-get-prefix-bullet prefix
)
3481 (allout-get-bullet)))))
3482 ;;;_ > allout-encrypted-type-prefix (&optional prefix)
3483 (defun allout-encrypted-type-prefix (&optional prefix
)
3484 "True if current header prefix bullet is for an encrypted entry (body)."
3485 (and allout-topic-encryption-bullet
3486 (string= allout-topic-encryption-bullet
3488 (allout-get-prefix-bullet prefix
)
3489 (allout-get-bullet)))))
3490 ;;;_ > allout-bullet-for-depth (&optional depth)
3491 (defun allout-bullet-for-depth (&optional depth
)
3492 "Return outline topic bullet suited to optional DEPTH, or current depth."
3493 ;; Find bullet in plain-bullets-string modulo DEPTH.
3494 (if allout-stylish-prefixes
3495 (char-to-string (aref allout-plain-bullets-string
3496 (%
(max 0 (- depth
2))
3497 allout-plain-bullets-string-len
)))
3498 allout-primary-bullet
)
3501 ;;;_ - Topic Production
3502 ;;;_ > allout-make-topic-prefix (&optional prior-bullet
3503 (defun allout-make-topic-prefix (&optional prior-bullet
3509 ;; Depth null means use current depth, non-null means we're either
3510 ;; opening a new topic after current topic, lower or higher, or we're
3511 ;; changing level of current topic.
3512 ;; Instead dominates specified bullet-char.
3514 "Generate a topic prefix suitable for optional arg DEPTH, or current depth.
3516 All the arguments are optional.
3518 PRIOR-BULLET indicates the bullet of the prefix being changed, or
3519 nil if none. This bullet may be preserved (other options
3520 notwithstanding) if it is on the `allout-distinctive-bullets-string',
3523 Second arg NEW indicates that a new topic is being opened after the
3524 topic at point, if non-nil. Default bullet for new topics, eg, may
3525 be set (contingent to other args) to numbered bullets if previous
3526 sibling is one. The implication otherwise is that the current topic
3527 is being adjusted -- shifted or rebulleted -- and we don't consider
3528 bullet or previous sibling.
3530 Third arg DEPTH forces the topic prefix to that depth, regardless of
3531 the current topics' depth.
3535 - nil, then the bullet char for the context is used, per distinction or depth
3536 - a (numeric) character, then character's string representation is used
3537 - a string, then the user is asked for bullet with the first char as default
3538 - anything else, the user is solicited with bullet char per context as default
3540 \(INSTEAD overrides other options, including, eg, a distinctive
3543 Fifth arg, NUMBER-CONTROL, matters only if `allout-numbered-bullet'
3544 is non-nil *and* no specific INSTEAD was specified. Then
3545 NUMBER-CONTROL non-nil forces prefix to either numbered or
3546 unnumbered format, depending on the value of the sixth arg, INDEX.
3548 \(Note that NUMBER-CONTROL does *not* apply to level 1 topics. Sorry...)
3550 If NUMBER-CONTROL is non-nil and sixth arg INDEX is non-nil then
3551 the prefix of the topic is forced to be numbered. Non-nil
3552 NUMBER-CONTROL and nil INDEX forces non-numbered format on the
3553 bullet. Non-nil NUMBER-CONTROL and non-nil, non-number INDEX means
3554 that the index for the numbered prefix will be derived, by counting
3555 siblings back to start of level. If INDEX is a number, then that
3556 number is used as the index for the numbered prefix (allowing, eg,
3557 sequential renumbering to not require this function counting back the
3558 index for each successive sibling)."
3560 ;; The options are ordered in likely frequency of use, most common
3561 ;; highest, least lowest. Ie, more likely to be doing prefix
3562 ;; adjustments than soliciting, and yet more than numbering.
3563 ;; Current prefix is least dominant, but most likely to be commonly
3569 (depth (or depth
(allout-depth)))
3570 (header-lead allout-header-prefix
)
3573 ;; Getting value for bullet char is practically the whole job:
3576 ; Simplest situation -- level 1:
3577 ((<= depth
1) (setq header-lead
"") allout-primary-bullet
)
3578 ; Simple, too: all asterisks:
3579 (allout-old-style-prefixes
3580 ;; Cheat -- make body the whole thing, null out header-lead and
3582 (setq body
(make-string depth
3583 (string-to-char allout-primary-bullet
)))
3584 (setq header-lead
"")
3587 ;; (Neither level 1 nor old-style, so we're space padding.
3588 ;; Sneak it in the condition of the next case, whatever it is.)
3590 ;; Solicitation overrides numbering and other cases:
3591 ((progn (setq body
(make-string (- depth
2) ?\
))
3592 ;; The actual condition:
3594 (let ((got (cond ((stringp instead
)
3595 (if (> (length instead
) 0)
3596 (allout-solicit-alternate-bullet
3597 depth
(substring instead
0 1))))
3598 ((characterp instead
) (char-to-string instead
))
3599 (t (allout-solicit-alternate-bullet depth
)))))
3600 ;; Gotta check whether we're numbering and got a numbered bullet:
3601 (setq numbering
(and allout-numbered-bullet
3602 (not (and number-control
(not index
)))
3603 (string= got allout-numbered-bullet
)))
3604 ;; Now return what we got, regardless:
3607 ;; Numbering invoked through args:
3608 ((and allout-numbered-bullet number-control
)
3609 (if (setq numbering
(not (setq denumbering
(not index
))))
3610 allout-numbered-bullet
3611 (if (and prior-bullet
3612 (not (string= allout-numbered-bullet
3615 (allout-bullet-for-depth depth
))))
3617 ;;; Neither soliciting nor controlled numbering ;;;
3618 ;;; (may be controlled denumbering, tho) ;;;
3620 ;; Check wrt previous sibling:
3621 ((and new
; only check for new prefixes
3622 (<= depth
(allout-depth))
3623 allout-numbered-bullet
; ... & numbering enabled
3625 (let ((sibling-bullet
3627 ;; Locate correct sibling:
3628 (or (>= depth
(allout-depth))
3629 (allout-ascend-to-depth depth
))
3630 (allout-get-bullet))))
3631 (if (and sibling-bullet
3632 (string= allout-numbered-bullet sibling-bullet
))
3633 (setq numbering sibling-bullet
)))))
3635 ;; Distinctive prior bullet?
3637 (allout-distinctive-bullet prior-bullet
)
3638 ;; Either non-numbered:
3639 (or (not (and allout-numbered-bullet
3640 (string= prior-bullet allout-numbered-bullet
)))
3641 ;; or numbered, and not denumbering:
3642 (setq numbering
(not denumbering
)))
3646 ;; Else, standard bullet per depth:
3647 ((allout-bullet-for-depth depth
)))))
3653 (format "%d" (cond ((and index
(numberp index
)) index
)
3654 (new (1+ (allout-sibling-index depth
)))
3655 ((allout-sibling-index))))))
3658 ;;;_ > allout-open-topic (relative-depth &optional before offer-recent-bullet)
3659 (defun allout-open-topic (relative-depth &optional before offer-recent-bullet
)
3660 "Open a new topic at depth DEPTH.
3662 New topic is situated after current one, unless optional flag BEFORE
3663 is non-nil, or unless current line is completely empty -- lacking even
3664 whitespace -- in which case open is done on the current line.
3666 When adding an offspring, it will be added immediately after the parent if
3667 the other offspring are exposed, or after the last child if the offspring
3668 are hidden. (The intervening offspring will be exposed in the latter
3671 If OFFER-RECENT-BULLET is true, offer to use the bullet of the prior sibling.
3675 - Creation of new topics is with respect to the visible topic
3676 containing the cursor, regardless of intervening concealed ones.
3678 - New headers are generally created after/before the body of a
3679 topic. However, they are created right at cursor location if the
3680 cursor is on a blank line, even if that breaks the current topic
3681 body. This is intentional, to provide a simple means for
3682 deliberately dividing topic bodies.
3684 - Double spacing of topic lists is preserved. Also, the first
3685 level two topic is created double-spaced (and so would be
3686 subsequent siblings, if that's left intact). Otherwise,
3687 single-spacing is used.
3689 - Creation of sibling or nested topics is with respect to the topic
3690 you're starting from, even when creating backwards. This way you
3691 can easily create a sibling in front of the current topic without
3692 having to go to its preceding sibling, and then open forward
3695 (allout-beginning-of-current-line)
3697 (let* ((inhibit-field-text-motion t
)
3698 (depth (+ (allout-current-depth) relative-depth
))
3699 (opening-on-blank (if (looking-at "^\$")
3700 (not (setq before nil
))))
3701 ;; bunch o vars set while computing ref-topic
3705 (ref-topic (save-excursion
3706 (cond ((< relative-depth
0)
3707 (allout-ascend-to-depth depth
))
3708 ((>= relative-depth
1) nil
)
3709 (t (allout-back-to-current-heading)))
3710 (setq ref-depth allout-recent-depth
)
3712 (if (> allout-recent-prefix-end
1)
3713 (allout-recent-bullet)
3715 (setq opening-numbered
3717 (and allout-numbered-bullet
3718 (or (<= relative-depth
0)
3719 (allout-descend-to-depth depth
))
3720 (if (allout-numbered-type-prefix)
3721 allout-numbered-bullet
))))
3727 (if (not opening-on-blank
)
3728 ; Positioning and vertical
3729 ; padding -- only if not
3732 (goto-char ref-topic
)
3733 (setq dbl-space
; Determine double space action:
3734 (or (and (<= relative-depth
0) ; not descending;
3736 ;; at b-o-b or preceded by a blank line?
3737 (or (> 0 (forward-line -
1))
3738 (looking-at "^\\s-*$")
3741 ;; succeeded by a blank line?
3742 (allout-end-of-current-subtree)
3743 (looking-at "\n\n")))
3744 (and (= ref-depth
1)
3748 ;; Don't already have following
3749 ;; vertical padding:
3750 (not (allout-pre-next-prefix)))))))
3752 ;; Position to prior heading, if inserting backwards, and not
3754 (if (and before
(>= relative-depth
0))
3755 (progn (allout-back-to-current-heading)
3756 (setq doing-beginning
(bobp))
3758 (allout-previous-heading)))
3759 (if (and before
(bobp))
3762 (if (<= relative-depth
0)
3763 ;; Not going inwards, don't snug up:
3769 (progn (end-of-line)
3770 (allout-pre-next-prefix)
3771 (while (and (= ?
\n (following-char))
3776 (if (not (looking-at "^$"))
3778 (allout-end-of-current-subtree)
3779 (if (looking-at "\n\n") (forward-char 1))))
3780 ;; Going inwards -- double-space if first offspring is
3781 ;; double-spaced, otherwise snug up.
3782 (allout-end-of-entry)
3786 (allout-beginning-of-current-line)
3789 ;; Blank lines between current header body and next
3790 ;; header -- get to last substantive (non-white-space)
3792 (progn (setq dbl-space t
)
3793 (re-search-backward "[^ \t\n]" nil t
)))
3794 (if (looking-at "\n\n")
3797 (allout-next-heading)
3798 (when (> allout-recent-depth ref-depth
)
3799 ;; This is an offspring.
3801 (looking-at "^\\s-*$")))
3802 (progn (forward-line 1)
3805 (allout-end-of-current-line))
3807 ;;(if doing-beginning (goto-char doing-beginning))
3809 ;; We insert a newline char rather than using open-line to
3810 ;; avoid rear-stickiness inheritance of read-only property.
3811 (progn (if (and (not (> depth ref-depth
))
3814 (if (and (not dbl-space
) (> depth ref-depth
))
3820 (if (and dbl-space
(not (> relative-depth
0)))
3822 (if (and (not (eobp))
3825 ;; bolp doesn't detect concealed
3826 ;; trailing newlines, compensate:
3829 (allout-hidden-p)))))
3832 (setq start
(point))
3833 (insert (concat (allout-make-topic-prefix opening-numbered t depth
)
3835 (setq end
(1+ (point)))
3837 (allout-rebullet-heading (and offer-recent-bullet ref-bullet
)
3839 (if (> relative-depth
0)
3840 (save-excursion (goto-char ref-topic
)
3841 (allout-show-children)))
3844 (run-hook-with-args 'allout-structure-added-hook start end
)
3848 ;;;_ > allout-open-subtopic (arg)
3849 (defun allout-open-subtopic (arg)
3850 "Open new topic header at deeper level than the current one.
3852 Negative universal ARG means to open deeper, but place the new topic
3853 prior to the current one."
3855 (allout-open-topic 1 (> 0 arg
) (< 1 arg
)))
3856 ;;;_ > allout-open-sibtopic (arg)
3857 (defun allout-open-sibtopic (arg)
3858 "Open new topic header at same level as the current one.
3860 Positive universal ARG means to use the bullet of the prior sibling.
3862 Negative universal ARG means to place the new topic prior to the current
3865 (allout-open-topic 0 (> 0 arg
) (not (= 1 arg
))))
3866 ;;;_ > allout-open-supertopic (arg)
3867 (defun allout-open-supertopic (arg)
3868 "Open new topic header at shallower level than the current one.
3870 Negative universal ARG means to open shallower, but place the new
3871 topic prior to the current one."
3874 (allout-open-topic -
1 (> 0 arg
) (< 1 arg
)))
3876 ;;;_ - Outline Alteration
3877 ;;;_ : Topic Modification
3878 ;;;_ = allout-former-auto-filler
3879 (defvar allout-former-auto-filler nil
3880 "Name of modal fill function being wrapped by `allout-auto-fill'.")
3881 ;;;_ > allout-auto-fill ()
3882 (defun allout-auto-fill ()
3883 "`allout-mode' autofill function.
3885 Maintains outline hanging topic indentation if
3886 `allout-use-hanging-indents' is set."
3888 (when (and (not allout-inhibit-auto-fill
)
3889 (or (not allout-inhibit-auto-fill-on-headline
)
3890 (not (allout-on-current-heading-p))))
3891 (let ((fill-prefix (if allout-use-hanging-indents
3892 ;; Check for topic header indentation:
3896 (if (looking-at allout-regexp
)
3897 ;; ... construct indentation to account for
3898 ;; length of topic prefix:
3899 (make-string (progn (allout-end-of-prefix)
3902 (use-auto-fill-function
3903 (if (and (eq allout-outside-normal-auto-fill-function
3905 (eq auto-fill-function
'allout-auto-fill
))
3907 (or allout-outside-normal-auto-fill-function
3908 auto-fill-function
))))
3909 (if (or allout-former-auto-filler allout-use-hanging-indents
)
3910 (funcall use-auto-fill-function
)))))
3911 ;;;_ > allout-reindent-body (old-depth new-depth &optional number)
3912 (defun allout-reindent-body (old-depth new-depth
&optional number
)
3913 "Reindent body lines which were indented at OLD-DEPTH to NEW-DEPTH.
3915 Optional arg NUMBER indicates numbering is being added, and it must
3918 Note that refill of indented paragraphs is not done."
3921 (allout-end-of-prefix)
3922 (let* ((new-margin (current-column))
3923 excess old-indent-begin old-indent-end
3924 ;; We want the column where the header-prefix text started
3925 ;; *before* the prefix was changed, so we infer it relative
3926 ;; to the new margin and the shift in depth:
3927 (old-margin (+ old-depth
(- new-margin new-depth
))))
3929 ;; Process lines up to (but excluding) next topic header:
3933 (and (re-search-forward "\n\\(\\s-*\\)"
3936 ;; Register the indent data, before we reset the
3937 ;; match data with a subsequent `looking-at':
3938 (setq old-indent-begin
(match-beginning 1)
3939 old-indent-end
(match-end 1))
3940 (not (looking-at allout-regexp
)))
3941 (if (> 0 (setq excess
(- (- old-indent-end old-indent-begin
)
3943 ;; Text starts left of old margin -- don't adjust:
3945 ;; Text was hanging at or right of old left margin --
3946 ;; reindent it, preserving its existing indentation
3947 ;; beyond the old margin:
3948 (delete-region old-indent-begin old-indent-end
)
3949 (indent-to (+ new-margin excess
(current-column))))))))))
3950 ;;;_ > allout-rebullet-current-heading (arg)
3951 (defun allout-rebullet-current-heading (arg)
3952 "Solicit new bullet for current visible heading."
3954 (let ((initial-col (current-column))
3955 (on-bullet (eq (point)(allout-current-bullet-pos)))
3957 (backwards (if (< arg
0)
3958 (setq arg
(* arg -
1)))))
3960 (save-excursion (allout-back-to-current-heading)
3961 (allout-end-of-prefix)
3962 (setq from allout-recent-prefix-beginning
3963 to allout-recent-prefix-end
)
3964 (allout-rebullet-heading t
;;; instead
3966 nil
;;; number-control
3968 t
) ;;; do-successors
3969 (run-hook-with-args 'allout-exposure-change-hook
3974 (setq initial-col nil
) ; Override positioning back to init col
3976 (allout-next-visible-heading 1)
3977 (allout-goto-prefix-doublechecked)
3978 (allout-next-visible-heading -
1))))
3980 (cond (on-bullet (goto-char (allout-current-bullet-pos)))
3981 (initial-col (move-to-column initial-col
)))))
3982 ;;;_ > allout-rebullet-heading (&optional instead ...)
3983 (defun allout-rebullet-heading (&optional instead
3989 "Adjust bullet of current topic prefix.
3991 All args are optional.
3994 - nil, then the bullet char for the context is used, per distinction or depth
3995 - a (numeric) character, then character's string representation is used
3996 - a string, then the user is asked for bullet with the first char as default
3997 - anything else, the user is solicited with bullet char per context as default
3999 Second arg DEPTH forces the topic prefix to that depth, regardless
4000 of the topic's current depth.
4002 Third arg NUMBER-CONTROL can force the prefix to or away from
4003 numbered form. It has effect only if `allout-numbered-bullet' is
4004 non-nil and soliciting was not explicitly invoked (via first arg).
4005 Its effect, numbering or denumbering, then depends on the setting
4006 of the fourth arg, INDEX.
4008 If NUMBER-CONTROL is non-nil and fourth arg INDEX is nil, then the
4009 prefix of the topic is forced to be non-numbered. Null index and
4010 non-nil NUMBER-CONTROL forces denumbering. Non-nil INDEX (and
4011 non-nil NUMBER-CONTROL) forces a numbered-prefix form. If non-nil
4012 INDEX is a number, then that number is used for the numbered
4013 prefix. Non-nil and non-number means that the index for the
4014 numbered prefix will be derived by allout-make-topic-prefix.
4016 Fifth arg DO-SUCCESSORS t means re-resolve count on succeeding
4019 Cf vars `allout-stylish-prefixes', `allout-old-style-prefixes',
4020 and `allout-numbered-bullet', which all affect the behavior of
4023 (let* ((current-depth (allout-depth))
4024 (new-depth (or new-depth current-depth
))
4025 (mb allout-recent-prefix-beginning
)
4026 (me allout-recent-prefix-end
)
4027 (current-bullet (buffer-substring-no-properties (- me
1) me
))
4028 (has-annotation (get-text-property mb
'allout-was-hidden
))
4029 (new-prefix (allout-make-topic-prefix current-bullet
4036 ;; Is new one identical to old?
4037 (if (and (= current-depth new-depth
)
4038 (string= current-bullet
4039 (substring new-prefix
(1- (length new-prefix
)))))
4043 ;; New prefix probably different from old:
4044 ; get rid of old one:
4045 (allout-unprotected (delete-region mb me
))
4047 ; Dispense with number if
4048 ; numbered-bullet prefix:
4050 (if (and allout-numbered-bullet
4051 (string= allout-numbered-bullet current-bullet
)
4052 (looking-at "[0-9]+"))
4054 (delete-region (match-beginning 0)(match-end 0)))))
4056 ;; convey 'allout-was-hidden annotation, if original had it:
4058 (put-text-property 0 (length new-prefix
) 'allout-was-hidden t
4061 ; Put in new prefix:
4062 (allout-unprotected (insert new-prefix
))
4064 ;; Reindent the body if elected, margin changed, and not encrypted body:
4065 (if (and allout-reindent-bodies
4066 (not (= new-depth current-depth
))
4067 (not (allout-encrypted-topic-p)))
4068 (allout-reindent-body current-depth new-depth
))
4070 (run-hook-with-args 'allout-exposure-change-hook mb me nil
)
4072 ;; Recursively rectify successive siblings of orig topic if
4073 ;; caller elected for it:
4076 (while (allout-next-sibling new-depth nil
)
4078 (cond ((numberp index
) (1+ index
))
4079 ((not number-control
) (allout-sibling-index))))
4080 (if (allout-numbered-type-prefix)
4081 (allout-rebullet-heading nil
;;; instead
4082 new-depth
;;; new-depth
4083 number-control
;;; number-control
4085 nil
))))) ;;;(dont!)do-successors
4086 ) ; (if (and (= current-depth new-depth)...))
4087 ) ; let* ((current-depth (allout-depth))...)
4089 ;;;_ > allout-rebullet-topic (arg)
4090 (defun allout-rebullet-topic (arg &optional sans-offspring
)
4091 "Rebullet the visible topic containing point and all contained subtopics.
4093 Descends into invisible as well as visible topics, however.
4095 When optional SANS-OFFSPRING is non-nil, subtopics are not
4096 shifted. (Shifting a topic outwards without shifting its
4097 offspring is disallowed, since this would create a \"containment
4098 discontinuity\", where the depth difference between a topic and
4099 its immediate offspring is greater than one.)
4101 With repeat count, shift topic depth by that amount."
4103 (let ((start-col (current-column)))
4106 (cond ((null arg
) (setq arg
0))
4107 ((listp arg
) (setq arg
(car arg
))))
4108 ;; Fill the user in, in case we're shifting a big topic:
4109 (if (not (zerop arg
)) (message "Shifting..."))
4110 (allout-back-to-current-heading)
4111 (if (<= (+ allout-recent-depth arg
) 0)
4112 (error "Attempt to shift topic below level 1"))
4113 (allout-rebullet-topic-grunt arg nil nil nil nil sans-offspring
)
4114 (if (not (zerop arg
)) (message "Shifting... done.")))
4115 (move-to-column (max 0 (+ start-col arg
)))))
4116 ;;;_ > allout-rebullet-topic-grunt (&optional relative-depth ...)
4117 (defun allout-rebullet-topic-grunt (&optional relative-depth
4123 "Like `allout-rebullet-topic', but on nearest containing topic
4126 See `allout-rebullet-heading' for rebulleting behavior.
4128 All arguments are optional.
4130 First arg RELATIVE-DEPTH means to shift the depth of the entire
4133 Several subsequent args are for internal recursive use by the function
4134 itself: STARTING-DEPTH, STARTING-POINT, and INDEX.
4136 Finally, if optional SANS-OFFSPRING is non-nil then the offspring
4137 are not shifted. (Shifting a topic outwards without shifting
4138 its offspring is disallowed, since this would create a
4139 \"containment discontinuity\", where the depth difference between
4140 a topic and its immediate offspring is greater than one.)"
4142 ;; XXX the recursion here is peculiar, and in general the routine may
4143 ;; need simplification with refactoring.
4145 (if (and sans-offspring
4147 (< relative-depth
0))
4148 (error (concat "Attempt to shift topic outwards without offspring,"
4149 " would cause containment discontinuity.")))
4151 (let* ((relative-depth (or relative-depth
0))
4152 (new-depth (allout-depth))
4153 (starting-depth (or starting-depth new-depth
))
4154 (on-starting-call (null starting-point
))
4156 ;; Leave index null on starting call, so rebullet-heading
4157 ;; calculates it at what might be new depth:
4158 (and (or (zerop relative-depth
)
4159 (not on-starting-call
))
4160 (allout-sibling-index))))
4161 (starting-index index
)
4162 (moving-outwards (< 0 relative-depth
))
4163 (starting-point (or starting-point
(point)))
4164 (local-point (point)))
4166 ;; Sanity check for excessive promotion done only on starting call:
4167 (and on-starting-call
4169 (> 0 (+ starting-depth relative-depth
))
4170 (error "Attempt to shift topic out beyond level 1"))
4172 (cond ((= starting-depth new-depth
)
4173 ;; We're at depth to work on this one.
4175 ;; When shifting out we work on the children before working on
4176 ;; the parent to avoid interim `allout-aberrant-container-p'
4177 ;; aberrancy, and vice-versa when shifting in:
4178 (if (>= relative-depth
0)
4179 (allout-rebullet-heading nil
4180 (+ starting-depth relative-depth
)
4183 nil
)) ;;; do-successors
4184 (when (not sans-offspring
)
4185 ;; ... and work on subsequent ones which are at greater depth:
4187 (allout-next-heading)
4188 (while (and (not (eobp))
4189 (< starting-depth
(allout-depth)))
4190 (setq index
(1+ index
))
4191 (allout-rebullet-topic-grunt relative-depth
4195 (when (< relative-depth
0)
4197 (goto-char local-point
)
4198 (allout-rebullet-heading nil
;;; instead
4199 (+ starting-depth relative-depth
)
4202 nil
)))) ;;; do-successors
4204 ((< starting-depth new-depth
)
4205 ;; Rare case -- subtopic more than one level deeper than parent.
4206 ;; Treat this one at an even deeper level:
4207 (allout-rebullet-topic-grunt relative-depth
4213 (if on-starting-call
4215 ;; Rectify numbering of former siblings of the adjusted topic,
4216 ;; if topic has changed depth
4217 (if (or do-successors
4218 (and (not (zerop relative-depth
))
4219 (or (= allout-recent-depth starting-depth
)
4220 (= allout-recent-depth
(+ starting-depth
4222 (allout-rebullet-heading nil nil nil nil t
))
4223 ;; Now rectify numbering of new siblings of the adjusted topic,
4224 ;; if depth has been changed:
4225 (progn (goto-char starting-point
)
4226 (if (not (zerop relative-depth
))
4227 (allout-rebullet-heading nil nil nil nil t
)))))
4230 ;;;_ > allout-renumber-to-depth (&optional depth)
4231 (defun allout-renumber-to-depth (&optional depth
)
4232 "Renumber siblings at current depth.
4234 Affects superior topics if optional arg DEPTH is less than current depth.
4236 Returns final depth."
4238 ;; Proceed by level, processing subsequent siblings on each,
4239 ;; ascending until we get shallower than the start depth:
4241 (let ((ascender (allout-depth))
4243 (while (and (not (eobp))
4245 (>= allout-recent-depth depth
)
4246 (>= ascender depth
))
4247 ; Skip over all topics at
4248 ; lesser depths, which can not
4249 ; have been disturbed:
4250 (while (and (not (setq was-eobp
(eobp)))
4251 (> allout-recent-depth ascender
))
4252 (allout-next-heading))
4253 ; Prime ascender for ascension:
4254 (setq ascender
(1- allout-recent-depth
))
4255 (if (>= allout-recent-depth depth
)
4256 (allout-rebullet-heading nil
;;; instead
4258 nil
;;; number-control
4260 t
)) ;;; do-successors
4261 (if was-eobp
(goto-char (point-max)))))
4262 allout-recent-depth
)
4263 ;;;_ > allout-number-siblings (&optional denumber)
4264 (defun allout-number-siblings (&optional denumber
)
4265 "Assign numbered topic prefix to this topic and its siblings.
4267 With universal argument, denumber -- assign default bullet to this
4268 topic and its siblings.
4270 With repeated universal argument (`^U^U'), solicit bullet for each
4271 rebulleting each topic at this level."
4276 (allout-back-to-current-heading)
4277 (allout-beginning-of-level)
4278 (let ((depth allout-recent-depth
)
4279 (index (if (not denumber
) 1))
4280 (use-bullet (equal '(16) denumber
))
4283 (allout-rebullet-heading use-bullet
;;; instead
4285 t
;;; number-control
4287 nil
) ;;; do-successors
4288 (if index
(setq index
(1+ index
)))
4289 (setq more
(allout-next-sibling depth nil
))))))
4290 ;;;_ > allout-shift-in (arg)
4291 (defun allout-shift-in (arg)
4292 "Increase depth of current heading and any items collapsed within it.
4294 With a negative argument, the item is shifted out using
4295 `allout-shift-out', instead.
4297 With an argument greater than one, shift-in the item but not its
4298 offspring, making the item into a sibling of its former children,
4299 and a child of sibling that formerly preceded it.
4301 You are not allowed to shift the first offspring of a topic
4302 inwards, because that would yield a \"containment
4303 discontinuity\", where the depth difference between a topic and
4304 its immediate offspring is greater than one. The first topic in
4305 the file can be adjusted to any positive depth, however."
4309 (allout-shift-out (* arg -
1))
4310 ;; refuse to create a containment discontinuity:
4312 (allout-back-to-current-heading)
4314 (let* ((current-depth allout-recent-depth
)
4315 (start-point (point))
4316 (predecessor-depth (progn
4318 (allout-goto-prefix-doublechecked)
4319 (if (< (point) start-point
)
4322 (if (and (> predecessor-depth
0)
4323 (> (1+ current-depth
)
4324 (1+ predecessor-depth
)))
4325 (error (concat "Disallowed shift deeper than"
4326 " containing topic's children."))
4327 (allout-back-to-current-heading)
4328 (if (< allout-recent-depth
(1+ current-depth
))
4329 (allout-show-children))))))
4330 (let ((where (point)))
4331 (allout-rebullet-topic 1 (and (> arg
1) 'sans-offspring
))
4332 (run-hook-with-args 'allout-structure-shifted-hook arg where
))))
4333 ;;;_ > allout-shift-out (arg)
4334 (defun allout-shift-out (arg)
4335 "Decrease depth of current heading and any topics collapsed within it.
4336 This will make the item a sibling of its former container.
4338 With a negative argument, the item is shifted in using
4339 `allout-shift-in', instead.
4341 With an argument greater than one, shift-out the item's offspring
4342 but not the item itself, making the former children siblings of
4345 With an argument greater than 1, the item's offspring are shifted
4346 out without shifting the item. This will make the immediate
4347 subtopics into siblings of the item."
4350 (allout-shift-in (* arg -
1))
4351 ;; Get proper exposure in this area:
4352 (save-excursion (if (allout-ascend)
4353 (allout-show-children)))
4354 ;; Show collapsed children if there's a successor which will become
4356 (if (and (allout-current-topic-collapsed-p)
4357 (save-excursion (allout-next-sibling)))
4358 (allout-show-children))
4359 (let ((where (and (allout-depth) allout-recent-prefix-beginning
)))
4362 ;; Shift the offspring but not the topic:
4363 (let ((children-chart (allout-chart-subtree 1)))
4364 (if (listp (car children-chart
))
4366 (setq children-chart
(allout-flatten children-chart
)))
4368 (dolist (child-point children-chart
)
4369 (goto-char child-point
)
4370 (allout-shift-out 1))))
4371 (allout-rebullet-topic (* arg -
1))))
4372 (run-hook-with-args 'allout-structure-shifted-hook
(* arg -
1) where
))))
4373 ;;;_ : Surgery (kill-ring) functions with special provisions for outlines:
4374 ;;;_ > allout-kill-line (&optional arg)
4375 (defun allout-kill-line (&optional arg
)
4376 "Kill line, adjusting subsequent lines suitably for outline mode."
4380 (if (or (not (allout-mode-p))
4382 (not (save-match-data (looking-at allout-regexp
))))
4383 ;; Just do a regular kill:
4385 ;; Ah, have to watch out for adjustments:
4386 (let* ((beg (point))
4388 (beg-hidden (allout-hidden-p))
4389 (end-hidden (save-excursion (allout-end-of-current-line)
4392 (depth (allout-depth)))
4394 (allout-annotate-hidden beg end
)
4396 (if (and (not beg-hidden
) (not end-hidden
))
4397 (allout-unprotected (kill-line arg
))
4399 (run-hooks 'allout-after-copy-or-kill-hook
)
4400 (allout-deannotate-hidden beg end
)
4402 (if allout-numbered-bullet
4403 (save-excursion ; Renumber subsequent topics if needed:
4404 (if (not (save-match-data (looking-at allout-regexp
)))
4405 (allout-next-heading))
4406 (allout-renumber-to-depth depth
)))
4407 (run-hook-with-args 'allout-structure-deleted-hook depth
(point))))))
4408 ;;;_ > allout-copy-line-as-kill ()
4409 (defun allout-copy-line-as-kill ()
4410 "Like `allout-kill-topic', but save to kill ring instead of deleting."
4412 (let ((buffer-read-only t
))
4415 (buffer-read-only nil
))))
4416 ;;;_ > allout-kill-topic ()
4417 (defun allout-kill-topic ()
4418 "Kill topic together with subtopics.
4420 Trailing whitespace is killed with a topic if that whitespace:
4422 - would separate the topic from a subsequent sibling
4423 - would separate the topic from the end of buffer
4424 - would not be added to whitespace already separating the topic from the
4427 Topic exposure is marked with text-properties, to be used by
4428 `allout-yank-processing' for exposure recovery."
4431 (let* ((inhibit-field-text-motion t
)
4432 (beg (prog1 (allout-back-to-current-heading) (beginning-of-line)))
4434 (depth allout-recent-depth
))
4435 (allout-end-of-current-subtree)
4436 (if (and (/= (current-column) 0) (not (eobp)))
4439 (if (and (save-match-data (looking-at "\n"))
4441 (or (not (allout-next-heading))
4442 (= depth allout-recent-depth
)))
4443 (and (> (- beg
(point-min)) 3)
4444 (string= (buffer-substring (- beg
2) beg
) "\n\n"))))
4447 (allout-annotate-hidden beg
(setq end
(point)))
4448 (unwind-protect ; for possible barf-if-buffer-read-only.
4449 (allout-unprotected (kill-region beg end
))
4450 (allout-deannotate-hidden beg end
)
4451 (run-hooks 'allout-after-copy-or-kill-hook
)
4454 (allout-renumber-to-depth depth
))
4455 (run-hook-with-args 'allout-structure-deleted-hook depth
(point)))))
4456 ;;;_ > allout-copy-topic-as-kill ()
4457 (defun allout-copy-topic-as-kill ()
4458 "Like `allout-kill-topic', but save to kill ring instead of deleting."
4460 (let ((buffer-read-only t
))
4463 (buffer-read-only (message "Topic copied...")))))
4464 ;;;_ > allout-annotate-hidden (begin end)
4465 (defun allout-annotate-hidden (begin end
)
4466 "Qualify text with properties to indicate exposure status."
4468 (let ((was-modified (buffer-modified-p))
4469 (buffer-read-only nil
))
4470 (allout-deannotate-hidden begin end
)
4473 (let (done next prev overlay
)
4475 ;; at or advance to start of next hidden region:
4476 (if (not (allout-hidden-p))
4479 (allout-next-single-char-property-change (point)
4482 (if (or (not next
) (eq prev next
))
4483 ;; still not at start of hidden area -- must not be any left.
4487 (if (not (allout-hidden-p))
4488 ;; still not at start of hidden area.
4490 (setq overlay
(allout-get-invisibility-overlay))
4491 (setq next
(overlay-end overlay
)
4493 ;; advance to end of this hidden area:
4497 (let ((buffer-undo-list t
))
4498 (put-text-property (overlay-start overlay
) next
4499 'allout-was-hidden t
)))))))))
4500 (set-buffer-modified-p was-modified
)))
4501 ;;;_ > allout-deannotate-hidden (begin end)
4502 (defun allout-deannotate-hidden (begin end
)
4503 "Remove allout hidden-text annotation between BEGIN and END."
4506 (let ((inhibit-read-only t
)
4507 (buffer-undo-list t
))
4508 (remove-text-properties begin
(min end
(point-max))
4509 '(allout-was-hidden t
)))))
4510 ;;;_ > allout-hide-by-annotation (begin end)
4511 (defun allout-hide-by-annotation (begin end
)
4512 "Translate text properties indicating exposure status into actual exposure."
4515 (let ((was-modified (buffer-modified-p))
4518 ;; at or advance to start of next annotation:
4519 (if (not (get-text-property (point) 'allout-was-hidden
))
4520 (setq next
(allout-next-single-char-property-change
4521 (point) 'allout-was-hidden nil end
)))
4522 (if (or (not next
) (eq prev next
))
4523 ;; no more or not advancing -- must not be any left.
4527 (if (not (get-text-property (point) 'allout-was-hidden
))
4528 ;; still not at start of annotation.
4530 ;; advance to just after end of this annotation:
4531 (setq next
(allout-next-single-char-property-change
4532 (point) 'allout-was-hidden nil end
))
4533 (let ((o (make-overlay prev next nil
'front-advance
)))
4534 (overlay-put o
'category
'allout-exposure-category
)
4535 (overlay-put o
'evaporate t
))
4536 (allout-deannotate-hidden prev next
)
4538 (if next
(goto-char next
)))))
4539 (set-buffer-modified-p was-modified
))))
4540 ;;;_ > allout-yank-processing ()
4541 (defun allout-yank-processing (&optional arg
)
4543 "Incidental allout-specific business to be done just after text yanks.
4545 Does depth adjustment of yanked topics, when:
4547 1 the stuff being yanked starts with a valid outline header prefix, and
4548 2 it is being yanked at the end of a line which consists of only a valid
4551 Also, adjusts numbering of subsequent siblings when appropriate.
4553 Depth adjustment alters the depth of all the topics being yanked
4554 the amount it takes to make the first topic have the depth of the
4555 header into which it's being yanked.
4557 The point is left in front of yanked, adjusted topics, rather than
4558 at the end (and vice-versa with the mark). Non-adjusted yanks,
4559 however, are left exactly like normal, non-allout-specific yanks."
4562 ; Get to beginning, leaving
4563 ; region around subject:
4564 (if (< (allout-mark-marker t
) (point))
4565 (exchange-point-and-mark))
4567 (let* ((subj-beg (point))
4569 (subj-end (allout-mark-marker t
))
4570 ;; 'resituate' if yanking an entire topic into topic header:
4571 (resituate (and (let ((allout-inhibit-aberrance-doublecheck t
))
4572 (allout-e-o-prefix-p))
4573 (looking-at allout-regexp
)
4574 (allout-prefix-data)))
4575 ;; `rectify-numbering' if resituating (where several topics may
4576 ;; be resituating) or yanking a topic into a topic slot (bol):
4577 (rectify-numbering (or resituate
4578 (and into-bol
(looking-at allout-regexp
)))))
4580 ;; Yanking a topic into the start of a topic -- reconcile to fit:
4581 (let* ((inhibit-field-text-motion t
)
4582 (prefix-len (if (not (match-end 1))
4584 (- (match-end 1) subj-beg
)))
4585 (subj-depth allout-recent-depth
)
4586 (prefix-bullet (allout-recent-bullet))
4588 ;; Nil if adjustment unnecessary, otherwise depth to which
4589 ;; adjustment should be made:
4591 (and (goto-char subj-end
)
4593 (goto-char subj-beg
)
4594 (and (looking-at allout-regexp
)
4597 (not (= (point) subj-beg
)))
4598 (looking-at allout-regexp
)
4599 (allout-prefix-data))
4600 allout-recent-depth
)))
4602 (setq rectify-numbering allout-numbered-bullet
)
4604 ; Do the adjustment:
4607 (narrow-to-region subj-beg subj-end
)
4608 ; Trim off excessive blank
4609 ; line at end, if any:
4610 (goto-char (point-max))
4611 (if (looking-at "^$")
4612 (allout-unprotected (delete-char -
1)))
4613 ; Work backwards, with each
4615 ; successively excluding the
4616 ; last processed topic from
4617 ; the narrow region:
4619 (allout-back-to-current-heading)
4620 ; go as high as we can in each bunch:
4621 (while (allout-ascend t
))
4624 (allout-rebullet-topic-grunt (- adjust-to-depth
4627 (if (setq more
(not (bobp)))
4630 (narrow-to-region subj-beg
(point))))))
4631 ;; Remove new heading prefix:
4634 (delete-region (point) (+ (point)
4638 ; and delete residual subj
4639 ; prefix digits and space:
4640 (while (looking-at "[0-9]") (delete-char 1))
4644 ;; Assert new topic's bullet - minimal effort if unchanged:
4645 (allout-rebullet-heading (string-to-char prefix-bullet
)))
4646 (exchange-point-and-mark))))
4647 (if rectify-numbering
4650 ; Give some preliminary feedback:
4651 (message "... reconciling numbers")
4652 ; ... and renumber, in case necessary:
4653 (goto-char subj-beg
)
4654 (if (allout-goto-prefix-doublechecked)
4656 (allout-rebullet-heading nil
;;; instead
4657 (allout-depth) ;;; depth
4658 nil
;;; number-control
4662 (if (or into-bol resituate
)
4663 (allout-hide-by-annotation (point) (allout-mark-marker t
))
4664 (allout-deannotate-hidden (allout-mark-marker t
) (point)))
4666 (exchange-point-and-mark))
4667 (run-hook-with-args 'allout-structure-added-hook subj-beg subj-end
))))
4668 ;;;_ > allout-yank (&optional arg)
4669 (defun allout-yank (&optional arg
)
4670 "`allout-mode' yank, with depth and numbering adjustment of yanked topics.
4672 Non-topic yanks work no differently than normal yanks.
4674 If a topic is being yanked into a bare topic prefix, the depth of the
4675 yanked topic is adjusted to the depth of the topic prefix.
4677 1 we're yanking in an `allout-mode' buffer
4678 2 the stuff being yanked starts with a valid outline header prefix, and
4679 3 it is being yanked at the end of a line which consists of only a valid
4682 If these conditions hold then the depth of the yanked topics are all
4683 adjusted the amount it takes to make the first one at the depth of the
4684 header into which it's being yanked.
4686 The point is left in front of yanked, adjusted topics, rather than
4687 at the end (and vice-versa with the mark). Non-adjusted yanks,
4688 however, (ones that don't qualify for adjustment) are handled
4689 exactly like normal yanks.
4691 Numbering of yanked topics, and the successive siblings at the depth
4692 into which they're being yanked, is adjusted.
4694 `allout-yank-pop' works with `allout-yank' just like normal `yank-pop'
4695 works with normal `yank' in non-outline buffers."
4698 (setq this-command
'yank
)
4702 (allout-yank-processing)))
4703 ;;;_ > allout-yank-pop (&optional arg)
4704 (defun allout-yank-pop (&optional arg
)
4705 "Yank-pop like `allout-yank' when popping to bare outline prefixes.
4707 Adapts level of popped topics to level of fresh prefix.
4709 Note -- prefix changes to distinctive bullets will stick, if followed
4710 by pops to non-distinctive yanks. Bug..."
4713 (setq this-command
'yank
)
4716 (allout-yank-processing)))
4718 ;;;_ - Specialty bullet functions
4719 ;;;_ : File Cross references
4720 ;;;_ > allout-resolve-xref ()
4721 (defun allout-resolve-xref ()
4722 "Pop to file associated with current heading, if it has an xref bullet.
4724 \(Works according to setting of `allout-file-xref-bullet')."
4726 (if (not allout-file-xref-bullet
)
4728 "Outline cross references disabled -- no `allout-file-xref-bullet'")
4729 (if (not (string= (allout-current-bullet) allout-file-xref-bullet
))
4730 (error "Current heading lacks cross-reference bullet `%s'"
4731 allout-file-xref-bullet
)
4732 (let ((inhibit-field-text-motion t
)
4736 (let* ((text-start allout-recent-prefix-end
)
4737 (heading-end (point-at-eol)))
4738 (goto-char text-start
)
4740 (if (re-search-forward "\\s-\\(\\S-*\\)" heading-end t
)
4741 (buffer-substring (match-beginning 1)
4743 (setq file-name
(expand-file-name file-name
))
4744 (if (or (file-exists-p file-name
)
4745 (if (file-writable-p file-name
)
4746 (y-or-n-p (format "%s not there, create one? "
4748 (error "%s not found and can't be created" file-name
)))
4749 (condition-case failure
4750 (find-file-other-window file-name
)
4752 (error "%s not found" file-name
))
4758 ;;;_ #6 Exposure Control
4761 ;;;_ > allout-flag-region (from to flag)
4762 (defun allout-flag-region (from to flag
)
4763 "Conceal text between FROM and TO if FLAG is non-nil, else reveal it.
4765 Exposure-change hook `allout-exposure-change-hook' is run with the same
4766 arguments as this function, after the exposure changes are made."
4768 ;; We use outline invisibility spec.
4769 (remove-overlays from to
'category
'allout-exposure-category
)
4771 (let ((o (make-overlay from to nil
'front-advance
)))
4772 (overlay-put o
'category
'allout-exposure-category
)
4773 (overlay-put o
'evaporate t
)
4774 (when (featurep 'xemacs
)
4775 (let ((props (symbol-plist 'allout-exposure-category
)))
4778 ;; as of 2008-02-27, xemacs lacks modification-hooks
4779 (overlay-put o
(pop props
) (pop props
))
4781 (setq allout-this-command-hid-text t
))
4782 (run-hook-with-args 'allout-exposure-change-hook from to flag
))
4783 ;;;_ > allout-flag-current-subtree (flag)
4784 (defun allout-flag-current-subtree (flag)
4785 "Conceal currently-visible topic's subtree if FLAG non-nil, else reveal it."
4788 (allout-back-to-current-heading)
4789 (let ((inhibit-field-text-motion t
))
4791 (allout-flag-region (point)
4792 ;; Exposing must not leave trailing blanks hidden,
4793 ;; but can leave them exposed when hiding, so we
4794 ;; can use flag's inverse as the
4795 ;; include-trailing-blank cue:
4796 (allout-end-of-current-subtree (not flag
))
4799 ;;;_ - Topic-specific
4800 ;;;_ > allout-show-entry ()
4801 (defun allout-show-entry ()
4802 "Like `allout-show-current-entry', but reveals entries in hidden topics.
4804 This is a way to give restricted peek at a concealed locality without the
4805 expense of exposing its context, but can leave the outline with aberrant
4806 exposure. `allout-show-offshoot' should be used after the peek to rectify
4812 (allout-goto-prefix-doublechecked)
4813 (setq beg
(if (allout-hidden-p) (1- (point)) (point)))
4814 (setq end
(allout-pre-next-prefix))
4815 (allout-flag-region beg end nil
)
4817 ;;;_ > allout-show-children (&optional level strict)
4818 (defun allout-show-children (&optional level strict
)
4820 "If point is visible, show all direct subheadings of this heading.
4822 Otherwise, do `allout-show-to-offshoot', and then show subheadings.
4824 Optional LEVEL specifies how many levels below the current level
4825 should be shown, or all levels if t. Default is 1.
4827 Optional STRICT means don't resort to -show-to-offshoot, no matter
4828 what. This is basically so -show-to-offshoot, which is called by
4829 this function, can employ the pure offspring-revealing capabilities of
4832 Returns point at end of subtree that was opened, if any. (May get a
4833 point of non-opened subtree?)"
4836 (let ((start-point (point)))
4837 (if (and (not strict
)
4840 (progn (allout-show-to-offshoot) ; Point's concealed, open to
4842 ;; Then recurse, but with "strict" set so we don't
4843 ;; infinite regress:
4844 (allout-show-children level t
))
4847 (allout-beginning-of-current-line)
4850 ;; translate the level spec for this routine to the ones
4851 ;; used by -chart-subtree and -chart-to-reveal:
4852 (chart-level (cond ((not level
) 1)
4855 (chart (allout-chart-subtree chart-level
))
4856 (to-reveal (or (allout-chart-to-reveal chart chart-level
)
4857 ;; interactive, show discontinuous children:
4859 (allout-called-interactively-p)
4861 (allout-back-to-current-heading)
4862 (setq depth
(allout-current-depth))
4863 (and (allout-next-heading)
4864 (> allout-recent-depth
4867 "Discontinuous offspring; use `%s %s'%s."
4868 (substitute-command-keys
4869 "\\[universal-argument]")
4870 (substitute-command-keys
4871 "\\[allout-shift-out]")
4872 " to elevate them.")
4873 (allout-chart-to-reveal
4874 chart
(- allout-recent-depth depth
))))))
4875 (goto-char start-point
)
4876 (when (and strict
(allout-hidden-p))
4877 ;; Concealed root would already have been taken care of,
4878 ;; unless strict was set.
4879 (allout-flag-region (point) (allout-snug-back) nil
)
4880 (when allout-show-bodies
4881 (goto-char (car to-reveal
))
4882 (allout-show-current-entry)))
4884 (goto-char (car to-reveal
))
4885 (allout-flag-region (save-excursion (allout-snug-back) (point))
4886 (progn (search-forward "\n" nil t
)
4889 (when allout-show-bodies
4890 (goto-char (car to-reveal
))
4891 (allout-show-current-entry))
4892 (setq to-reveal
(cdr to-reveal
)))))))
4893 ;; Compensate for `save-excursion's maintenance of point
4894 ;; within invisible text:
4895 (goto-char start-point
)))
4896 ;;;_ > allout-show-to-offshoot ()
4897 (defun allout-show-to-offshoot ()
4898 "Like `allout-show-entry', but reveals all concealed ancestors, as well.
4900 Useful for coherently exposing to a random point in a hidden region."
4903 (let ((inhibit-field-text-motion t
)
4905 (orig-pref (allout-goto-prefix-doublechecked))
4908 (while (or (> bag-it
1) (allout-hidden-p))
4909 (while (allout-hidden-p)
4910 (move-beginning-of-line 1)
4911 (if (allout-hidden-p) (forward-char -
1)))
4912 (if (= last-at
(setq last-at
(point)))
4913 ;; Oops, we're not making any progress! Show the current topic
4914 ;; completely, and try one more time here, if we haven't already.
4915 (progn (beginning-of-line)
4916 (allout-show-current-subtree)
4918 (setq bag-it
(1+ bag-it
))
4920 (error "allout-show-to-offshoot: %s"
4921 "Stumped by aberrant nesting.")))
4922 (if (> bag-it
0) (setq bag-it
0))
4923 (allout-show-children)
4924 (goto-char orig-pref
)))
4925 (goto-char orig-pt
)))
4926 (if (allout-hidden-p)
4927 (allout-show-entry)))
4928 ;;;_ > allout-hide-current-entry ()
4929 (defun allout-hide-current-entry ()
4930 "Hide the body directly following this heading."
4932 (allout-back-to-current-heading)
4934 (let ((inhibit-field-text-motion t
))
4936 (allout-flag-region (point)
4937 (progn (allout-end-of-entry) (point))
4939 ;;;_ > allout-show-current-entry (&optional arg)
4940 (defun allout-show-current-entry (&optional arg
)
4941 "Show body following current heading, or hide entry with universal argument."
4945 (allout-hide-current-entry)
4946 (save-excursion (allout-show-to-offshoot))
4948 (allout-flag-region (point)
4949 (progn (allout-end-of-entry t
) (point))
4952 ;;;_ > allout-show-current-subtree (&optional arg)
4953 (defun allout-show-current-subtree (&optional arg
)
4954 "Show everything within the current topic.
4955 With a repeat-count, expose this topic and its siblings."
4958 (if (<= (allout-current-depth) 0)
4959 ;; Outside any topics -- try to get to the first:
4960 (if (not (allout-next-heading))
4962 ;; got to first, outermost topic -- set to expose it and siblings:
4963 (message "Above outermost topic -- exposing all.")
4964 (allout-flag-region (point-min)(point-max) nil
))
4965 (allout-beginning-of-current-line)
4967 (allout-flag-current-subtree nil
)
4968 (allout-beginning-of-level)
4969 (allout-expose-topic '(* :))))))
4970 ;;;_ > allout-current-topic-collapsed-p (&optional include-single-liners)
4971 (defun allout-current-topic-collapsed-p (&optional include-single-liners
)
4972 "True if the currently visible containing topic is already collapsed.
4974 Single line topics intrinsically can be considered as being both
4975 collapsed and uncollapsed. If optional INCLUDE-SINGLE-LINERS is
4976 true, then single-line topics are considered to be collapsed. By
4977 default, they are treated as being uncollapsed."
4981 ;; Is the topic all on one line (allowing for trailing blank line)?
4982 (>= (progn (allout-back-to-current-heading)
4983 (let ((inhibit-field-text-motion t
))
4984 (move-end-of-line 1))
4986 (allout-end-of-current-subtree (not (looking-at "\n\n"))))
4988 (or include-single-liners
4989 (progn (backward-char 1) (allout-hidden-p)))))))
4990 ;;;_ > allout-hide-current-subtree (&optional just-close)
4991 (defun allout-hide-current-subtree (&optional just-close
)
4992 "Close the current topic, or containing topic if this one is already closed.
4994 If this topic is closed and it's a top level topic, close this topic
4997 If optional arg JUST-CLOSE is non-nil, do not close the parent or
4998 siblings, even if the target topic is already closed."
5001 (let* ((from (point))
5002 (sibs-msg "Top-level topic already closed -- closing siblings...")
5003 (current-exposed (not (allout-current-topic-collapsed-p t
))))
5004 (cond (current-exposed (allout-flag-current-subtree t
))
5006 ((allout-ascend) (allout-hide-current-subtree))
5009 (allout-goto-prefix-doublechecked)
5010 (allout-expose-topic '(0 :))
5011 (message (concat sibs-msg
" Done."))))
5013 ;;;_ > allout-toggle-current-subtree-exposure
5014 (defun allout-toggle-current-subtree-exposure ()
5015 "Show or hide the current subtree depending on its current state."
5016 ;; thanks to tassilo for suggesting this.
5019 (allout-back-to-heading)
5020 (if (allout-hidden-p (point-at-eol))
5021 (allout-show-current-subtree)
5022 (allout-hide-current-subtree))))
5023 ;;;_ > allout-show-current-branches ()
5024 (defun allout-show-current-branches ()
5025 "Show all subheadings of this heading, but not their bodies."
5027 (let ((inhibit-field-text-motion t
))
5028 (beginning-of-line))
5029 (allout-show-children t
))
5030 ;;;_ > allout-hide-current-leaves ()
5031 (defun allout-hide-current-leaves ()
5032 "Hide the bodies of the current topic and all its offspring."
5034 (allout-back-to-current-heading)
5035 (allout-hide-region-body (point) (progn (allout-end-of-current-subtree)
5038 ;;;_ - Region and beyond
5039 ;;;_ > allout-show-all ()
5040 (defun allout-show-all ()
5041 "Show all of the text in the buffer."
5043 (message "Exposing entire buffer...")
5044 (allout-flag-region (point-min) (point-max) nil
)
5045 (message "Exposing entire buffer... Done."))
5046 ;;;_ > allout-hide-bodies ()
5047 (defun allout-hide-bodies ()
5048 "Hide all of buffer except headings."
5050 (allout-hide-region-body (point-min) (point-max)))
5051 ;;;_ > allout-hide-region-body (start end)
5052 (defun allout-hide-region-body (start end
)
5053 "Hide all body lines in the region, but not headings."
5057 (narrow-to-region start end
)
5058 (goto-char (point-min))
5059 (let ((inhibit-field-text-motion t
))
5062 (allout-flag-region (point) (allout-end-of-entry) t
)
5065 (if (looking-at "\n\n")
5068 ;;;_ > allout-expose-topic (spec)
5069 (defun allout-expose-topic (spec)
5070 "Apply exposure specs to successive outline topic items.
5072 Use the more convenient frontend, `allout-new-exposure', if you don't
5073 need evaluation of the arguments, or even better, the `allout-layout'
5074 variable-keyed mode-activation/auto-exposure feature of allout outline
5075 mode. See the respective documentation strings for more details.
5077 Cursor is left at start position.
5079 SPEC is either a number or a list.
5081 Successive specs on a list are applied to successive sibling topics.
5083 A simple spec (either a number, one of a few symbols, or the null
5084 list) dictates the exposure for the corresponding topic.
5086 Non-null lists recursively designate exposure specs for respective
5087 subtopics of the current topic.
5089 The `:' repeat spec is used to specify exposure for any number of
5090 successive siblings, up to the trailing ones for which there are
5091 explicit specs following the `:'.
5093 Simple (numeric and null-list) specs are interpreted as follows:
5095 Numbers indicate the relative depth to open the corresponding topic.
5096 - negative numbers force the topic to be closed before opening to the
5097 absolute value of the number, so all siblings are open only to
5099 - positive numbers open to the relative depth indicated by the
5100 number, but do not force already opened subtopics to be closed.
5101 - 0 means to close topic -- hide all offspring.
5103 apply prior element to all siblings at current level, *up to*
5104 those siblings that would be covered by specs following the `:'
5105 on the list. Ie, apply to all topics at level but the last
5106 ones. (Only first of multiple colons at same level is
5107 respected -- subsequent ones are discarded.)
5108 * - completely opens the topic, including bodies.
5109 + - shows all the sub headers, but not the bodies
5110 - - exposes the body of the corresponding topic.
5113 \(allout-expose-topic '(-1 : 0))
5114 Close this and all following topics at current level, exposing
5115 only their immediate children, but close down the last topic
5116 at this current level completely.
5117 \(allout-expose-topic '(-1 () : 1 0))
5118 Close current topic so only the immediate subtopics are shown;
5119 show the children in the second to last topic, and completely
5121 \(allout-expose-topic '(-2 : -1 *))
5122 Expose children and grandchildren of all topics at current
5123 level except the last two; expose children of the second to
5124 last and completely open the last one."
5126 (interactive "xExposure spec: ")
5127 (if (not (listp spec
))
5129 (let ((depth (allout-depth))
5134 (setq prev-elem curr-elem
5135 curr-elem
(car spec
)
5137 (cond ; Do current element:
5138 ((null curr-elem
) nil
)
5139 ((symbolp curr-elem
)
5140 (cond ((eq curr-elem
'*) (allout-show-current-subtree)
5141 (if (> allout-recent-end-of-subtree max-pos
)
5142 (setq max-pos allout-recent-end-of-subtree
)))
5144 (if (not (allout-hidden-p))
5145 (save-excursion (allout-hide-current-subtree t
)))
5146 (allout-show-current-branches)
5147 (if (> allout-recent-end-of-subtree max-pos
)
5148 (setq max-pos allout-recent-end-of-subtree
)))
5149 ((eq curr-elem
'-
) (allout-show-current-entry))
5152 ;; Expand the `repeat' spec to an explicit version,
5153 ;; w.r.t. remaining siblings:
5154 (let ((residue ; = # of sibs not covered by remaining spec
5155 ;; Dang, could be nice to make use of the chart, sigh:
5156 (- (length (allout-chart-siblings))
5159 ;; Some residue -- cover it with prev-elem:
5160 (setq spec
(append (make-list residue prev-elem
)
5162 ((numberp curr-elem
)
5163 (if (and (>= 0 curr-elem
) (not (allout-hidden-p)))
5164 (save-excursion (allout-hide-current-subtree t
)
5167 (if (> allout-recent-end-of-subtree max-pos
)
5169 allout-recent-end-of-subtree
)))))
5170 (if (> (abs curr-elem
) 0)
5171 (progn (allout-show-children (abs curr-elem
))
5172 (if (> allout-recent-end-of-subtree max-pos
)
5173 (setq max-pos allout-recent-end-of-subtree
)))))
5175 (if (allout-descend-to-depth (1+ depth
))
5176 (let ((got (allout-expose-topic curr-elem
)))
5177 (if (and got
(> got max-pos
)) (setq max-pos got
))))))
5178 (cond (stay (setq stay nil
))
5179 ((listp (car spec
)) nil
)
5180 ((> max-pos
(point))
5181 ;; Capitalize on max-pos state to get us nearer next sibling:
5182 (progn (goto-char (min (point-max) max-pos
))
5183 (allout-next-heading)))
5184 ((allout-next-sibling depth
))))
5186 ;;;_ > allout-old-expose-topic (spec &rest followers)
5187 (defun allout-old-expose-topic (spec &rest followers
)
5189 "Deprecated. Use `allout-expose-topic' (with different schema
5192 Dictate wholesale exposure scheme for current topic, according to SPEC.
5194 SPEC is either a number or a list. Optional successive args
5195 dictate exposure for subsequent siblings of current topic.
5197 A simple spec (either a number, a special symbol, or the null list)
5198 dictates the overall exposure for a topic. Non null lists are
5199 composite specs whose first element dictates the overall exposure for
5200 a topic, with the subsequent elements in the list interpreted as specs
5201 that dictate the exposure for the successive offspring of the topic.
5203 Simple (numeric and null-list) specs are interpreted as follows:
5205 - Numbers indicate the relative depth to open the corresponding topic:
5206 - negative numbers force the topic to be close before opening to the
5207 absolute value of the number.
5208 - positive numbers just open to the relative depth indicated by the number.
5210 - `*' completely opens the topic, including bodies.
5211 - `+' shows all the sub headers, but not the bodies
5212 - `-' exposes the body and immediate offspring of the corresponding topic.
5214 If the spec is a list, the first element must be a number, which
5215 dictates the exposure depth of the topic as a whole. Subsequent
5216 elements of the list are nested SPECs, dictating the specific exposure
5217 for the corresponding offspring of the topic.
5219 Optional FOLLOWERS arguments dictate exposure for succeeding siblings."
5221 (interactive "xExposure spec: ")
5222 (let ((inhibit-field-text-motion t
)
5223 (depth (allout-current-depth))
5225 (cond ((null spec
) nil
)
5227 (if (eq spec
'*) (allout-show-current-subtree))
5228 (if (eq spec
'+) (allout-show-current-branches))
5229 (if (eq spec
'-
) (allout-show-current-entry)))
5232 (save-excursion (allout-hide-current-subtree t
)
5234 (if (or (not max-pos
)
5235 (> (point) max-pos
))
5236 (setq max-pos
(point)))
5238 (setq spec
(* -
1 spec
)))))
5240 (allout-show-children spec
)))
5242 ;(let ((got (allout-old-expose-topic (car spec))))
5243 ; (if (and got (or (not max-pos) (> got max-pos)))
5244 ; (setq max-pos got)))
5245 (let ((new-depth (+ (allout-current-depth) 1))
5247 (setq max-pos
(allout-old-expose-topic (car spec
)))
5248 (setq spec
(cdr spec
))
5250 (allout-descend-to-depth new-depth
)
5251 (not (allout-hidden-p)))
5252 (progn (setq got
(apply 'allout-old-expose-topic spec
))
5253 (if (and got
(or (not max-pos
) (> got max-pos
)))
5254 (setq max-pos got
)))))))
5255 (while (and followers
5256 (progn (if (and max-pos
(< (point) max-pos
))
5257 (progn (goto-char max-pos
)
5258 (setq max-pos nil
)))
5260 (allout-next-sibling depth
)))
5261 (allout-old-expose-topic (car followers
))
5262 (setq followers
(cdr followers
)))
5264 ;;;_ > allout-new-exposure '()
5265 (defmacro allout-new-exposure
(&rest spec
)
5266 "Literal frontend for `allout-expose-topic', doesn't evaluate arguments.
5267 Some arguments that would need to be quoted in `allout-expose-topic'
5268 need not be quoted in `allout-new-exposure'.
5270 Cursor is left at start position.
5272 Use this instead of obsolete `allout-exposure'.
5275 \(allout-new-exposure (-1 () () () 1) 0)
5276 Close current topic at current level so only the immediate
5277 subtopics are shown, except also show the children of the
5278 third subtopic; and close the next topic at the current level.
5279 \(allout-new-exposure : -1 0)
5280 Close all topics at current level to expose only their
5281 immediate children, except for the last topic at the current
5282 level, in which even its immediate children are hidden.
5283 \(allout-new-exposure -2 : -1 *)
5284 Expose children and grandchildren of first topic at current
5285 level, and expose children of subsequent topics at current
5286 level *except* for the last, which should be opened completely."
5287 (list 'save-excursion
5288 '(if (not (or (allout-goto-prefix-doublechecked)
5289 (allout-next-heading)))
5290 (error "allout-new-exposure: Can't find any outline topics"))
5291 (list 'allout-expose-topic
(list 'quote spec
))))
5293 ;;;_ #7 Systematic outline presentation -- copying, printing, flattening
5295 ;;;_ - Mapping and processing of topics
5296 ;;;_ ( See also Subtree Charting, in Navigation code.)
5297 ;;;_ > allout-stringify-flat-index (flat-index)
5298 (defun allout-stringify-flat-index (flat-index &optional context
)
5299 "Convert list representing section/subsection/... to document string.
5301 Optional arg CONTEXT indicates interior levels to include."
5305 (context-depth (or (and context
2) 1)))
5306 ;; Take care of the explicit context:
5307 (while (> context-depth
0)
5308 (setq numstr
(int-to-string (car flat-index
))
5309 flat-index
(cdr flat-index
)
5310 result
(if flat-index
5311 (cons delim
(cons numstr result
))
5312 (cons numstr result
))
5313 context-depth
(if flat-index
(1- context-depth
) 0)))
5315 ;; Take care of the indentation:
5322 (1+ (truncate (if (zerop (car flat-index
))
5324 (log10 (car flat-index
)))))
5327 (setq flat-index
(cdr flat-index
)))
5328 ;; Dispose of single extra delim:
5329 (setq result
(cdr result
))))
5330 (apply 'concat result
)))
5331 ;;;_ > allout-stringify-flat-index-plain (flat-index)
5332 (defun allout-stringify-flat-index-plain (flat-index)
5333 "Convert list representing section/subsection/... to document string."
5337 (setq result
(cons (int-to-string (car flat-index
))
5339 (cons delim result
))))
5340 (setq flat-index
(cdr flat-index
)))
5341 (apply 'concat result
)))
5342 ;;;_ > allout-stringify-flat-index-indented (flat-index)
5343 (defun allout-stringify-flat-index-indented (flat-index)
5344 "Convert list representing section/subsection/... to document string."
5348 ;; Take care of the explicit context:
5349 (setq numstr
(int-to-string (car flat-index
))
5350 flat-index
(cdr flat-index
)
5351 result
(if flat-index
5352 (cons delim
(cons numstr result
))
5353 (cons numstr result
)))
5355 ;; Take care of the indentation:
5362 (1+ (truncate (if (zerop (car flat-index
))
5364 (log10 (car flat-index
)))))
5367 (setq flat-index
(cdr flat-index
)))
5368 ;; Dispose of single extra delim:
5369 (setq result
(cdr result
))))
5370 (apply 'concat result
)))
5371 ;;;_ > allout-listify-exposed (&optional start end format)
5372 (defun allout-listify-exposed (&optional start end format
)
5374 "Produce a list representing exposed topics in current region.
5376 This list can then be used by `allout-process-exposed' to manipulate
5379 Optional START and END indicate bounds of region.
5381 Optional arg, FORMAT, designates an alternate presentation form for
5384 list -- Present prefix as numeric section.subsection..., starting with
5385 section indicated by the list, innermost nesting first.
5386 `indent' (symbol) -- Convert header prefixes to all white space,
5387 except for distinctive bullets.
5389 The elements of the list produced are lists that represents a topic
5390 header and body. The elements of that list are:
5392 - a number representing the depth of the topic,
5393 - a string representing the header-prefix, including trailing whitespace and
5395 - a string representing the bullet character,
5396 - and a series of strings, each containing one line of the exposed
5397 portion of the topic entry."
5402 ((inhibit-field-text-motion t
)
5404 strings prefix result depth new-depth out gone-out bullet beg
5409 ;; Goto initial topic, and register preceding stuff, if any:
5410 (if (> (allout-goto-prefix-doublechecked) start
)
5411 ;; First topic follows beginning point -- register preliminary stuff:
5413 (list (list 0 "" nil
5414 (buffer-substring-no-properties start
5416 (while (and (not done
)
5417 (not (eobp)) ; Loop until we've covered the region.
5418 (not (> (point) end
)))
5419 (setq depth allout-recent-depth
; Current topics depth,
5420 bullet
(allout-recent-bullet) ; ... bullet,
5421 prefix
(allout-recent-prefix)
5422 beg
(progn (allout-end-of-prefix t
) (point))) ; and beginning.
5423 (setq done
; The boundary for the current topic:
5424 (not (allout-next-visible-heading 1)))
5425 (setq new-depth allout-recent-depth
)
5427 out
(< new-depth depth
))
5432 (while (> next
(point)) ; Get all the exposed text in
5434 (cons (buffer-substring-no-properties
5436 ;To hidden text or end of line:
5439 (allout-back-to-visible-text)))
5441 (when (< (point) next
) ; Resume from after hid text, if any.
5443 (beginning-of-line))
5445 ;; Accumulate list for this topic:
5446 (setq strings
(nreverse strings
))
5450 (let ((special (if (string-match
5451 (regexp-quote bullet
)
5452 allout-distinctive-bullets-string
)
5454 (cond ((listp format
)
5456 (if allout-flattened-numbering-abbreviation
5457 (allout-stringify-flat-index format
5459 (allout-stringify-flat-index-plain
5463 ((eq format
'indent
)
5466 (concat (make-string (1+ depth
) ?
)
5467 (substring prefix -
1))
5470 (make-string depth ?
)
5472 (t (error "allout-listify-exposed: %s %s"
5473 "invalid format" format
))))
5474 (list depth prefix strings
))
5476 ;; Reassess format, if any:
5477 (if (and format
(listp format
))
5478 (cond ((= new-depth depth
)
5479 (setq format
(cons (1+ (car format
))
5481 ((> new-depth depth
) ; descending -- assume by 1:
5482 (setq format
(cons 1 format
)))
5485 (while (< new-depth depth
)
5486 (setq format
(cdr format
))
5487 (setq depth
(1- depth
)))
5488 ; And increment the current one:
5490 (cons (1+ (or (car format
)
5493 ;; Put the list with first at front, to last at back:
5494 (nreverse result
))))
5495 ;;;_ > allout-region-active-p ()
5496 (defmacro allout-region-active-p
()
5497 (cond ((fboundp 'use-region-p
) '(use-region-p))
5498 ((fboundp 'region-active-p
) '(region-active-p))
5500 ;;_ > allout-process-exposed (&optional func from to frombuf
5502 (defun allout-process-exposed (&optional func from to frombuf tobuf
5504 "Map function on exposed parts of current topic; results to another buffer.
5506 All args are options; default values itemized below.
5508 Apply FUNCTION to exposed portions FROM position TO position in buffer
5509 FROMBUF to buffer TOBUF. Sixth optional arg, FORMAT, designates an
5510 alternate presentation form:
5512 `flat' -- Present prefix as numeric section.subsection..., starting with
5513 section indicated by the START-NUM, innermost nesting first.
5514 X`flat-indented' -- Prefix is like `flat' for first topic at each
5515 X level, but subsequent topics have only leaf topic
5516 X number, padded with blanks to line up with first.
5517 `indent' (symbol) -- Convert header prefixes to all white space,
5518 except for distinctive bullets.
5521 FUNCTION: `allout-insert-listified'
5522 FROM: region start, if region active, else start of buffer
5523 TO: region end, if region active, else end of buffer
5524 FROMBUF: current buffer
5525 TOBUF: buffer name derived: \"*current-buffer-name exposed*\"
5528 ; Resolve arguments,
5529 ; defaulting if necessary:
5530 (if (not func
) (setq func
'allout-insert-listified
))
5531 (if (not (and from to
))
5532 (if (allout-region-active-p)
5533 (setq from
(region-beginning) to
(region-end))
5534 (setq from
(point-min) to
(point-max))))
5536 (if (not (bufferp frombuf
))
5537 ;; Specified but not a buffer -- get it:
5538 (let ((got (get-buffer frombuf
)))
5540 (error (concat "allout-process-exposed: source buffer "
5543 (setq frombuf got
))))
5544 ;; not specified -- default it:
5545 (setq frombuf
(current-buffer)))
5547 (if (not (bufferp tobuf
))
5548 (setq tobuf
(get-buffer-create tobuf
)))
5549 ;; not specified -- default it:
5550 (setq tobuf
(concat "*" (buffer-name frombuf
) " exposed*")))
5555 (progn (set-buffer frombuf
)
5556 (allout-listify-exposed from to format
))))
5558 (mapc func listified
)
5559 (pop-to-buffer tobuf
)))
5562 ;;;_ > allout-insert-listified (listified)
5563 (defun allout-insert-listified (listified)
5564 "Insert contents of listified outline portion in current buffer.
5566 LISTIFIED is a list representing each topic header and body:
5568 \`(depth prefix text)'
5570 or \`(depth prefix text bullet-plus)'
5572 If `bullet-plus' is specified, it is inserted just after the entire prefix."
5573 (setq listified
(cdr listified
))
5574 (let ((prefix (prog1
5576 (setq listified
(cdr listified
))))
5579 (setq listified
(cdr listified
))))
5580 (bullet-plus (car listified
)))
5582 (if bullet-plus
(insert (concat " " bullet-plus
)))
5585 (if (setq text
(cdr text
))
5588 ;;;_ > allout-copy-exposed-to-buffer (&optional arg tobuf format)
5589 (defun allout-copy-exposed-to-buffer (&optional arg tobuf format
)
5590 "Duplicate exposed portions of current outline to another buffer.
5592 Other buffer has current buffers name with \" exposed\" appended to it.
5594 With repeat count, copy the exposed parts of only the current topic.
5596 Optional second arg TOBUF is target buffer name.
5598 Optional third arg FORMAT, if non-nil, symbolically designates an
5599 alternate presentation format for the outline:
5601 `flat' - Convert topic header prefixes to numeric
5602 section.subsection... identifiers.
5603 `indent' - Convert header prefixes to all white space, except for
5604 distinctive bullets.
5605 `indent-flat' - The best of both - only the first of each level has
5606 the full path, the rest have only the section number
5607 of the leaf, preceded by the right amount of indentation."
5611 (setq tobuf
(get-buffer-create (concat "*" (buffer-name) " exposed*"))))
5612 (let* ((start-pt (point))
5613 (beg (if arg
(allout-back-to-current-heading) (point-min)))
5614 (end (if arg
(allout-end-of-current-subtree) (point-max)))
5615 (buf (current-buffer))
5617 (if (eq format
'flat
)
5618 (setq format
(if arg
(save-excursion
5620 (allout-topic-flat-index))
5622 (with-current-buffer tobuf
(erase-buffer))
5623 (allout-process-exposed 'allout-insert-listified
5629 (goto-char (point-min))
5631 (goto-char start-pt
)))
5632 ;;;_ > allout-flatten-exposed-to-buffer (&optional arg tobuf)
5633 (defun allout-flatten-exposed-to-buffer (&optional arg tobuf
)
5634 "Present numeric outline of outline's exposed portions in another buffer.
5636 The resulting outline is not compatible with outline mode -- use
5637 `allout-copy-exposed-to-buffer' if you want that.
5639 Use `allout-indented-exposed-to-buffer' for indented presentation.
5641 With repeat count, copy the exposed portions of only current topic.
5643 Other buffer has current buffer's name with \" exposed\" appended to
5644 it, unless optional second arg TOBUF is specified, in which case it is
5647 (allout-copy-exposed-to-buffer arg tobuf
'flat
))
5648 ;;;_ > allout-indented-exposed-to-buffer (&optional arg tobuf)
5649 (defun allout-indented-exposed-to-buffer (&optional arg tobuf
)
5650 "Present indented outline of outline's exposed portions in another buffer.
5652 The resulting outline is not compatible with outline mode -- use
5653 `allout-copy-exposed-to-buffer' if you want that.
5655 Use `allout-flatten-exposed-to-buffer' for numeric sectional presentation.
5657 With repeat count, copy the exposed portions of only current topic.
5659 Other buffer has current buffer's name with \" exposed\" appended to
5660 it, unless optional second arg TOBUF is specified, in which case it is
5663 (allout-copy-exposed-to-buffer arg tobuf
'indent
))
5665 ;;;_ - LaTeX formatting
5666 ;;;_ > allout-latex-verb-quote (string &optional flow)
5667 (defun allout-latex-verb-quote (string &optional flow
)
5668 "Return copy of STRING for literal reproduction across LaTeX processing.
5669 Expresses the original characters (including carriage returns) of the
5670 string across LaTeX processing."
5671 (mapconcat (function
5673 (cond ((memq char
'(?
\\ ?$ ?% ?
# ?
& ?
{ ?
} ?_ ?^ ?- ?
*))
5674 (concat "\\char" (number-to-string char
) "{}"))
5675 ((= char ?
\n) "\\\\")
5676 (t (char-to-string char
)))))
5679 ;;;_ > allout-latex-verbatim-quote-curr-line ()
5680 (defun allout-latex-verbatim-quote-curr-line ()
5681 "Express line for exact (literal) representation across LaTeX processing.
5683 Adjust line contents so it is unaltered (from the original line)
5684 across LaTeX processing, within the context of a `verbatim'
5685 environment. Leaves point at the end of the line."
5686 (let ((inhibit-field-text-motion t
))
5689 (end (point-at-eol)))
5691 (while (re-search-forward "\\\\"
5692 ;;"\\\\\\|\\{\\|\\}\\|\\_\\|\\$\\|\\\"\\|\\&\\|\\^\\|\\-\\|\\*\\|#"
5693 end
; bounded by end-of-line
5694 1) ; no matches, move to end & return nil
5695 (goto-char (match-beginning 2))
5698 (goto-char (1+ (match-end 2))))))))
5699 ;;;_ > allout-insert-latex-header (buffer)
5700 (defun allout-insert-latex-header (buffer)
5701 "Insert initial LaTeX commands at point in BUFFER."
5702 ;; Much of this is being derived from the stuff in appendix of E in
5703 ;; the TeXBook, pg 421.
5705 (let ((doc-style (format "\n\\documentstyle{%s}\n"
5707 (page-numbering (if allout-number-pages
5708 "\\pagestyle{empty}\n"
5710 (titlecmd (format "\\newcommand{\\titlecmd}[1]{{%s #1}}\n"
5711 allout-title-style
))
5712 (labelcmd (format "\\newcommand{\\labelcmd}[1]{{%s #1}}\n"
5713 allout-label-style
))
5714 (headlinecmd (format "\\newcommand{\\headlinecmd}[1]{{%s #1}}\n"
5715 allout-head-line-style
))
5716 (bodylinecmd (format "\\newcommand{\\bodylinecmd}[1]{{%s #1}}\n"
5717 allout-body-line-style
))
5718 (setlength (format "%s%s%s%s"
5719 "\\newlength{\\stepsize}\n"
5720 "\\setlength{\\stepsize}{"
5723 (oneheadline (format "%s%s%s%s%s%s%s"
5724 "\\newcommand{\\OneHeadLine}[3]{%\n"
5726 "\\hspace*{#2\\stepsize}%\n"
5727 "\\labelcmd{#1}\\hspace*{.2cm}"
5728 "\\headlinecmd{#3}\\\\["
5731 (onebodyline (format "%s%s%s%s%s%s"
5732 "\\newcommand{\\OneBodyLine}[2]{%\n"
5734 "\\hspace*{#1\\stepsize}%\n"
5735 "\\bodylinecmd{#2}\\\\["
5738 (begindoc "\\begin{document}\n\\begin{center}\n")
5739 (title (format "%s%s%s%s"
5741 (allout-latex-verb-quote (if allout-title
5744 (error "<unnamed buffer>"))
5747 "\\end{center}\n\n"))
5748 (hsize "\\hsize = 7.5 true in\n")
5749 (hoffset "\\hoffset = -1.5 true in\n")
5750 (vspace "\\vspace{.1cm}\n\n"))
5751 (insert (concat doc-style
5766 ;;;_ > allout-insert-latex-trailer (buffer)
5767 (defun allout-insert-latex-trailer (buffer)
5768 "Insert concluding LaTeX commands at point in BUFFER."
5770 (insert "\n\\end{document}\n"))
5771 ;;;_ > allout-latexify-one-item (depth prefix bullet text)
5772 (defun allout-latexify-one-item (depth prefix bullet text
)
5773 "Insert LaTeX commands for formatting one outline item.
5775 Args are the topics numeric DEPTH, the header PREFIX lead string, the
5776 BULLET string, and a list of TEXT strings for the body."
5777 (let* ((head-line (if text
(car text
)))
5778 (body-lines (cdr text
))
5782 (insert (concat "\\OneHeadLine{\\verb\1 "
5783 (allout-latex-verb-quote bullet
)
5788 (allout-latex-verb-quote head-line
)
5791 (if (not body-lines
)
5793 ;;(insert "\\beginlines\n")
5794 (insert "\\begin{verbatim}\n")
5796 (setq curr-line
(car body-lines
))
5797 (if (and (not body-content
)
5798 (not (string-match "^\\s-*$" curr-line
)))
5799 (setq body-content t
))
5800 ; Mangle any occurrences of
5801 ; "\end{verbatim}" in text,
5803 (if (and body-content
5804 (setq bop
(string-match "\\end{verbatim}" curr-line
)))
5805 (setq curr-line
(concat (substring curr-line
0 bop
)
5807 (substring curr-line bop
))))
5808 ;;(insert "|" (car body-lines) "|")
5810 (allout-latex-verbatim-quote-curr-line)
5812 (setq body-lines
(cdr body-lines
)))
5814 (setq body-content nil
)
5818 ;;(insert "\\endlines\n")
5819 (insert "\\end{verbatim}\n")
5821 ;;;_ > allout-latexify-exposed (arg &optional tobuf)
5822 (defun allout-latexify-exposed (arg &optional tobuf
)
5823 "Format current topics exposed portions to TOBUF for LaTeX processing.
5824 TOBUF defaults to a buffer named the same as the current buffer, but
5825 with \"*\" prepended and \" latex-formed*\" appended.
5827 With repeat count, copy the exposed portions of entire buffer."
5832 (get-buffer-create (concat "*" (buffer-name) " latexified*"))))
5833 (let* ((start-pt (point))
5834 (beg (if arg
(point-min) (allout-back-to-current-heading)))
5835 (end (if arg
(point-max) (allout-end-of-current-subtree)))
5836 (buf (current-buffer)))
5839 (allout-insert-latex-header tobuf
)
5840 (goto-char (point-max))
5841 (allout-process-exposed 'allout-latexify-one-item
5846 (goto-char (point-max))
5847 (allout-insert-latex-trailer tobuf
)
5848 (goto-char (point-min))
5850 (goto-char start-pt
)))
5853 ;;;_ > allout-toggle-current-subtree-encryption (&optional keymode-cue)
5854 (defun allout-toggle-current-subtree-encryption (&optional keymode-cue
)
5855 "Encrypt clear or decrypt encoded topic text.
5857 Allout uses Emacs 'epg' library to perform encryption. Symmetric
5858 and keypair encryption are supported. All encryption is ascii
5861 Entry encryption defaults to symmetric key mode unless keypair
5862 recipients are associated with the file (see
5863 `epa-file-encrypt-to') or the function is invoked with a
5864 \(KEYMODE-CUE) universal argument greater than 1.
5866 When encrypting, KEYMODE-CUE universal argument greater than 1
5867 causes prompting for recipients for public-key keypair
5868 encryption. Selecting no recipients results in symmetric key
5871 Further, encrypting with a KEYMODE-CUE universal argument greater
5872 than 4 - eg, preceded by a doubled Ctrl-U - causes association of
5873 the specified recipients with the file, replacing those currently
5874 associated with it. This can be used to deassociate any
5875 recipients with the file, by selecting no recipients in the
5878 Encrypted topic's bullets are set to a `~' to signal that the
5879 contents of the topic (body and subtopics, but not heading) is
5880 pending encryption or encrypted. `*' asterisk immediately after
5881 the bullet signals that the body is encrypted, its absence means
5882 the topic is meant to be encrypted but is not currently. When a
5883 file with topics pending encryption is saved, topics pending
5884 encryption are encrypted. See `allout-encrypt-unencrypted-on-saves'
5885 for auto-encryption specifics.
5887 \*NOTE WELL* that automatic encryption that happens during saves will
5888 default to symmetric encryption -- you must deliberately (re)encrypt key-pair
5889 encrypted topics if you want them to continue to use the key-pair cipher.
5891 Level-one topics, with prefix consisting solely of an `*' asterisk, cannot be
5892 encrypted. If you want to encrypt the contents of a top-level topic, use
5893 \\[allout-shift-in] to increase its depth."
5896 (allout-back-to-current-heading)
5897 (allout-toggle-subtree-encryption keymode-cue
)))
5898 ;;;_ > allout-toggle-subtree-encryption (&optional keymode-cue)
5899 (defun allout-toggle-subtree-encryption (&optional keymode-cue
)
5900 "Encrypt clear text or decrypt encoded topic contents (body and subtopics.)
5902 Entry encryption defaults to symmetric key mode unless keypair
5903 recipients are associated with the file (see
5904 `epa-file-encrypt-to') or the function is invoked with a
5905 \(KEYMODE-CUE) universal argument greater than 1.
5907 When encrypting, KEYMODE-CUE universal argument greater than 1
5908 causes prompting for recipients for public-key keypair
5909 encryption. Selecting no recipients results in symmetric key
5912 Further, encrypting with a KEYMODE-CUE universal argument greater
5913 than 4 - eg, preceded by a doubled Ctrl-U - causes association of
5914 the specified recipients with the file, replacing those currently
5915 associated with it. This can be used to deassociate any
5916 recipients with the file, by selecting no recipients in the
5919 Encryption and decryption uses the Emacs 'epg' library.
5921 Encrypted text will be ascii-armored.
5923 See `allout-toggle-current-subtree-encryption' for more details."
5927 (allout-end-of-prefix t
)
5929 (if (= allout-recent-depth
1)
5930 (error (concat "Cannot encrypt or decrypt level 1 topics -"
5931 " shift it in to make it encryptable")))
5933 (let* ((allout-buffer (current-buffer))
5934 ;; for use with allout-auto-save-temporarily-disabled, if necessary:
5935 (was-buffer-saved-size buffer-saved-size
)
5937 (bullet-pos allout-recent-prefix-beginning
)
5938 (after-bullet-pos (point))
5940 (progn (if (= (point-max) after-bullet-pos
)
5941 (error "no body to encrypt"))
5942 (allout-encrypted-topic-p)))
5943 (was-collapsed (if (not (search-forward "\n" nil t
))
5947 (subtree-beg (1+ (point)))
5948 (subtree-end (allout-end-of-subtree))
5949 (subject-text (buffer-substring-no-properties subtree-beg
5951 (subtree-end-char (char-after (1- subtree-end
)))
5952 (subtree-trailing-char (char-after subtree-end
))
5953 ;; kluge -- result-text needs to be nil, but we also want to
5954 ;; check for the error condition
5955 (result-text (if (or (string= "" subject-text
)
5956 (string= "\n" subject-text
))
5957 (error "No topic contents to %scrypt"
5958 (if was-encrypted
"de" "en"))
5960 ;; Assess key parameters:
5961 (was-coding-system buffer-file-coding-system
))
5963 (when (not was-encrypted
)
5964 ;; ensure that non-ascii chars pending encryption are noticed before
5965 ;; they're encrypted, so the coding system is set to accommodate
5967 (setq buffer-file-coding-system
5968 (allout-select-safe-coding-system subtree-beg subtree-end
))
5969 ;; if the coding system for the text being encrypted is different
5970 ;; than that prevailing, then there a real risk that the coding
5971 ;; system can't be noticed by emacs when the file is visited. to
5972 ;; mitigate that, offer to preserve the coding system using a file
5974 (if (and (not (equal buffer-file-coding-system
5977 (format (concat "Register coding system %s as file local"
5978 " var? Necessary when only encrypted text"
5979 " is in that coding system. ")
5980 buffer-file-coding-system
)))
5981 (allout-adjust-file-variable "buffer-file-coding-system"
5982 buffer-file-coding-system
)))
5985 (allout-encrypt-string subject-text was-encrypted
5986 (current-buffer) keymode-cue
))
5988 ;; Replace the subtree with the processed product.
5991 (set-buffer allout-buffer
)
5992 (delete-region subtree-beg subtree-end
)
5993 (insert result-text
)
5995 (allout-flag-region (1- subtree-beg
) (point) t
))
5996 ;; adjust trailing-blank-lines to preserve topic spacing:
5997 (if (not was-encrypted
)
5998 (if (and (= subtree-end-char ?
\n)
5999 (= subtree-trailing-char ?
\n))
6000 (insert subtree-trailing-char
)))
6001 ;; Ensure that the item has an encrypted-entry bullet:
6002 (if (not (string= (buffer-substring-no-properties
6003 (1- after-bullet-pos
) after-bullet-pos
)
6004 allout-topic-encryption-bullet
))
6005 (progn (goto-char (1- after-bullet-pos
))
6007 (insert allout-topic-encryption-bullet
)))
6009 ;; Remove the is-encrypted bullet qualifier:
6010 (progn (goto-char after-bullet-pos
)
6012 ;; Add the is-encrypted bullet qualifier:
6013 (goto-char after-bullet-pos
)
6016 ;; adjust buffer's auto-save eligibility:
6018 (allout-inhibit-auto-save-info-for-decryption was-buffer-saved-size
)
6019 (allout-maybe-resume-auto-save-info-after-encryption))
6021 (run-hook-with-args 'allout-structure-added-hook
6022 bullet-pos subtree-end
))))
6023 ;;;_ > allout-encrypt-string (text decrypt allout-buffer keymode-cue
6024 ;;; &optional rejected)
6025 (defun allout-encrypt-string (text decrypt allout-buffer keymode-cue
6027 "Encrypt or decrypt message TEXT.
6029 Returns the resulting string, or nil if the transformation fails.
6031 If DECRYPT is true (default false), then decrypt instead of encrypt.
6033 ALLOUT-BUFFER identifies the buffer containing the text.
6035 Entry encryption defaults to symmetric key mode unless keypair
6036 recipients are associated with the file (see
6037 `epa-file-encrypt-to') or the function is invoked with a
6038 \(KEYMODE-CUE) universal argument greater than 1.
6040 When encrypting, KEYMODE-CUE universal argument greater than 1
6041 causes prompting for recipients for public-key keypair
6042 encryption. Selecting no recipients results in symmetric key
6045 Further, encrypting with a KEYMODE-CUE universal argument greater
6046 than 4 - eg, preceded by a doubled Ctrl-U - causes association of
6047 the specified recipients with the file, replacing those currently
6048 associated with it. This can be used to deassociate any
6049 recipients with the file, by selecting no recipients in the
6052 Optional REJECTED is for internal use, to convey the number of
6053 rejections due to matches against
6054 `allout-encryption-ciphertext-rejection-regexps', as limited by
6055 `allout-encryption-ciphertext-rejection-ceiling'.
6057 NOTE: A few GnuPG v2 versions improperly preserve incorrect
6058 symmetric decryption keys, preventing entry of the correct key on
6059 subsequent decryption attempts until the cache times-out. That
6060 can take several minutes. (Decryption of other entries is not
6061 affected.) Upgrade your EasyPG version, if you can, and you can
6062 deliberately clear your gpg-agent's cache by sending it a '-HUP'
6068 (let* ((epg-context (let* ((context (epg-make-context nil t
)))
6069 (epg-context-set-passphrase-callback
6070 context
#'epa-passphrase-callback-function
)
6073 (encoding (with-current-buffer allout-buffer
6074 buffer-file-coding-system
))
6075 (multibyte (with-current-buffer allout-buffer
6076 enable-multibyte-characters
))
6077 ;; "sanitization" avoids encryption results that are outline structure.
6078 (sani-regexps 'allout-encryption-plaintext-sanitization-regexps
)
6079 (strip-plaintext-regexps (if (not decrypt
)
6080 (allout-get-configvar-values
6082 (rejection-regexps 'allout-encryption-ciphertext-rejection-regexps
)
6083 (reject-ciphertext-regexps (if (not decrypt
)
6084 (allout-get-configvar-values
6085 rejection-regexps
)))
6086 (rejected (or rejected
0))
6087 (rejections-left (- allout-encryption-ciphertext-rejection-ceiling
6089 (keypair-mode (cond (decrypt 'decrypting
)
6090 ((<= (prefix-numeric-value keymode-cue
) 1)
6092 ((<= (prefix-numeric-value keymode-cue
) 4)
6094 ((> (prefix-numeric-value keymode-cue
) 4)
6096 (keypair-message (concat "Select encryption recipients.\n"
6097 "Symmetric encryption is done if no"
6098 " recipients are selected. "))
6099 (encrypt-to (and (boundp 'epa-file-encrypt-to
) epa-file-encrypt-to
))
6105 ;; Massage the subject text for encoding and filtering.
6108 ;; convey the text characteristics of the original buffer:
6109 (set-buffer-multibyte multibyte
)
6111 (set-buffer-file-coding-system encoding
)
6113 (encode-coding-region (point-min) (point-max) encoding
)))
6115 ;; remove sanitization regexps matches before encrypting:
6116 (when (and strip-plaintext-regexps
(not decrypt
))
6117 (dolist (re strip-plaintext-regexps
)
6118 (let ((re (if (listp re
) (car re
) re
))
6119 (replacement (if (listp re
) (cadr re
) "")))
6120 (goto-char (point-min))
6122 (while (re-search-forward re nil t
)
6123 (replace-match replacement nil nil
))))))
6124 (setq massaged-text
(buffer-substring-no-properties (point-min)
6126 ;; determine key mode and, if keypair, recipients:
6132 (default (if encrypt-to
(epg-list-keys epg-context encrypt-to
)))
6134 ((prompt prompt-save
)
6135 (save-window-excursion
6136 (epa-select-keys epg-context keypair-message
)))))
6141 (epg-decrypt-string epg-context
6142 (encode-coding-string massaged-text
6143 (or encoding
'utf-8
)))
6146 (cons (concat (cadr err
) " - gpg version problem?")
6148 (replace-regexp-in-string "\n$" ""
6149 (epg-encrypt-string epg-context
6150 (encode-coding-string massaged-text
6151 (or encoding
'utf-8
))
6154 ;; validate result -- non-empty
6155 (if (not result-text
)
6156 (error "%scryption failed." (if decrypt
"De" "En")))
6159 (when (eq keypair-mode
'prompt-save
)
6160 ;; set epa-file-encrypt-to in the buffer:
6161 (setq epa-file-encrypt-to
(mapcar (lambda (key)
6163 (car (epg-key-user-id-list key
))))
6165 ;; change the file variable:
6166 (allout-adjust-file-variable "epa-file-encrypt-to" epa-file-encrypt-to
))
6169 ;; Retry (within limit) if ciphertext contains rejections:
6171 ;; Check for disqualification of this ciphertext:
6172 (let ((regexps reject-ciphertext-regexps
)
6174 (while (and regexps
(not reject-it
))
6175 (setq reject-it
(string-match (car regexps
) result-text
))
6178 (setq rejections-left
(1- rejections-left
))
6179 (if (<= rejections-left
0)
6180 (error (concat "Ciphertext rejected too many times"
6182 allout-encryption-ciphertext-rejection-ceiling
6183 'allout-encryption-ciphertext-rejection-regexps
)
6184 ;; try again (gpg-agent may have the key cached):
6185 (allout-encrypt-string text decrypt allout-buffer keypair-mode
6188 ;; Barf if encryption yields extraordinary control chars:
6190 (string-match "[\C-a\C-k\C-o-\C-z\C-@]"
6192 (error (concat "Encryption produced non-armored text, which"
6193 "conflicts with allout mode -- reconfigure!")))
6195 ;;;_ > allout-inhibit-auto-save-info-for-decryption
6196 (defun allout-inhibit-auto-save-info-for-decryption (was-buffer-saved-size)
6197 "Temporarily prevent auto-saves in this buffer when an item is decrypted.
6199 WAS-BUFFER-SAVED-SIZE is the value of `buffer-saved-size' *before*
6201 (when (not (or (= buffer-saved-size -
1) (= was-buffer-saved-size -
1)))
6202 (setq allout-auto-save-temporarily-disabled was-buffer-saved-size
6203 buffer-saved-size -
1)))
6204 ;;;_ > allout-maybe-resume-auto-save-info-after-encryption ()
6205 (defun allout-maybe-resume-auto-save-info-after-encryption ()
6206 "Restore auto-save info, *if* there are no topics pending encryption."
6207 (when (and allout-auto-save-temporarily-disabled
6208 (= buffer-saved-size -
1)
6212 (goto-char (point-min))
6213 (not (allout-next-topic-pending-encryption)))))
6214 (setq buffer-saved-size allout-auto-save-temporarily-disabled
6215 allout-auto-save-temporarily-disabled nil
)))
6217 ;;;_ > allout-encrypted-topic-p ()
6218 (defun allout-encrypted-topic-p ()
6219 "True if the current topic is encryptable and encrypted."
6221 (allout-end-of-prefix t
)
6222 (and (string= (buffer-substring-no-properties (1- (point)) (point))
6223 allout-topic-encryption-bullet
)
6224 (save-match-data (looking-at "\\*")))
6227 ;;;_ > allout-next-topic-pending-encryption ()
6228 (defun allout-next-topic-pending-encryption ()
6229 "Return the point of the next topic pending encryption, or nil if none.
6231 Such a topic has the `allout-topic-encryption-bullet' without an
6232 immediately following '*' that would mark the topic as being encrypted.
6233 It must also have content."
6234 (let (done got content-beg
)
6238 (if (not (re-search-forward
6239 (format "\\(\\`\\|\n\\)%s *%s[^*]"
6240 (regexp-quote allout-header-prefix
)
6241 (regexp-quote allout-topic-encryption-bullet
))
6245 (goto-char (setq got
(match-beginning 0)))
6246 (if (save-match-data (looking-at "\n"))
6253 ((not (search-forward "\n"))
6262 (setq content-beg
(point))
6264 (allout-end-of-subtree)
6265 (if (<= (point) content-beg
)
6277 ;;;_ > allout-encrypt-decrypted ()
6278 (defun allout-encrypt-decrypted ()
6279 "Encrypt topics pending encryption except those containing exemption point.
6281 If a topic that is currently being edited was encrypted, we return a list
6282 containing the location of the topic and the location of the cursor just
6283 before the topic was encrypted. This can be used, eg, to decrypt the topic
6284 and exactly resituate the cursor if this is being done as part of a file
6285 save. See `allout-encrypt-unencrypted-on-saves' for more info."
6290 (let* ((current-mark (point-marker))
6291 (current-mark-position (marker-position current-mark
))
6294 editing-topic editing-point
)
6295 (goto-char (point-min))
6296 (while (allout-next-topic-pending-encryption)
6297 (setq was-modified
(buffer-modified-p))
6298 (when (save-excursion
6299 (and (boundp 'allout-encrypt-unencrypted-on-saves
)
6300 allout-encrypt-unencrypted-on-saves
6301 (setq bo-subtree
(re-search-forward "$"))
6302 (not (allout-hidden-p))
6303 (>= current-mark
(point))
6304 (allout-end-of-current-subtree)
6305 (<= current-mark
(point))))
6306 (setq editing-topic
(point)
6307 ;; we had to wait for this 'til now so prior topics are
6308 ;; encrypted, any relevant text shifts are in place:
6309 editing-point
(- current-mark-position
6310 (count-trailing-whitespace-region
6311 bo-subtree current-mark-position
))))
6312 (allout-toggle-subtree-encryption)
6313 (if (not was-modified
)
6314 (set-buffer-modified-p nil
))
6316 (if (not was-modified
)
6317 (set-buffer-modified-p nil
))
6318 (if editing-topic
(list editing-topic editing-point
))
6324 ;;;_ #9 miscellaneous
6326 ;;;_ > outlineify-sticky ()
6327 ;; outlinify-sticky is correct spelling; provide this alias for sticklers:
6329 (defalias 'outlinify-sticky
'outlineify-sticky
)
6331 (defun outlineify-sticky (&optional arg
)
6332 "Activate outline mode and establish file var so it is started subsequently.
6334 See `allout-layout' and customization of `allout-auto-activation'
6335 for details on preparing Emacs for automatic allout activation."
6339 (if (allout-mode-p) (allout-mode)) ; deactivate so we can re-activate...
6343 (goto-char (point-min))
6344 (if (allout-goto-prefix)
6346 (allout-open-topic 2)
6347 (insert (concat "Dummy outline topic header -- see"
6348 "`allout-mode' docstring: `^Hm'."))
6349 (allout-adjust-file-variable
6350 "allout-layout" (or allout-layout
'(-1 : 0))))))
6351 ;;;_ > allout-file-vars-section-data ()
6352 (defun allout-file-vars-section-data ()
6353 "Return data identifying the file-vars section, or nil if none.
6355 Returns a list of the form (BEGINNING-POINT PREFIX-STRING SUFFIX-STRING)."
6356 ;; minimally gleaned from emacs 21.4 files.el hack-local-variables function.
6357 (let (beg prefix suffix
)
6359 (goto-char (point-max))
6360 (search-backward "\n\^L" (max (- (point-max) 3000) (point-min)) 'move
)
6361 (if (let ((case-fold-search t
))
6362 (not (search-forward "Local Variables:" nil t
)))
6364 (setq beg
(- (point) 16))
6365 (setq suffix
(buffer-substring-no-properties
6367 (progn (if (search-forward "\n" nil t
)
6370 (setq prefix
(buffer-substring-no-properties
6371 (progn (if (search-backward "\n" nil t
)
6375 (list beg prefix suffix
))
6379 ;;;_ > allout-adjust-file-variable (varname value)
6380 (defun allout-adjust-file-variable (varname value
)
6381 "Adjust the setting of an Emacs file variable named VARNAME to VALUE.
6383 This activity is inhibited if either `enable-local-variables' or
6384 `allout-enable-file-variable-adjustment' are nil.
6386 When enabled, an entry for the variable is created if not already present,
6387 or changed if established with a different value. The section for the file
6388 variables, itself, is created if not already present. When created, the
6389 section lines (including the section line) exist as second-level topics in
6390 a top-level topic at the end of the file.
6392 `enable-local-variables' must be true for any of this to happen."
6393 (if (not (and enable-local-variables
6394 allout-enable-file-variable-adjustment
))
6397 (let ((inhibit-field-text-motion t
)
6398 (section-data (allout-file-vars-section-data))
6401 (setq beg
(car section-data
)
6402 prefix
(cadr section-data
)
6403 suffix
(car (cddr section-data
)))
6404 ;; create the section
6405 (goto-char (point-max))
6407 (allout-open-topic 0)
6409 (insert "Local emacs vars.\n")
6410 (allout-open-topic 1)
6413 prefix
(buffer-substring-no-properties (progn
6418 (insert "Local variables:\n")
6419 (allout-open-topic 0)
6422 ;; look for existing entry or create one, leaving point for insertion
6425 (allout-show-to-offshoot)
6426 (if (search-forward (concat "\n" prefix varname
":") nil t
)
6427 (let* ((value-beg (point))
6428 (line-end (progn (if (search-forward "\n" nil t
)
6431 (value-end (- line-end
(length suffix
))))
6432 (if (> value-end value-beg
)
6433 (delete-region value-beg value-end
)))
6437 (insert (concat prefix varname
":")))
6438 (insert (format " %S%s" value suffix
))
6443 ;;;_ > allout-get-configvar-values (varname)
6444 (defun allout-get-configvar-values (configvar-name)
6445 "Return a list of values of the symbols in list bound to CONFIGVAR-NAME.
6447 The user is prompted for removal of symbols that are unbound, and they
6448 otherwise are ignored.
6450 CONFIGVAR-NAME should be the name of the configuration variable,
6453 (let ((configvar-value (symbol-value configvar-name
))
6455 (dolist (sym configvar-value
)
6456 (if (not (boundp sym
))
6457 (if (yes-or-no-p (format "%s entry `%s' is unbound -- remove it? "
6458 configvar-name sym
))
6459 (delq sym
(symbol-value configvar-name
)))
6460 (push (symbol-value sym
) got
)))
6463 ;;;_ > allout-mark-topic ()
6464 (defun allout-mark-topic ()
6465 "Put the region around topic currently containing point."
6467 (let ((inhibit-field-text-motion t
))
6468 (beginning-of-line))
6469 (allout-goto-prefix-doublechecked)
6471 (allout-end-of-current-subtree)
6472 (exchange-point-and-mark))
6474 ;;;_ > solicit-char-in-string (prompt string &optional do-defaulting)
6475 (defun solicit-char-in-string (prompt string
&optional do-defaulting
)
6476 "Solicit (with first arg PROMPT) choice of a character from string STRING.
6478 Optional arg DO-DEFAULTING indicates to accept empty input (CR)."
6480 (let ((new-prompt prompt
)
6484 (message "%s" new-prompt
)
6486 ;; We do our own reading here, so we can circumvent, eg, special
6487 ;; treatment for `?' character. (Oughta use minibuffer keymap instead.)
6489 (char-to-string (let ((cursor-in-echo-area nil
)) (read-char))))
6492 (cond ((string-match (regexp-quote got
) string
) got
)
6493 ((and do-defaulting
(string= got
"\r"))
6494 ;; Return empty string to default:
6496 ((string= got
"\C-g") (signal 'quit nil
))
6498 (setq new-prompt
(concat prompt
6504 ;; got something out of loop -- return it:
6508 ;;;_ > regexp-sans-escapes (string)
6509 (defun regexp-sans-escapes (regexp &optional successive-backslashes
)
6510 "Return a copy of REGEXP with all character escapes stripped out.
6512 Representations of actual backslashes -- '\\\\\\\\' -- are left as a
6515 Optional arg SUCCESSIVE-BACKSLASHES is used internally for recursion."
6517 (if (string= regexp
"")
6519 ;; Set successive-backslashes to number if current char is
6520 ;; backslash, or else to nil:
6521 (setq successive-backslashes
6522 (if (= (aref regexp
0) ?
\\)
6523 (if successive-backslashes
(1+ successive-backslashes
) 1)
6525 (if (or (not successive-backslashes
) (= 2 successive-backslashes
))
6526 ;; Include first char:
6527 (concat (substring regexp
0 1)
6528 (regexp-sans-escapes (substring regexp
1)))
6529 ;; Exclude first char, but maintain count:
6530 (regexp-sans-escapes (substring regexp
1) successive-backslashes
))))
6531 ;;;_ > count-trailing-whitespace-region (beg end)
6532 (defun count-trailing-whitespace-region (beg end
)
6533 "Return number of trailing whitespace chars between BEG and END.
6535 If BEG is bigger than END we return 0."
6542 (while (re-search-forward "[ ][ ]*$" end t
)
6543 (goto-char (1+ (match-beginning 2)))
6544 (setq count
(1+ count
)))
6546 ;;;_ > allout-format-quote (string)
6547 (defun allout-format-quote (string)
6548 "Return a copy of string with all \"%\" characters doubled."
6550 (mapcar (lambda (char) (if (= char ?%
) "%%" (char-to-string char
)))
6553 ;;;_ > allout-flatten (list)
6554 (defun allout-flatten (list)
6555 "Return a list of all atoms in list."
6557 (cond ((null list
) nil
)
6558 ((atom (car list
)) (cons (car list
) (allout-flatten (cdr list
))))
6559 (t (append (allout-flatten (car list
)) (allout-flatten (cdr list
))))))
6560 ;;;_ : Compatibility:
6561 ;;;_ : xemacs undo-in-progress provision:
6562 (unless (boundp 'undo-in-progress
)
6563 (defvar undo-in-progress nil
6564 "Placeholder defvar for XEmacs compatibility from allout.el.")
6565 (defadvice undo-more
(around allout activate
)
6566 ;; This defadvice used only in emacs that lack undo-in-progress, eg xemacs.
6567 (let ((undo-in-progress t
)) ad-do-it
)))
6569 ;;;_ > allout-mark-marker to accommodate divergent emacsen:
6570 (defun allout-mark-marker (&optional force buffer
)
6571 "Accommodate the different signature for `mark-marker' across Emacsen.
6573 XEmacs takes two optional args, while Emacs does not,
6574 so pass them along when appropriate."
6575 (if (featurep 'xemacs
)
6576 (apply 'mark-marker force buffer
)
6578 ;;;_ > subst-char-in-string if necessary
6579 (if (not (fboundp 'subst-char-in-string
))
6580 (defun subst-char-in-string (fromchar tochar string
&optional inplace
)
6581 "Replace FROMCHAR with TOCHAR in STRING each time it occurs.
6582 Unless optional argument INPLACE is non-nil, return a new string."
6583 (let ((i (length string
))
6584 (newstr (if inplace string
(copy-sequence string
))))
6587 (if (eq (aref newstr i
) fromchar
)
6588 (aset newstr i tochar
)))
6590 ;;;_ > wholenump if necessary
6591 (if (not (fboundp 'wholenump
))
6592 (defalias 'wholenump
'natnump
))
6593 ;;;_ > remove-overlays if necessary
6594 (if (not (fboundp 'remove-overlays
))
6595 (defun remove-overlays (&optional beg end name val
)
6596 "Clear BEG and END of overlays whose property NAME has value VAL.
6597 Overlays might be moved and/or split.
6598 BEG and END default respectively to the beginning and end of buffer."
6599 (unless beg
(setq beg
(point-min)))
6600 (unless end
(setq end
(point-max)))
6602 (setq beg
(prog1 end
(setq end beg
))))
6604 (dolist (o (overlays-in beg end
))
6605 (when (eq (overlay-get o name
) val
)
6606 ;; Either push this overlay outside beg...end
6607 ;; or split it to exclude beg...end
6608 ;; or delete it entirely (if it is contained in beg...end).
6609 (if (< (overlay-start o
) beg
)
6610 (if (> (overlay-end o
) end
)
6612 (move-overlay (copy-overlay o
)
6613 (overlay-start o
) beg
)
6614 (move-overlay o end
(overlay-end o
)))
6615 (move-overlay o
(overlay-start o
) beg
))
6616 (if (> (overlay-end o
) end
)
6617 (move-overlay o end
(overlay-end o
))
6618 (delete-overlay o
)))))))
6620 ;;;_ > copy-overlay if necessary -- xemacs ~ 21.4
6621 (if (not (fboundp 'copy-overlay
))
6622 (defun copy-overlay (o)
6623 "Return a copy of overlay O."
6624 (let ((o1 (make-overlay (overlay-start o
) (overlay-end o
)
6625 ;; FIXME: there's no easy way to find the
6626 ;; insertion-type of the two markers.
6627 (overlay-buffer o
)))
6628 (props (overlay-properties o
)))
6630 (overlay-put o1
(pop props
) (pop props
)))
6632 ;;;_ > add-to-invisibility-spec if necessary -- xemacs ~ 21.4
6633 (if (not (fboundp 'add-to-invisibility-spec
))
6634 (defun add-to-invisibility-spec (element)
6635 "Add ELEMENT to `buffer-invisibility-spec'.
6636 See documentation for `buffer-invisibility-spec' for the kind of elements
6638 (if (eq buffer-invisibility-spec t
)
6639 (setq buffer-invisibility-spec
(list t
)))
6640 (setq buffer-invisibility-spec
6641 (cons element buffer-invisibility-spec
))))
6642 ;;;_ > remove-from-invisibility-spec if necessary -- xemacs ~ 21.4
6643 (if (not (fboundp 'remove-from-invisibility-spec
))
6644 (defun remove-from-invisibility-spec (element)
6645 "Remove ELEMENT from `buffer-invisibility-spec'."
6646 (if (consp buffer-invisibility-spec
)
6647 (setq buffer-invisibility-spec
(delete element
6648 buffer-invisibility-spec
)))))
6649 ;;;_ > move-beginning-of-line if necessary -- older emacs, xemacs
6650 (if (not (fboundp 'move-beginning-of-line
))
6651 (defun move-beginning-of-line (arg)
6652 "Move point to beginning of current line as displayed.
6653 \(This disregards invisible newlines such as those
6654 which are part of the text that an image rests on.)
6656 With argument ARG not nil or 1, move forward ARG - 1 lines first.
6657 If point reaches the beginning or end of buffer, it stops there.
6658 To ignore intangibility, bind `inhibit-point-motion-hooks' to t."
6660 (or arg
(setq arg
1))
6662 (condition-case nil
(line-move (1- arg
)) (error nil
)))
6664 ;; Move to beginning-of-line, ignoring fields and invisibles.
6665 (skip-chars-backward "^\n")
6666 (while (and (not (bobp))
6668 (get-char-property (1- (point)) 'invisible
)))
6669 (if (eq buffer-invisibility-spec t
)
6671 (or (memq prop buffer-invisibility-spec
)
6672 (assq prop buffer-invisibility-spec
)))))
6673 (goto-char (if (featurep 'xemacs
)
6674 (previous-property-change (point))
6675 (previous-char-property-change (point))))
6676 (skip-chars-backward "^\n"))
6677 (vertical-motion 0))
6679 ;;;_ > move-end-of-line if necessary -- Emacs < 22.1, xemacs
6680 (if (not (fboundp 'move-end-of-line
))
6681 (defun move-end-of-line (arg)
6682 "Move point to end of current line as displayed.
6683 \(This disregards invisible newlines such as those
6684 which are part of the text that an image rests on.)
6686 With argument ARG not nil or 1, move forward ARG - 1 lines first.
6687 If point reaches the beginning or end of buffer, it stops there.
6688 To ignore intangibility, bind `inhibit-point-motion-hooks' to t."
6690 (or arg
(setq arg
1))
6695 (let ((goal-column 0))
6696 (and (condition-case nil
6697 (or (line-move arg
) t
)
6705 (get-char-property (1- (point))
6707 (if (eq buffer-invisibility-spec t
)
6710 buffer-invisibility-spec
)
6712 buffer-invisibility-spec
)))))
6714 (previous-char-property-change (point))))
6718 (if (and (> (point) newpos
)
6719 (eq (preceding-char) ?
\n))
6721 (if (and (> (point) newpos
) (not (eobp))
6722 (not (eq (following-char) ?
\n)))
6723 ;; If we skipped something intangible
6724 ;; and now we're not really at eol,
6729 ;;;_ > allout-next-single-char-property-change -- alias unless lacking
6730 (defalias 'allout-next-single-char-property-change
6731 (if (fboundp 'next-single-char-property-change
)
6732 'next-single-char-property-change
6733 'next-single-property-change
)
6734 ;; No docstring because xemacs defalias doesn't support it.
6736 ;;;_ > allout-previous-single-char-property-change -- alias unless lacking
6737 (defalias 'allout-previous-single-char-property-change
6738 (if (fboundp 'previous-single-char-property-change
)
6739 'previous-single-char-property-change
6740 'previous-single-property-change
)
6741 ;; No docstring because xemacs defalias doesn't support it.
6743 ;;;_ > allout-select-safe-coding-system
6744 (defalias 'allout-select-safe-coding-system
6745 (if (fboundp 'select-safe-coding-system
)
6746 'select-safe-coding-system
6747 'detect-coding-region
)
6749 ;;;_ > allout-substring-no-properties
6750 ;; define as alias first, so byte compiler is happy.
6751 (defalias 'allout-substring-no-properties
'substring-no-properties
)
6752 ;; then supplant with definition if underlying alias absent.
6753 (if (not (fboundp 'substring-no-properties
))
6754 (defun allout-substring-no-properties (string &optional start end
)
6755 (substring string
(or start
0) end
))
6759 ;;;_ > allout-bullet-isearch (&optional bullet)
6760 (defun allout-bullet-isearch (&optional bullet
)
6761 "Isearch (regexp) for topic with bullet BULLET."
6764 (setq bullet
(solicit-char-in-string
6765 "ISearch for topic with bullet: "
6766 (regexp-sans-escapes allout-bullets-string
))))
6768 (let ((isearch-regexp t
)
6769 (isearch-string (concat "^"
6770 allout-header-prefix
6773 (isearch-repeat 'forward
)
6776 ;;;_ #11 Unit tests -- this should be last item before "Provide"
6777 ;;;_ > allout-run-unit-tests ()
6778 (defun allout-run-unit-tests ()
6779 "Run the various allout unit tests."
6780 (message "Running allout tests...")
6781 (allout-test-resumptions)
6782 (message "Running allout tests... Done.")
6784 ;;;_ : test resumptions:
6785 ;;;_ > allout-tests-obliterate-variable (name)
6786 (defun allout-tests-obliterate-variable (name)
6787 "Completely unbind variable with NAME."
6788 (if (local-variable-p name
(current-buffer)) (kill-local-variable name
))
6789 (while (boundp name
) (makunbound name
)))
6790 ;;;_ > allout-test-resumptions ()
6791 (defvar allout-tests-globally-unbound nil
6792 "Fodder for allout resumptions tests -- defvar just for byte compiler.")
6793 (defvar allout-tests-globally-true nil
6794 "Fodder for allout resumptions tests -- defvar just for byte compiler.")
6795 (defvar allout-tests-locally-true nil
6796 "Fodder for allout resumptions tests -- defvar just for byte compiler.")
6797 (defun allout-test-resumptions ()
6798 "Exercise allout resumptions."
6799 ;; for each resumption case, we also test that the right local/global
6800 ;; scopes are affected during resumption effects:
6802 ;; ensure that previously unbound variables return to the unbound state.
6804 (allout-tests-obliterate-variable 'allout-tests-globally-unbound
)
6805 (allout-add-resumptions '(allout-tests-globally-unbound t
))
6806 (assert (not (default-boundp 'allout-tests-globally-unbound
)))
6807 (assert (local-variable-p 'allout-tests-globally-unbound
(current-buffer)))
6808 (assert (boundp 'allout-tests-globally-unbound
))
6809 (assert (equal allout-tests-globally-unbound t
))
6810 (allout-do-resumptions)
6811 (assert (not (local-variable-p 'allout-tests-globally-unbound
6813 (assert (not (boundp 'allout-tests-globally-unbound
))))
6815 ;; ensure that variable with prior global value is resumed
6817 (allout-tests-obliterate-variable 'allout-tests-globally-true
)
6818 (setq allout-tests-globally-true t
)
6819 (allout-add-resumptions '(allout-tests-globally-true nil
))
6820 (assert (equal (default-value 'allout-tests-globally-true
) t
))
6821 (assert (local-variable-p 'allout-tests-globally-true
(current-buffer)))
6822 (assert (equal allout-tests-globally-true nil
))
6823 (allout-do-resumptions)
6824 (assert (not (local-variable-p 'allout-tests-globally-true
6826 (assert (boundp 'allout-tests-globally-true
))
6827 (assert (equal allout-tests-globally-true t
)))
6829 ;; ensure that prior local value is resumed
6831 (allout-tests-obliterate-variable 'allout-tests-locally-true
)
6832 (set (make-local-variable 'allout-tests-locally-true
) t
)
6833 (assert (not (default-boundp 'allout-tests-locally-true
))
6834 nil
(concat "Test setup mistake -- variable supposed to"
6835 " not have global binding, but it does."))
6836 (assert (local-variable-p 'allout-tests-locally-true
(current-buffer))
6837 nil
(concat "Test setup mistake -- variable supposed to have"
6838 " local binding, but it lacks one."))
6839 (allout-add-resumptions '(allout-tests-locally-true nil
))
6840 (assert (not (default-boundp 'allout-tests-locally-true
)))
6841 (assert (local-variable-p 'allout-tests-locally-true
(current-buffer)))
6842 (assert (equal allout-tests-locally-true nil
))
6843 (allout-do-resumptions)
6844 (assert (boundp 'allout-tests-locally-true
))
6845 (assert (local-variable-p 'allout-tests-locally-true
(current-buffer)))
6846 (assert (equal allout-tests-locally-true t
))
6847 (assert (not (default-boundp 'allout-tests-locally-true
))))
6849 ;; ensure that last of multiple resumptions holds, for various scopes.
6851 (allout-tests-obliterate-variable 'allout-tests-globally-unbound
)
6852 (allout-tests-obliterate-variable 'allout-tests-globally-true
)
6853 (setq allout-tests-globally-true t
)
6854 (allout-tests-obliterate-variable 'allout-tests-locally-true
)
6855 (set (make-local-variable 'allout-tests-locally-true
) t
)
6856 (allout-add-resumptions '(allout-tests-globally-unbound t
)
6857 '(allout-tests-globally-true nil
)
6858 '(allout-tests-locally-true nil
))
6859 (allout-add-resumptions '(allout-tests-globally-unbound 2)
6860 '(allout-tests-globally-true 3)
6861 '(allout-tests-locally-true 4))
6862 ;; reestablish many of the basic conditions are maintained after re-add:
6863 (assert (not (default-boundp 'allout-tests-globally-unbound
)))
6864 (assert (local-variable-p 'allout-tests-globally-unbound
(current-buffer)))
6865 (assert (equal allout-tests-globally-unbound
2))
6866 (assert (default-boundp 'allout-tests-globally-true
))
6867 (assert (local-variable-p 'allout-tests-globally-true
(current-buffer)))
6868 (assert (equal allout-tests-globally-true
3))
6869 (assert (not (default-boundp 'allout-tests-locally-true
)))
6870 (assert (local-variable-p 'allout-tests-locally-true
(current-buffer)))
6871 (assert (equal allout-tests-locally-true
4))
6872 (allout-do-resumptions)
6873 (assert (not (local-variable-p 'allout-tests-globally-unbound
6875 (assert (not (boundp 'allout-tests-globally-unbound
)))
6876 (assert (not (local-variable-p 'allout-tests-globally-true
6878 (assert (boundp 'allout-tests-globally-true
))
6879 (assert (equal allout-tests-globally-true t
))
6880 (assert (boundp 'allout-tests-locally-true
))
6881 (assert (local-variable-p 'allout-tests-locally-true
(current-buffer)))
6882 (assert (equal allout-tests-locally-true t
))
6883 (assert (not (default-boundp 'allout-tests-locally-true
))))
6885 ;; ensure that deliberately unbinding registered variables doesn't foul things
6887 (allout-tests-obliterate-variable 'allout-tests-globally-unbound
)
6888 (allout-tests-obliterate-variable 'allout-tests-globally-true
)
6889 (setq allout-tests-globally-true t
)
6890 (allout-tests-obliterate-variable 'allout-tests-locally-true
)
6891 (set (make-local-variable 'allout-tests-locally-true
) t
)
6892 (allout-add-resumptions '(allout-tests-globally-unbound t
)
6893 '(allout-tests-globally-true nil
)
6894 '(allout-tests-locally-true nil
))
6895 (allout-tests-obliterate-variable 'allout-tests-globally-unbound
)
6896 (allout-tests-obliterate-variable 'allout-tests-globally-true
)
6897 (allout-tests-obliterate-variable 'allout-tests-locally-true
)
6898 (allout-do-resumptions))
6900 ;;;_ % Run unit tests if `allout-run-unit-tests-after-load' is true:
6901 (when allout-run-unit-tests-on-load
6902 (allout-run-unit-tests))
6907 ;;;_* Local emacs vars.
6908 ;; The following `allout-layout' local variable setting:
6909 ;; - closes all topics from the first topic to just before the third-to-last,
6910 ;; - shows the children of the third to last (config vars)
6911 ;; - and the second to last (code section),
6912 ;; - and closes the last topic (this local-variables section).
6914 ;;allout-layout: (0 : -1 -1 0)
6917 ;;; allout.el ends here