1 ;;; allout.el --- extensive outline mode for use alone and with other modes
3 ;; Copyright (C) 1992, 1993, 1994, 2001, 2002, 2003, 2004,
4 ;; 2005 Free Software Foundation, Inc.
6 ;; Author: Ken Manheimer <ken dot manheimer at gmail dot com>
7 ;; Maintainer: Ken Manheimer <ken dot manheimer at gmail dot com>
8 ;; Created: Dec 1991 - first release to usenet
9 ;; Keywords: outlines wp languages
11 ;; This file is part of GNU Emacs.
13 ;; GNU Emacs is free software; you can redistribute it and/or modify
14 ;; it under the terms of the GNU General Public License as published by
15 ;; the Free Software Foundation; either version 2, or (at your option)
18 ;; GNU Emacs is distributed in the hope that it will be useful,
19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21 ;; GNU General Public License for more details.
23 ;; You should have received a copy of the GNU General Public License
24 ;; along with GNU Emacs; see the file COPYING. If not, write to the
25 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
26 ;; Boston, MA 02110-1301, USA.
30 ;; Allout outline mode provides extensive outline formatting and
31 ;; and manipulation beyond standard emacs outline mode. It provides
32 ;; for structured editing of outlines, as well as navigation and
33 ;; exposure. It also provides for syntax-sensitive text like
34 ;; programming languages. (For an example, see the allout code
35 ;; itself, which is organized in ;; an outline framework.)
39 ;; - classic outline-mode topic-oriented navigation and exposure adjustment
40 ;; - topic-oriented editing including coherent topic and subtopic
41 ;; creation, promotion, demotion, cut/paste across depths, etc
42 ;; - incremental search with dynamic exposure and reconcealment of text
43 ;; - customizable bullet format enbles programming-language specific
44 ;; outlining, for ultimate code-folding editing. (allout code itself is
45 ;; formatted as an outline - do ESC-x eval-current-buffer in allout.el
47 ;; - configurable per-file initial exposure settings
48 ;; - symmetric-key and key-pair topic encryption, plus reliable key
49 ;; verification and user-supplied hint maintenance. (see
50 ;; allout-toggle-current-subtree-encryption docstring.)
51 ;; - automatic topic-number maintenance
52 ;; - "hot-spot" operation, for single-keystroke maneuvering and
53 ;; exposure control (see the allout-mode docstring)
54 ;; - easy rendering of exposed portions into numbered, latex, indented, etc
59 ;; The outline menubar additions provide quick reference to many of
60 ;; the features, and see the docstring of the variable `allout-init'
61 ;; for instructions on priming your emacs session for automatic
62 ;; activation of allout-mode.
64 ;; 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. (It has changed since allout
67 ;; 3.x, for those of you that depend on the old method.)
69 ;; Note - the lines beginning with `;;;_' are outline topic headers.
70 ;; Just `ESC-x eval-current-buffer' to give it a whirl.
72 ;; ken manheimer (ken dot manheimer at gmail dot com)
80 ;;;_* Dependency autoloads
81 (eval-when-compile 'cl
) ; otherwise, flet compilation fouls
82 (autoload 'crypt-encrypt-buffer
"crypt++")
83 (setq-default crypt-encryption-type
'gpg
)
85 (autoload 'mc-encrypt
"mailcrypt"
86 "*Encrypt the current buffer")
87 (autoload 'mc-activate-passwd
"mailcrypt"
88 "Activate the passphrase matching ID, using PROMPT for a prompt.
89 Return the passphrase. If PROMPT is nil, only return value if cached.")
90 (autoload 'mc-gpg-process-region
"mc-gpg")
91 (autoload 'mc-dectivate-passwd
"mailcrypt"
92 "*Deactivate the passphrase cache.")
94 ;;;_* USER CUSTOMIZATION VARIABLES:
96 "Extensive outline mode for use alone and with other modes."
100 ;;;_ + Layout, Mode, and Topic Header Configuration
102 ;;;_ = allout-auto-activation
103 (defcustom allout-auto-activation nil
104 "*Regulates auto-activation modality of allout outlines - see `allout-init'.
106 Setq-default by `allout-init' to regulate whether or not allout
107 outline mode is automatically activated when the buffer-specific
108 variable `allout-layout' is non-nil, and whether or not the layout
109 dictated by `allout-layout' should be imposed on mode activation.
111 With value t, auto-mode-activation and auto-layout are enabled.
112 \(This also depends on `allout-find-file-hook' being installed in
113 `find-file-hook', which is also done by `allout-init'.)
115 With value `ask', auto-mode-activation is enabled, and endorsement for
116 performing auto-layout is asked of the user each time.
118 With value `activate', only auto-mode-activation is enabled,
121 With value nil, neither auto-mode-activation nor auto-layout are
124 See the docstring for `allout-init' for the proper interface to
126 :type
'(choice (const :tag
"On" t
)
127 (const :tag
"Ask about layout" "ask")
128 (const :tag
"Mode only" "activate")
129 (const :tag
"Off" nil
))
132 (defvar allout-layout nil
133 "*Layout specification and provisional mode trigger for allout outlines.
137 A list value specifies a default layout for the current buffer, to be
138 applied upon activation of `allout-mode'. Any non-nil value will
139 automatically trigger `allout-mode' \(provided `allout-init' has been called
140 to enable this behavior).
142 See the docstring for `allout-init' for details on setting up for
143 auto-mode-activation, and for `allout-expose-topic' for the format of
144 the layout specification.
146 You can associate a particular outline layout with a file by setting
147 this var via the file's local variables. For example, the following
148 lines at the bottom of an Emacs Lisp file:
151 ;;;allout-layout: \(0 : -1 -1 0)
154 will, modulo the above-mentioned conditions, cause the mode to be
155 activated when the file is visited, followed by the equivalent of
156 `\(allout-expose-topic 0 : -1 -1 0)'. \(This is the layout used for
157 the allout.el, itself.)
159 Also, allout's mode-specific provisions will make topic prefixes default
160 to the comment-start string, if any, of the language of the file. This
161 is modulo the setting of `allout-use-mode-specific-leader', which see.")
162 (make-variable-buffer-local 'allout-layout
)
163 ;;;_ = allout-show-bodies
164 (defcustom allout-show-bodies nil
165 "*If non-nil, show entire body when exposing a topic, rather than
169 (make-variable-buffer-local 'allout-show-bodies
)
171 ;;;_ = allout-header-prefix
172 (defcustom allout-header-prefix
"."
173 "*Leading string which helps distinguish topic headers.
175 Outline topic header lines are identified by a leading topic
176 header prefix, which mostly have the value of this var at their front.
177 \(Level 1 topics are exceptions. They consist of only a single
178 character, which is typically set to the `allout-primary-bullet'. Many
179 outlines start at level 2 to avoid this discrepancy."
182 (make-variable-buffer-local 'allout-header-prefix
)
183 ;;;_ = allout-primary-bullet
184 (defcustom allout-primary-bullet
"*"
185 "Bullet used for top-level outline topics.
187 Outline topic header lines are identified by a leading topic header
188 prefix, which is concluded by bullets that includes the value of this
189 var and the respective allout-*-bullets-string vars.
191 The value of an asterisk (`*') provides for backwards compatibility
192 with the original Emacs outline mode. See `allout-plain-bullets-string'
193 and `allout-distinctive-bullets-string' for the range of available
197 (make-variable-buffer-local 'allout-primary-bullet
)
198 ;;;_ = allout-plain-bullets-string
199 (defcustom allout-plain-bullets-string
".,"
200 "*The bullets normally used in outline topic prefixes.
202 See `allout-distinctive-bullets-string' for the other kind of
205 DO NOT include the close-square-bracket, `]', as a bullet.
207 Outline mode has to be reactivated in order for changes to the value
208 of this var to take effect."
211 (make-variable-buffer-local 'allout-plain-bullets-string
)
212 ;;;_ = allout-distinctive-bullets-string
213 (defcustom allout-distinctive-bullets-string
"*+-=>()[{}&!?#%\"X@$~_\\:;^"
214 "*Persistent outline header bullets used to distinguish special topics.
216 These bullets are used to distinguish topics from the run-of-the-mill
217 ones. They are not used in the standard topic headers created by
218 the topic-opening, shifting, and rebulleting \(eg, on topic shift,
219 topic paste, blanket rebulleting) routines, but are offered among the
220 choices for rebulleting. They are not altered by the above automatic
221 rebulleting, so they can be used to characterize topics, eg:
224 `\(' parenthetic comment \(with a matching close paren inside)
225 `[' meta-note \(with a matching close ] inside)
231 ... for example. (`#' typically has a special meaning to the software,
232 according to the value of `allout-numbered-bullet'.)
234 See `allout-plain-bullets-string' for the selection of
237 You must run `set-allout-regexp' in order for outline mode to
238 reconcile to changes of this value.
240 DO NOT include the close-square-bracket, `]', on either of the bullet
244 (make-variable-buffer-local 'allout-distinctive-bullets-string
)
246 ;;;_ = allout-use-mode-specific-leader
247 (defcustom allout-use-mode-specific-leader t
248 "*When non-nil, use mode-specific topic-header prefixes.
250 Allout outline mode will use the mode-specific `allout-mode-leaders'
251 and/or comment-start string, if any, to lead the topic prefix string,
252 so topic headers look like comments in the programming language.
254 String values are used as they stand.
256 Value t means to first check for assoc value in `allout-mode-leaders'
257 alist, then use comment-start string, if any, then use default \(`.').
258 \(See note about use of comment-start strings, below.)
260 Set to the symbol for either of `allout-mode-leaders' or
261 `comment-start' to use only one of them, respectively.
263 Value nil means to always use the default \(`.').
265 comment-start strings that do not end in spaces are tripled, and an
266 `_' underscore is tacked on the end, to distinguish them from regular
267 comment strings. comment-start strings that do end in spaces are not
268 tripled, but an underscore is substituted for the space. [This
269 presumes that the space is for appearance, not comment syntax. You
270 can use `allout-mode-leaders' to override this behavior, when
272 :type
'(choice (const t
) (const nil
) string
273 (const allout-mode-leaders
)
274 (const comment-start
))
276 ;;;_ = allout-mode-leaders
277 (defvar allout-mode-leaders
'()
278 "Specific allout-prefix leading strings per major modes.
280 Entries will be used instead or in lieu of mode-specific
281 comment-start strings. See also `allout-use-mode-specific-leader'.
283 If you're constructing a string that will comment-out outline
284 structuring so it can be included in program code, append an extra
285 character, like an \"_\" underscore, to distinguish the lead string
286 from regular comments that start at bol.")
288 ;;;_ = allout-old-style-prefixes
289 (defcustom allout-old-style-prefixes nil
290 "*When non-nil, use only old-and-crusty `outline-mode' `*' topic prefixes.
292 Non-nil restricts the topic creation and modification
293 functions to asterix-padded prefixes, so they look exactly
294 like the original Emacs-outline style prefixes.
296 Whatever the setting of this variable, both old and new style prefixes
297 are always respected by the topic maneuvering functions."
300 (make-variable-buffer-local 'allout-old-style-prefixes
)
301 ;;;_ = allout-stylish-prefixes - alternating bullets
302 (defcustom allout-stylish-prefixes t
303 "*Do fancy stuff with topic prefix bullets according to level, etc.
305 Non-nil enables topic creation, modification, and repositioning
306 functions to vary the topic bullet char (the char that marks the topic
307 depth) just preceding the start of the topic text) according to level.
308 Otherwise, only asterisks (`*') and distinctive bullets are used.
310 This is how an outline can look (but sans indentation) with stylish
315 . + One level 3 subtopic
316 . . One level 4 subtopic
317 . . A second 4 subtopic
318 . + Another level 3 subtopic
319 . #1 A numbered level 4 subtopic
321 . ! Another level 4 subtopic with a different distinctive bullet
322 . #4 And another numbered level 4 subtopic
324 This would be an outline with stylish prefixes inhibited (but the
325 numbered and other distinctive bullets retained):
329 . * One level 3 subtopic
330 . * One level 4 subtopic
331 . * A second 4 subtopic
332 . * Another level 3 subtopic
333 . #1 A numbered level 4 subtopic
335 . ! Another level 4 subtopic with a different distinctive bullet
336 . #4 And another numbered level 4 subtopic
338 Stylish and constant prefixes (as well as old-style prefixes) are
339 always respected by the topic maneuvering functions, regardless of
340 this variable setting.
342 The setting of this var is not relevant when `allout-old-style-prefixes'
346 (make-variable-buffer-local 'allout-stylish-prefixes
)
348 ;;;_ = allout-numbered-bullet
349 (defcustom allout-numbered-bullet
"#"
350 "*String designating bullet of topics that have auto-numbering; nil for none.
352 Topics having this bullet have automatic maintenance of a sibling
353 sequence-number tacked on, just after the bullet. Conventionally set
354 to \"#\", you can set it to a bullet of your choice. A nil value
355 disables numbering maintenance."
356 :type
'(choice (const nil
) string
)
358 (make-variable-buffer-local 'allout-numbered-bullet
)
359 ;;;_ = allout-file-xref-bullet
360 (defcustom allout-file-xref-bullet
"@"
361 "*Bullet signifying file cross-references, for `allout-resolve-xref'.
363 Set this var to the bullet you want to use for file cross-references."
364 :type
'(choice (const nil
) string
)
366 ;;;_ = allout-presentation-padding
367 (defcustom allout-presentation-padding
2
368 "*Presentation-format white-space padding factor, for greater indent."
372 (make-variable-buffer-local 'allout-presentation-padding
)
374 ;;;_ = allout-abbreviate-flattened-numbering
375 (defcustom allout-abbreviate-flattened-numbering nil
376 "*If non-nil, `allout-flatten-exposed-to-buffer' abbreviates topic
377 numbers to minimal amount with some context. Otherwise, entire
378 numbers are always used."
382 ;;;_ + LaTeX formatting
383 ;;;_ - allout-number-pages
384 (defcustom allout-number-pages nil
385 "*Non-nil turns on page numbering for LaTeX formatting of an outline."
388 ;;;_ - allout-label-style
389 (defcustom allout-label-style
"\\large\\bf"
390 "*Font and size of labels for LaTeX formatting of an outline."
393 ;;;_ - allout-head-line-style
394 (defcustom allout-head-line-style
"\\large\\sl "
395 "*Font and size of entries for LaTeX formatting of an outline."
398 ;;;_ - allout-body-line-style
399 (defcustom allout-body-line-style
" "
400 "*Font and size of entries for LaTeX formatting of an outline."
403 ;;;_ - allout-title-style
404 (defcustom allout-title-style
"\\Large\\bf"
405 "*Font and size of titles for LaTeX formatting of an outline."
409 (defcustom allout-title
'(or buffer-file-name
(buffer-name))
410 "*Expression to be evaluated to determine the title for LaTeX
414 ;;;_ - allout-line-skip
415 (defcustom allout-line-skip
".05cm"
416 "*Space between lines for LaTeX formatting of an outline."
420 (defcustom allout-indent
".3cm"
421 "*LaTeX formatted depth-indent spacing."
425 ;;;_ + Topic encryption
426 ;;;_ = allout-topic-encryption-bullet
427 (defcustom allout-topic-encryption-bullet
"~"
428 "*Bullet signifying encryption of the entry's body."
429 :type
'(choice (const nil
) string
)
431 ;;;_ = allout-default-encryption-scheme
432 (defcustom allout-default-encryption-scheme
'mc-scheme-gpg
433 "*Default allout outline topic encryption mode.
435 See mailcrypt variable `mc-schemes' and mailcrypt docs for encryption schemes."
438 ;;;_ = allout-key-verifier-handling
439 (defcustom allout-key-verifier-handling
'situate
440 "*Dictate outline encryption key verifier handling.
442 The key verifier is string associated with a file that is encrypted with
443 the file's current symmetric encryption key. It is used, if present, to
444 confirm that the key entered by the user is the same as the established
445 one, or explicitly presenting the user with the choice to go with a
446 new key when a difference is encountered.
448 The range of values are:
450 situate - include key verifier string as text in the file's local-vars
452 transient - establish the value as a variable in the file's buffer, but
453 don't preserve it as a file variable.
454 disabled - don't establish or do verification.
456 See the docstring for the `allout-enable-file-variable-adjustment'
457 variable for details about allout ajustment of file variables."
458 :type
'(choice (const situate
)
462 (make-variable-buffer-local 'allout-key-verifier-handling
)
463 ;;;_ = allout-key-hint-handling
464 (defcustom allout-key-hint-handling
'always
465 "*Dictate outline encryption key reminder handling:
467 always - always show reminder when prompting
468 needed - show reminder on key entry failure
469 manage - never present reminder, but still manage a file-var entry for it
470 disabled - don't even manage the file variable entry
472 See the docstring for the `allout-enable-file-variable-adjustment'
473 variable for details about allout ajustment of file variables."
474 :type
'(choice (const always
)
479 (make-variable-buffer-local 'allout-key-hint-handling
)
480 ;;;_ = allout-encrypt-unencrypted-on-saves
481 (defcustom allout-encrypt-unencrypted-on-saves
'except-current
482 "*When saving, should topics pending encryption be encrypted?
484 The idea is to prevent file-system exposure of any un-encrypted stuff, and
485 mostly covers both deliberate file writes and auto-saves.
487 - Yes: encrypt all topics pending encryption, even if it's the one
488 currently being edited. \(In that case, the currently edited topic
489 will be automatically decrypted before any user interaction, so they
490 can continue editing but the copy on the file system will be
492 Auto-saves will use the \"All except current topic\" mode if this
493 one is selected, to avoid practical difficulties - see below.
494 - All except current topic: skip the topic currently being edited, even if
495 it's pending encryption. This may expose the current topic on the
496 file sytem, but avoids the nuisance of prompts for the encryption
497 key in the middle of editing for, eg, autosaves.
498 This mode is used for auto-saves for both this option and \"Yes\".
499 - No: leave it to the user to encrypt any unencrypted topics.
501 For practical reasons, auto-saves always use the 'except-current policy
502 when auto-encryption is enabled. \(Otherwise, spurious key prompts and
503 unavoidable timing collisions are too disruptive.) If security for a file
504 requires that even the current topic is never auto-saved in the clear,
505 disable auto-saves for that file."
507 :type
'(choice (const :tag
"Yes" t
)
508 (const :tag
"All except current topic" except-current
)
509 (const :tag
"No" nil
))
511 (make-variable-buffer-local 'allout-encrypt-unencrypted-on-saves
)
513 ;;;_ + Miscellaneous customization
515 ;;;_ = allout-command-prefix
516 (defcustom allout-command-prefix
"\C-c"
517 "*Key sequence to be used as prefix for outline mode command key bindings."
521 ;;;_ = allout-keybindings-list
522 ;;; You have to reactivate allout-mode - `(allout-mode t)' - to
523 ;;; institute changes to this var.
524 (defvar allout-keybindings-list
()
525 "*List of `allout-mode' key / function bindings, for `allout-mode-map'.
527 String or vector key will be prefaced with `allout-command-prefix',
528 unless optional third, non-nil element is present.")
529 (setq allout-keybindings-list
532 ("\C-n" allout-next-visible-heading
)
533 ("\C-p" allout-previous-visible-heading
)
534 ("\C-u" allout-up-current-level
)
535 ("\C-f" allout-forward-current-level
)
536 ("\C-b" allout-backward-current-level
)
537 ("\C-a" allout-beginning-of-current-entry
)
538 ("\C-e" allout-end-of-entry
)
540 ("\C-i" allout-show-children
)
541 ("\C-s" allout-show-current-subtree
)
542 ("\C-h" allout-hide-current-subtree
)
543 ("h" allout-hide-current-subtree
)
544 ("\C-o" allout-show-current-entry
)
545 ("!" allout-show-all
)
546 ("x" allout-toggle-current-subtree-encryption
)
547 ; Alteration commands:
548 (" " allout-open-sibtopic
)
549 ("." allout-open-subtopic
)
550 ("," allout-open-supertopic
)
551 ("'" allout-shift-in
)
552 (">" allout-shift-in
)
553 ("<" allout-shift-out
)
554 ("\C-m" allout-rebullet-topic
)
555 ("*" allout-rebullet-current-heading
)
556 ("#" allout-number-siblings
)
557 ("\C-k" allout-kill-line t
)
558 ("\C-y" allout-yank t
)
559 ("\M-y" allout-yank-pop t
)
560 ("\C-k" allout-kill-topic
)
561 ; Miscellaneous commands:
562 ;([?\C-\ ] allout-mark-topic)
563 ("@" allout-resolve-xref
)
564 ("=c" allout-copy-exposed-to-buffer
)
565 ("=i" allout-indented-exposed-to-buffer
)
566 ("=t" allout-latexify-exposed
)
567 ("=p" allout-flatten-exposed-to-buffer
)))
569 ;;;_ = allout-isearch-dynamic-expose
570 (defcustom allout-isearch-dynamic-expose t
571 "*Non-nil enable dynamic exposure of hidden incremental-search
572 targets as they're encountered."
575 (make-variable-buffer-local 'allout-isearch-dynamic-expose
)
577 ;;;_ = allout-use-hanging-indents
578 (defcustom allout-use-hanging-indents t
579 "*If non-nil, topic body text auto-indent defaults to indent of the header.
580 Ie, it is indented to be just past the header prefix. This is
581 relevant mostly for use with indented-text-mode, or other situations
582 where auto-fill occurs.
584 \[This feature no longer depends in any way on the `filladapt.el'
585 lisp-archive package.\]"
588 (make-variable-buffer-local 'allout-use-hanging-indents
)
590 ;;;_ = allout-reindent-bodies
591 (defcustom allout-reindent-bodies
(if allout-use-hanging-indents
593 "*Non-nil enables auto-adjust of topic body hanging indent with depth shifts.
595 When active, topic body lines that are indented even with or beyond
596 their topic header are reindented to correspond with depth shifts of
599 A value of t enables reindent in non-programming-code buffers, ie
600 those that do not have the variable `comment-start' set. A value of
601 `force' enables reindent whether or not `comment-start' is set."
602 :type
'(choice (const nil
) (const t
) (const text
) (const force
))
605 (make-variable-buffer-local 'allout-reindent-bodies
)
607 ;;;_ = allout-enable-file-variable-adjustment
608 (defcustom allout-enable-file-variable-adjustment t
609 "*If non-nil, some allout outline actions can edit Emacs file variables text.
611 This can range from changes to existing entries, addition of new ones,
612 and creation of a new local variables section when necessary.
614 Emacs file variables adjustments are also inhibited if `enable-local-variables'
617 Operations potentially causing edits include allout encryption routines.
618 See the docstring for `allout-toggle-current-subtree-encryption' for
622 (make-variable-buffer-local 'allout-enable-file-variable-adjustment
)
624 ;;;_* CODE - no user customizations below.
626 ;;;_ #1 Internal Outline Formatting and Configuration
628 ;;;_ = allout-version
629 (defvar allout-version
630 (let ((rcs-rev "$Revision$"))
633 (string-match "Revision: \\([0-9]+\\.[0-9]+\\)" rcs-rev
)
634 (substring rcs-rev
(match-beginning 1) (match-end 1)))
636 "Revision number of currently loaded outline package. \(allout.el)")
637 ;;;_ > allout-version
638 (defun allout-version (&optional here
)
639 "Return string describing the loaded outline version."
641 (let ((msg (concat "Allout Outline Mode v " allout-version
)))
642 (if here
(insert msg
))
645 ;;;_ : Topic header format
647 (defvar allout-regexp
""
648 "*Regular expression to match the beginning of a heading line.
650 Any line whose beginning matches this regexp is considered a
651 heading. This var is set according to the user configuration vars
652 by `set-allout-regexp'.")
653 (make-variable-buffer-local 'allout-regexp
)
654 ;;;_ = allout-bullets-string
655 (defvar allout-bullets-string
""
656 "A string dictating the valid set of outline topic bullets.
658 This var should *not* be set by the user - it is set by `set-allout-regexp',
659 and is produced from the elements of `allout-plain-bullets-string'
660 and `allout-distinctive-bullets-string'.")
661 (make-variable-buffer-local 'allout-bullets-string
)
662 ;;;_ = allout-bullets-string-len
663 (defvar allout-bullets-string-len
0
664 "Length of current buffers' `allout-plain-bullets-string'.")
665 (make-variable-buffer-local 'allout-bullets-string-len
)
666 ;;;_ = allout-line-boundary-regexp
667 (defvar allout-line-boundary-regexp
()
668 "`allout-regexp' with outline style beginning-of-line anchor.
670 \(Ie, C-j, *or* C-m, for prefixes of hidden topics). This is properly
671 set when `allout-regexp' is produced by `set-allout-regexp', so
672 that (match-beginning 2) and (match-end 2) delimit the prefix.")
673 (make-variable-buffer-local 'allout-line-boundary-regexp
)
674 ;;;_ = allout-bob-regexp
675 (defvar allout-bob-regexp
()
676 "Like `allout-line-boundary-regexp', for headers at beginning of buffer.
677 \(match-beginning 2) and \(match-end 2) delimit the prefix.")
678 (make-variable-buffer-local 'allout-bob-regexp
)
679 ;;;_ = allout-header-subtraction
680 (defvar allout-header-subtraction
(1- (length allout-header-prefix
))
681 "Allout-header prefix length to subtract when computing topic depth.")
682 (make-variable-buffer-local 'allout-header-subtraction
)
683 ;;;_ = allout-plain-bullets-string-len
684 (defvar allout-plain-bullets-string-len
(length allout-plain-bullets-string
)
685 "Length of `allout-plain-bullets-string', updated by `set-allout-regexp'.")
686 (make-variable-buffer-local 'allout-plain-bullets-string-len
)
689 ;;;_ X allout-reset-header-lead (header-lead)
690 (defun allout-reset-header-lead (header-lead)
691 "*Reset the leading string used to identify topic headers."
692 (interactive "sNew lead string: ")
693 (setq allout-header-prefix header-lead
)
694 (setq allout-header-subtraction
(1- (length allout-header-prefix
)))
696 ;;;_ X allout-lead-with-comment-string (header-lead)
697 (defun allout-lead-with-comment-string (&optional header-lead
)
698 "*Set the topic-header leading string to specified string.
700 Useful when for encapsulating outline structure in programming
701 language comments. Returns the leading string."
704 (if (not (stringp header-lead
))
705 (setq header-lead
(read-string
706 "String prefix for topic headers: ")))
707 (setq allout-reindent-bodies nil
)
708 (allout-reset-header-lead header-lead
)
710 ;;;_ > allout-infer-header-lead ()
711 (defun allout-infer-header-lead ()
712 "Determine appropriate `allout-header-prefix'.
714 Works according to settings of:
717 `allout-header-prefix' (default)
718 `allout-use-mode-specific-leader'
719 and `allout-mode-leaders'.
721 Apply this via \(re)activation of `allout-mode', rather than
722 invoking it directly."
723 (let* ((use-leader (and (boundp 'allout-use-mode-specific-leader
)
724 (if (or (stringp allout-use-mode-specific-leader
)
725 (memq allout-use-mode-specific-leader
726 '(allout-mode-leaders
729 allout-use-mode-specific-leader
730 ;; Oops - garbled value, equate with effect of 't:
734 ((not use-leader
) nil
)
735 ;; Use the explicitly designated leader:
736 ((stringp use-leader
) use-leader
)
737 (t (or (and (memq use-leader
'(t allout-mode-leaders
))
738 ;; Get it from outline mode leaders?
739 (cdr (assq major-mode allout-mode-leaders
)))
740 ;; ... didn't get from allout-mode-leaders...
741 (and (memq use-leader
'(t comment-start
))
743 ;; Use comment-start, maybe tripled, and with
747 (substring comment-start
748 (1- (length comment-start
))))
749 ;; Use comment-start, sans trailing space:
750 (substring comment-start
0 -
1)
751 (concat comment-start comment-start comment-start
))
752 ;; ... and append underscore, whichever:
756 (if (string= leader allout-header-prefix
)
757 nil
; no change, nothing to do.
758 (setq allout-header-prefix leader
)
759 allout-header-prefix
))))
760 ;;;_ > allout-infer-body-reindent ()
761 (defun allout-infer-body-reindent ()
762 "Determine proper setting for `allout-reindent-bodies'.
764 Depends on default setting of `allout-reindent-bodies' \(which see)
765 and presence of setting for `comment-start', to tell whether the
766 file is programming code."
767 (if (and allout-reindent-bodies
769 (not (eq 'force allout-reindent-bodies
)))
770 (setq allout-reindent-bodies nil
)))
771 ;;;_ > set-allout-regexp ()
772 (defun set-allout-regexp ()
773 "Generate proper topic-header regexp form for outline functions.
775 Works with respect to `allout-plain-bullets-string' and
776 `allout-distinctive-bullets-string'."
779 ;; Derive allout-bullets-string from user configured components:
780 (setq allout-bullets-string
"")
781 (let ((strings (list 'allout-plain-bullets-string
782 'allout-distinctive-bullets-string
783 'allout-primary-bullet
))
791 (setq new-string
"") (setq index
0)
792 (setq cur-len
(length (setq cur-string
(symbol-value (car strings
)))))
793 (while (< index cur-len
)
794 (setq cur-char
(aref cur-string index
))
795 (setq allout-bullets-string
796 (concat allout-bullets-string
798 ; Single dash would denote a
799 ; sequence, repeated denotes
801 ((eq cur-char ?-
) "--")
802 ; literal close-square-bracket
803 ; doesn't work right in the
805 ((eq cur-char ?\
]) "")
806 (t (regexp-quote (char-to-string cur-char
))))))
807 (setq index
(1+ index
)))
808 (setq strings
(cdr strings
)))
810 ;; Derive next for repeated use in allout-pending-bullet:
811 (setq allout-plain-bullets-string-len
(length allout-plain-bullets-string
))
812 (setq allout-header-subtraction
(1- (length allout-header-prefix
)))
813 ;; Produce the new allout-regexp:
814 (setq allout-regexp
(concat "\\(\\"
817 allout-bullets-string
819 allout-primary-bullet
821 (setq allout-line-boundary-regexp
822 (concat "\\([\n\r]\\)\\(" allout-regexp
"\\)"))
823 (setq allout-bob-regexp
824 (concat "\\(\\`\\)\\(" allout-regexp
"\\)"))
827 ;;;_ = allout-mode-map
828 (defvar allout-mode-map nil
"Keybindings for (allout) outline minor mode.")
829 ;;;_ > produce-allout-mode-map (keymap-alist &optional base-map)
830 (defun produce-allout-mode-map (keymap-list &optional base-map
)
831 "Produce keymap for use as allout-mode-map, from KEYMAP-LIST.
833 Built on top of optional BASE-MAP, or empty sparse map if none specified.
834 See doc string for allout-keybindings-list for format of binding list."
835 (let ((map (or base-map
(make-sparse-keymap)))
836 (pref (list allout-command-prefix
)))
839 (let ((add-pref (null (cdr (cdr cell
))))
840 (key-suff (list (car cell
))))
843 (apply 'concat
(if add-pref
844 (append pref key-suff
)
846 (car (cdr cell
)))))))
849 ;;;_ = allout-prior-bindings - being deprecated.
850 (defvar allout-prior-bindings nil
851 "Variable for use in V18, with allout-added-bindings, for
852 resurrecting, on mode deactivation, bindings that existed before
853 activation. Being deprecated.")
854 ;;;_ = allout-added-bindings - being deprecated
855 (defvar allout-added-bindings nil
856 "Variable for use in V18, with allout-prior-bindings, for
857 resurrecting, on mode deactivation, bindings that existed before
858 activation. Being deprecated.")
860 (defvar allout-mode-exposure-menu
)
861 (defvar allout-mode-editing-menu
)
862 (defvar allout-mode-navigation-menu
)
863 (defvar allout-mode-misc-menu
)
864 (defun produce-allout-mode-menubar-entries ()
866 (easy-menu-define allout-mode-exposure-menu
868 "Allout outline exposure menu."
870 ["Show Entry" allout-show-current-entry t
]
871 ["Show Children" allout-show-children t
]
872 ["Show Subtree" allout-show-current-subtree t
]
873 ["Hide Subtree" allout-hide-current-subtree t
]
874 ["Hide Leaves" allout-hide-current-leaves t
]
876 ["Show All" allout-show-all t
]))
877 (easy-menu-define allout-mode-editing-menu
879 "Allout outline editing menu."
881 ["Open Sibling" allout-open-sibtopic t
]
882 ["Open Subtopic" allout-open-subtopic t
]
883 ["Open Supertopic" allout-open-supertopic t
]
885 ["Shift Topic In" allout-shift-in t
]
886 ["Shift Topic Out" allout-shift-out t
]
887 ["Rebullet Topic" allout-rebullet-topic t
]
888 ["Rebullet Heading" allout-rebullet-current-heading t
]
889 ["Number Siblings" allout-number-siblings t
]
891 ["Toggle Topic Encryption"
892 allout-toggle-current-subtree-encryption
893 (> (allout-current-depth) 1)]))
894 (easy-menu-define allout-mode-navigation-menu
896 "Allout outline navigation menu."
898 ["Next Visible Heading" allout-next-visible-heading t
]
899 ["Previous Visible Heading"
900 allout-previous-visible-heading t
]
902 ["Up Level" allout-up-current-level t
]
903 ["Forward Current Level" allout-forward-current-level t
]
904 ["Backward Current Level"
905 allout-backward-current-level t
]
907 ["Beginning of Entry"
908 allout-beginning-of-current-entry t
]
909 ["End of Entry" allout-end-of-entry t
]
910 ["End of Subtree" allout-end-of-current-subtree t
]))
911 (easy-menu-define allout-mode-misc-menu
913 "Allout outlines miscellaneous bindings."
915 ["Version" allout-version t
]
917 ["Duplicate Exposed" allout-copy-exposed-to-buffer t
]
918 ["Duplicate Exposed, numbered"
919 allout-flatten-exposed-to-buffer t
]
920 ["Duplicate Exposed, indented"
921 allout-indented-exposed-to-buffer t
]
923 ["Set Header Lead" allout-reset-header-lead t
]
924 ["Set New Exposure" allout-expose-topic t
])))
925 ;;;_ : Mode-Specific Variable Maintenance Utilities
926 ;;;_ = allout-mode-prior-settings
927 (defvar allout-mode-prior-settings nil
928 "Internal `allout-mode' use; settings to be resumed on mode deactivation.")
929 (make-variable-buffer-local 'allout-mode-prior-settings
)
930 ;;;_ > allout-resumptions (name &optional value)
931 (defun allout-resumptions (name &optional value
)
933 "Registers or resumes settings over `allout-mode' activation/deactivation.
935 First arg is NAME of variable affected. Optional second arg is list
936 containing allout-mode-specific VALUE to be imposed on named
937 variable, and to be registered. (It's a list so you can specify
938 registrations of null values.) If no value is specified, the
939 registered value is returned (encapsulated in the list, so the caller
940 can distinguish nil vs no value), and the registration is popped
943 (let ((on-list (assq name allout-mode-prior-settings
))
944 prior-capsule
; By `capsule' i mean a list
945 ; containing a value, so we can
946 ; distinguish nil from no value.
954 nil
; Already preserved prior value - don't mess with it.
955 ;; Register the old value, or nil if previously unbound:
956 (setq allout-mode-prior-settings
958 (if (boundp name
) (list (symbol-value name
))))
959 allout-mode-prior-settings
)))
960 ; And impose the new value, locally:
961 (progn (make-local-variable name
)
962 (set name
(car value
))))
967 ;; Oops, not registered - leave it be:
970 ;; Some registration:
972 (setq prior-capsule
(car (cdr on-list
)))
974 (set name
(car prior-capsule
)) ; Some prior value - reestablish it.
975 (makunbound name
)) ; Previously unbound - demolish var.
976 ; Remove registration:
978 (while allout-mode-prior-settings
979 (if (not (eq (car allout-mode-prior-settings
)
982 (cons (car allout-mode-prior-settings
)
984 (setq allout-mode-prior-settings
985 (cdr allout-mode-prior-settings
)))
986 (setq allout-mode-prior-settings rebuild
)))))
988 ;;;_ : Mode-specific incidentals
989 ;;;_ = allout-pre-was-isearching nil
990 (defvar allout-pre-was-isearching nil
991 "Cue for isearch-dynamic-exposure mechanism, implemented in
992 allout-pre- and -post-command-hooks.")
993 (make-variable-buffer-local 'allout-pre-was-isearching
)
994 ;;;_ = allout-isearch-prior-pos nil
995 (defvar allout-isearch-prior-pos nil
996 "Cue for isearch-dynamic-exposure tracking, used by
997 `allout-isearch-expose'.")
998 (make-variable-buffer-local 'allout-isearch-prior-pos
)
999 ;;;_ = allout-isearch-did-quit
1000 (defvar allout-isearch-did-quit nil
1001 "Distinguishes isearch conclusion and cancellation.
1003 Maintained by allout-isearch-abort \(which is wrapped around the real
1004 isearch-abort), and monitored by allout-isearch-expose for action.")
1005 (make-variable-buffer-local 'allout-isearch-did-quit
)
1006 ;;;_ > allout-unprotected (expr)
1007 (defmacro allout-unprotected
(expr)
1008 "Enable internal outline operations to alter read-only text."
1009 `(let ((was-inhibit-r-o inhibit-read-only
))
1012 (setq inhibit-read-only t
)
1014 (setq inhibit-read-only was-inhibit-r-o
)
1018 ;;;_ = allout-undo-aggregation
1019 (defvar allout-undo-aggregation
30
1020 "Amount of successive self-insert actions to bunch together per undo.
1022 This is purely a kludge variable, regulating the compensation for a bug in
1023 the way that `before-change-functions' and undo interact.")
1024 (make-variable-buffer-local 'allout-undo-aggregation
)
1025 ;;;_ = file-var-bug hack
1026 (defvar allout-v18
/19-file-var-hack nil
1027 "Horrible hack used to prevent invalid multiple triggering of outline
1028 mode from prop-line file-var activation. Used by `allout-mode' function
1030 ;;;_ = allout-file-key-verifier-string
1031 (defvar allout-file-key-verifier-string nil
1032 "Name for use as a file variable for verifying encryption key across
1034 (make-variable-buffer-local 'allout-file-key-verifier-string
)
1035 ;;;_ = allout-encryption-scheme
1036 (defvar allout-encryption-scheme nil
1037 "*Allout outline topic encryption scheme pending for the current buffer.
1039 Intended as a file-specific (buffer local) setting, it defaults to the
1040 value of allout-default-encryption-scheme if nil.")
1041 (make-variable-buffer-local 'allout-encryption-scheme
)
1042 ;;;_ = allout-key-verifier-string
1043 (defvar allout-key-verifier-string nil
1044 "Setting used to test solicited encryption keys against that already
1045 associated with a file.
1047 It consists of an encrypted random string useful only to verify that a key
1048 entered by the user is effective for decryption. The key itself is \*not*
1049 recorded in the file anywhere, and the encrypted contents are random binary
1050 characters to avoid exposing greater susceptibility to search attacks.
1052 The verifier string is retained as an Emacs file variable, as well as in
1053 the emacs buffer state, if file variable adjustments are enabled. See
1054 `allout-enable-file-variable-adjustment' for details about that.")
1055 (make-variable-buffer-local 'allout-key-verifier-string
)
1056 (setq-default allout-key-verifier-string nil
)
1057 ;;;_ = allout-key-hint-string
1058 (defvar allout-key-hint-string
""
1059 "Variable used to retain a reminder string for a file's encryption key.
1061 See the description of `allout-key-hint-handling' for details about how
1062 the reminder is deployed.
1064 The hint is retained as an Emacs file variable, as well as in the emacs buffer
1065 state, if file variable adjustments are enabled. See
1066 `allout-enable-file-variable-adjustment' for details about that.")
1067 (make-variable-buffer-local 'allout-key-hint-string
)
1068 (setq-default allout-key-hint-string
"")
1069 ;;;_ = allout-after-save-decrypt
1070 (defvar allout-after-save-decrypt nil
1071 "Internal variable, is nil or has the value of two points:
1073 - the location of a topic to be decrypted after saving is done
1074 - where to situate the cursor after the decryption is performed
1076 This is used to decrypt the topic that was currently being edited, if it
1077 was encrypted automatically as part of a file write or autosave.")
1078 (make-variable-buffer-local 'allout-after-save-decrypt
)
1079 ;;;_ > allout-write-file-hook-handler ()
1080 (defun allout-write-file-hook-handler ()
1081 "Implement `allout-encrypt-unencrypted-on-saves' policy for file writes."
1083 (if (or (not (boundp 'allout-encrypt-unencrypted-on-saves
))
1084 (not allout-encrypt-unencrypted-on-saves
))
1086 (let ((except-mark (and (equal allout-encrypt-unencrypted-on-saves
1089 (if (save-excursion (goto-char (point-min))
1090 (allout-next-topic-pending-encryption except-mark
))
1092 (message "auto-encrypting pending topics")
1094 (condition-case failure
1095 (setq allout-after-save-decrypt
1096 (allout-encrypt-decrypted except-mark
))
1099 "allout-write-file-hook-handler suppressing error %s"
1104 ;;;_ > allout-auto-save-hook-handler ()
1105 (defun allout-auto-save-hook-handler ()
1106 "Implement `allout-encrypt-unencrypted-on-saves' policy for auto saves."
1108 (if allout-encrypt-unencrypted-on-saves
1109 ;; Always implement 'except-current policy when enabled.
1110 (let ((allout-encrypt-unencrypted-on-saves 'except-current
))
1111 (allout-write-file-hook-handler))))
1112 ;;;_ > allout-after-saves-handler ()
1113 (defun allout-after-saves-handler ()
1114 "Decrypt topic encrypted for save, if it's currently being edited.
1116 Ie, if it was pending encryption and contained the point in its body before
1119 We use values stored in `allout-after-save-decrypt' to locate the topic
1120 and the place for the cursor after the decryption is done."
1121 (if (not (and (allout-mode-p)
1122 (boundp 'allout-after-save-decrypt
)
1123 allout-after-save-decrypt
))
1125 (goto-char (car allout-after-save-decrypt
))
1126 (let ((was-modified (buffer-modified-p)))
1127 (allout-toggle-current-subtree-encryption)
1128 (if (not was-modified
)
1129 (set-buffer-modified-p nil
)))
1130 (goto-char (cadr allout-after-save-decrypt
))
1131 (setq allout-after-save-decrypt nil
))
1134 ;;;_ #2 Mode activation
1136 (defvar allout-mode
() "Allout outline mode minor-mode flag.")
1137 (make-variable-buffer-local 'allout-mode
)
1138 ;;;_ > allout-mode-p ()
1139 (defmacro allout-mode-p
()
1140 "Return t if `allout-mode' is active in current buffer."
1142 ;;;_ = allout-explicitly-deactivated
1143 (defvar allout-explicitly-deactivated nil
1144 "If t, `allout-mode's last deactivation was deliberate.
1145 So `allout-post-command-business' should not reactivate it...")
1146 (make-variable-buffer-local 'allout-explicitly-deactivated
)
1147 ;;;_ > allout-init (&optional mode)
1148 (defun allout-init (&optional mode
)
1149 "Prime `allout-mode' to enable/disable auto-activation, wrt `allout-layout'.
1151 MODE is one of the following symbols:
1153 - nil \(or no argument) deactivate auto-activation/layout;
1154 - `activate', enable auto-activation only;
1155 - `ask', enable auto-activation, and enable auto-layout but with
1156 confirmation for layout operation solicited from user each time;
1157 - `report', just report and return the current auto-activation state;
1158 - anything else \(eg, t) for auto-activation and auto-layout, without
1159 any confirmation check.
1161 Use this function to setup your Emacs session for automatic activation
1162 of allout outline mode, contingent to the buffer-specific setting of
1163 the `allout-layout' variable. (See `allout-layout' and
1164 `allout-expose-topic' docstrings for more details on auto layout).
1166 `allout-init' works by setting up (or removing) the `allout-mode'
1167 find-file-hook, and giving `allout-auto-activation' a suitable
1170 To prime your Emacs session for full auto-outline operation, include
1171 the following two lines in your Emacs init file:
1181 (concat "Select outline auto setup mode "
1182 "(empty for report, ? for options) ")
1183 '(("nil")("full")("activate")("deactivate")
1184 ("ask") ("report") (""))
1187 (if (string= mode
"")
1189 (setq mode
(intern-soft mode
)))))
1191 ;; convenience aliases, for consistent ref to respective vars:
1192 ((hook 'allout-find-file-hook
)
1193 (curr-mode 'allout-auto-activation
))
1196 (setq find-file-hooks
(delq hook find-file-hooks
))
1198 (message "Allout outline mode auto-activation inhibited.")))
1200 (if (not (memq hook find-file-hooks
))
1202 ;; Just punt and use the reports from each of the modes:
1203 (allout-init (symbol-value curr-mode
))))
1204 (t (add-hook 'find-file-hooks hook
)
1205 (set curr-mode
; `set', not `setq'!
1206 (cond ((eq mode
'activate
)
1208 "Outline mode auto-activation enabled.")
1211 ;; Return the current mode setting:
1215 (concat "Outline mode auto-activation and "
1216 "-layout \(upon confirmation) enabled."))
1219 "Outline mode auto-activation and -layout enabled.")
1222 ;;;_ > allout-setup-menubar ()
1223 (defun allout-setup-menubar ()
1224 "Populate the current buffer's menubar with `allout-mode' stuff."
1225 (let ((menus (list allout-mode-exposure-menu
1226 allout-mode-editing-menu
1227 allout-mode-navigation-menu
1228 allout-mode-misc-menu
))
1231 (setq cur
(car menus
)
1233 (easy-menu-add cur
))))
1234 ;;;_ > allout-mode (&optional toggle)
1236 (defun allout-mode (&optional toggle
)
1238 "Toggle minor mode for controlling exposure and editing of text outlines.
1240 Optional arg forces mode to re-initialize iff arg is positive num or
1241 symbol. Allout outline mode always runs as a minor mode.
1243 Allout outline mode provides extensive outline oriented formatting and
1244 manipulation. It enables structural editing of outlines, as well as
1245 navigation and exposure. It also is specifically aimed at
1246 accommodating syntax-sensitive text like programming languages. \(For
1247 an example, see the allout code itself, which is organized as an allout
1250 In addition to outline navigation and exposure, allout includes:
1252 - topic-oriented repositioning, promotion/demotion, cut, and paste
1253 - integral outline exposure-layout
1254 - incremental search with dynamic exposure and reconcealment of hidden text
1255 - automatic topic-number maintenance
1256 - easy topic encryption and decryption
1257 - \"Hot-spot\" operation, for single-keystroke maneuvering and
1258 exposure control. \(See the allout-mode docstring.)
1260 and many other features.
1262 Below is a description of the bindings, and then explanation of
1263 special `allout-mode' features and terminology. See also the outline
1264 menubar additions for quick reference to many of the features, and see
1265 the docstring of the function `allout-init' for instructions on
1266 priming your emacs session for automatic activation of `allout-mode'.
1269 The bindings are dictated by the `allout-keybindings-list' and
1270 `allout-command-prefix' variables.
1272 Navigation: Exposure Control:
1273 ---------- ----------------
1274 C-c C-n allout-next-visible-heading | C-c C-h allout-hide-current-subtree
1275 C-c C-p allout-previous-visible-heading | C-c C-i allout-show-children
1276 C-c C-u allout-up-current-level | C-c C-s allout-show-current-subtree
1277 C-c C-f allout-forward-current-level | C-c C-o allout-show-current-entry
1278 C-c C-b allout-backward-current-level | ^U C-c C-s allout-show-all
1279 C-c C-e allout-end-of-entry | allout-hide-current-leaves
1280 C-c C-a allout-beginning-of-current-entry, alternately, goes to hot-spot
1282 Topic Header Production:
1283 -----------------------
1284 C-c<SP> allout-open-sibtopic Create a new sibling after current topic.
1285 C-c . allout-open-subtopic ... an offspring of current topic.
1286 C-c , allout-open-supertopic ... a sibling of the current topic's parent.
1288 Topic Level and Prefix Adjustment:
1289 ---------------------------------
1290 C-c > allout-shift-in Shift current topic and all offspring deeper.
1291 C-c < allout-shift-out ... less deep.
1292 C-c<CR> allout-rebullet-topic Reconcile bullets of topic and its offspring
1293 - distinctive bullets are not changed, others
1294 alternated according to nesting depth.
1295 C-c b allout-rebullet-current-heading Prompt for alternate bullet for
1297 C-c # allout-number-siblings Number bullets of topic and siblings - the
1298 offspring are not affected. With repeat
1299 count, revoke numbering.
1301 Topic-oriented Killing and Yanking:
1302 ----------------------------------
1303 C-c C-k allout-kill-topic Kill current topic, including offspring.
1304 C-k allout-kill-line Like kill-line, but reconciles numbering, etc.
1305 C-y allout-yank Yank, adjusting depth of yanked topic to
1306 depth of heading if yanking into bare topic
1307 heading (ie, prefix sans text).
1308 M-y allout-yank-pop Is to allout-yank as yank-pop is to yank
1312 M-x outlineify-sticky Activate outline mode for current buffer,
1313 and establish a default file-var setting
1314 for `allout-layout'.
1315 C-c C-SPC allout-mark-topic
1316 C-c = c allout-copy-exposed-to-buffer
1317 Duplicate outline, sans concealed text, to
1318 buffer with name derived from derived from that
1319 of current buffer - \"*BUFFERNAME exposed*\".
1320 C-c = p allout-flatten-exposed-to-buffer
1321 Like above 'copy-exposed', but convert topic
1322 prefixes to section.subsection... numeric
1324 ESC ESC (allout-init t) Setup Emacs session for outline mode
1329 Outline mode supports easily togglable gpg encryption of topics, with
1330 niceities like support for symmetric and key-pair modes, key timeout, key
1331 consistency checking, user-provided hinting for symmetric key mode, and
1332 auto-encryption of topics pending encryption on save. The aim is to enable
1333 reliable topic privacy while preventing accidents like neglected
1334 encryption, encryption with a mistaken key, forgetting which key was used,
1335 and other practical pitfalls.
1337 See the `allout-toggle-current-subtree-encryption' function and
1338 `allout-encrypt-unencrypted-on-saves' customization variable for details.
1342 Hot-spot operation provides a means for easy, single-keystroke outline
1343 navigation and exposure control.
1346 When the text cursor is positioned directly on the bullet character of
1347 a topic, regular characters (a to z) invoke the commands of the
1348 corresponding allout-mode keymap control chars. For example, \"f\"
1349 would invoke the command typically bound to \"C-c C-f\"
1350 \(\\[allout-forward-current-level] `allout-forward-current-level').
1352 Thus, by positioning the cursor on a topic bullet, you can execute
1353 the outline navigation and manipulation commands with a single
1354 keystroke. Non-literal chars never get this special translation, so
1355 you can use them to get away from the hot-spot, and back to normal
1358 Note that the command `allout-beginning-of-current-entry' \(\\[allout-beginning-of-current-entry]\)
1359 will move to the hot-spot when the cursor is already located at the
1360 beginning of the current entry, so you can simply hit \\[allout-beginning-of-current-entry]
1361 twice in a row to get to the hot-spot.
1365 Topic hierarchy constituents - TOPICS and SUBTOPICS:
1367 TOPIC: A basic, coherent component of an Emacs outline. It can
1368 contain other topics, and it can be subsumed by other topics,
1370 The visible topic most immediately containing the cursor.
1371 DEPTH: The degree of nesting of a topic; it increases with
1372 containment. Also called the:
1373 LEVEL: The same as DEPTH.
1376 The topics that contain a topic.
1377 PARENT: A topic's immediate ancestor. It has a depth one less than
1380 The topics contained by a topic;
1382 An immediate offspring of a topic;
1384 The immediate offspring of a topic.
1386 Topics having the same parent and depth.
1388 Topic text constituents:
1390 HEADER: The first line of a topic, include the topic PREFIX and header
1392 PREFIX: The leading text of a topic which distinguishes it from normal
1393 text. It has a strict form, which consists of a prefix-lead
1394 string, padding, and a bullet. The bullet may be followed by a
1395 number, indicating the ordinal number of the topic among its
1396 siblings, a space, and then the header text.
1398 The relative length of the PREFIX determines the nesting depth
1401 The string at the beginning of a topic prefix, normally a `.'.
1402 It can be customized by changing the setting of
1403 `allout-header-prefix' and then reinitializing `allout-mode'.
1405 By setting the prefix-lead to the comment-string of a
1406 programming language, you can embed outline structuring in
1407 program code without interfering with the language processing
1408 of that code. See `allout-use-mode-specific-leader'
1409 docstring for more detail.
1411 Spaces or asterisks which separate the prefix-lead and the
1412 bullet, according to the depth of the topic.
1413 BULLET: A character at the end of the topic prefix, it must be one of
1414 the characters listed on `allout-plain-bullets-string' or
1415 `allout-distinctive-bullets-string'. (See the documentation
1416 for these variables for more details.) The default choice of
1417 bullet when generating varies in a cycle with the depth of the
1419 ENTRY: The text contained in a topic before any offspring.
1420 BODY: Same as ENTRY.
1424 The state of a topic which determines the on-screen visibility
1425 of its offspring and contained text.
1427 Topics and entry text whose display is inhibited. Contiguous
1428 units of concealed text is represented by `...' ellipses.
1429 (Ref the `selective-display' var.)
1431 Concealed topics are effectively collapsed within an ancestor.
1432 CLOSED: A topic whose immediate offspring and body-text is concealed.
1433 OPEN: A topic that is not closed, though its offspring or body may be."
1437 (let* ((active (and (not (equal major-mode
'outline
))
1439 ; Massage universal-arg `toggle' val:
1441 (or (and (listp toggle
)(car toggle
))
1443 ; Activation specifically demanded?
1444 (explicit-activation (or
1447 (or (symbolp toggle
)
1448 (and (natnump toggle
)
1449 (not (zerop toggle
)))))))
1450 ;; allout-mode already called once during this complex command?
1451 (same-complex-command (eq allout-v18
/19-file-var-hack
1452 (car command-history
)))
1456 ; See comments below re v19.18,.19 bug.
1457 (setq allout-v18
/19-file-var-hack
(car command-history
))
1461 ;; Provision for v19.18, 19.19 bug -
1462 ;; Emacs v 19.18, 19.19 file-var code invokes prop-line-designated
1463 ;; modes twice when file is visited. We have to avoid toggling mode
1464 ;; off on second invocation, so we detect it as best we can, and
1466 ((and same-complex-command
; Still in same complex command
1467 ; as last time `allout-mode' invoked.
1468 active
; Already activated.
1469 (not explicit-activation
) ; Prop-line file-vars don't have args.
1470 (string-match "^19.1[89]" ; Bug only known to be in v19.18 and
1471 emacs-version
)); 19.19.
1475 ((and (not explicit-activation
)
1477 ; Activation not explicitly
1478 ; requested, and either in
1479 ; active state or *de*activation
1480 ; specifically requested:
1481 (setq allout-explicitly-deactivated t
)
1482 (if (string-match "^18\." emacs-version
)
1483 ; Revoke those keys that remain
1485 (let ((curr-loc (current-local-map)))
1488 (if (eq (lookup-key curr-loc
(car cell
))
1490 (define-key curr-loc
(car cell
)
1491 (assq (car cell
) allout-prior-bindings
)))))
1492 allout-added-bindings
)
1493 (allout-resumptions 'allout-added-bindings
)
1494 (allout-resumptions 'allout-prior-bindings
)))
1496 (if allout-old-style-prefixes
1498 (allout-resumptions 'allout-primary-bullet
)
1499 (allout-resumptions 'allout-old-style-prefixes
)))
1500 (allout-resumptions 'selective-display
)
1501 (if (and (boundp 'before-change-functions
) before-change-functions
)
1502 (allout-resumptions 'before-change-functions
))
1503 (setq local-write-file-hooks
1504 (delq 'allout-write-file-hook-handler
1505 local-write-file-hooks
))
1506 (setq auto-save-hook
1507 (delq 'allout-auto-save-hook-handler
1509 (allout-resumptions 'paragraph-start
)
1510 (allout-resumptions 'paragraph-separate
)
1511 (allout-resumptions (if (string-match "^18" emacs-version
)
1513 'auto-fill-function
))
1514 (allout-resumptions 'allout-former-auto-filler
)
1515 (setq allout-mode nil
))
1519 (setq allout-explicitly-deactivated nil
)
1520 (if allout-old-style-prefixes
1521 (progn ; Inhibit all the fancy formatting:
1522 (allout-resumptions 'allout-primary-bullet
'("*"))
1523 (allout-resumptions 'allout-old-style-prefixes
'(()))))
1525 (allout-infer-header-lead)
1526 (allout-infer-body-reindent)
1530 ; Produce map from current version
1531 ; of allout-keybindings-list:
1532 (if (boundp 'minor-mode-map-alist
)
1534 (progn ; V19, and maybe lucid and
1535 ; epoch, minor-mode key bindings:
1536 (setq allout-mode-map
1537 (produce-allout-mode-map allout-keybindings-list
))
1538 (produce-allout-mode-menubar-entries)
1539 (fset 'allout-mode-map allout-mode-map
)
1540 ; Include on minor-mode-map-alist,
1541 ; if not already there:
1542 (if (not (member '(allout-mode . allout-mode-map
)
1543 minor-mode-map-alist
))
1544 (setq minor-mode-map-alist
1545 (cons '(allout-mode . allout-mode-map
)
1546 minor-mode-map-alist
))))
1548 ; V18 minor-mode key bindings:
1549 ; Stash record of added bindings
1550 ; for later revocation:
1551 (allout-resumptions 'allout-added-bindings
1552 (list allout-keybindings-list
))
1553 (allout-resumptions 'allout-prior-bindings
1554 (list (current-local-map)))
1556 (use-local-map (produce-allout-mode-map allout-keybindings-list
1557 (current-local-map)))
1560 ; selective-display is the
1561 ; emacs conditional exposure
1563 (allout-resumptions 'selective-display
'(t))
1564 (add-hook 'pre-command-hook
'allout-pre-command-business
)
1565 (add-hook 'post-command-hook
'allout-post-command-business
)
1566 (add-hook 'local-write-file-hooks
'allout-write-file-hook-handler
)
1567 (make-variable-buffer-local 'auto-save-hook
)
1568 (add-hook 'auto-save-hook
'allout-auto-save-hook-handler
)
1569 ; Custom auto-fill func, to support
1570 ; respect for topic headline,
1571 ; hanging-indents, etc:
1572 (let* ((fill-func-var (if (string-match "^18" emacs-version
)
1574 'auto-fill-function
))
1575 (fill-func (symbol-value fill-func-var
)))
1576 ;; Register prevailing fill func for use by allout-auto-fill:
1577 (allout-resumptions 'allout-former-auto-filler
(list fill-func
))
1578 ;; Register allout-auto-fill to be used if filling is active:
1579 (allout-resumptions fill-func-var
'(allout-auto-fill)))
1580 ;; Paragraphs are broken by topic headlines.
1581 (make-local-variable 'paragraph-start
)
1582 (allout-resumptions 'paragraph-start
1583 (list (concat paragraph-start
"\\|^\\("
1584 allout-regexp
"\\)")))
1585 (make-local-variable 'paragraph-separate
)
1586 (allout-resumptions 'paragraph-separate
1587 (list (concat paragraph-separate
"\\|^\\("
1588 allout-regexp
"\\)")))
1590 (or (assq 'allout-mode minor-mode-alist
)
1591 (setq minor-mode-alist
1592 (cons '(allout-mode " Allout") minor-mode-alist
)))
1594 (allout-setup-menubar)
1599 (if (and allout-isearch-dynamic-expose
1600 (not (fboundp 'allout-real-isearch-abort
)))
1601 (allout-enwrap-isearch))
1603 (run-hooks 'allout-mode-hook
)
1604 (setq allout-mode t
))
1608 (allout-infer-body-reindent))
1612 allout-auto-activation
1613 (listp allout-layout
)
1614 (and (not (eq allout-auto-activation
'activate
))
1615 (if (eq allout-auto-activation
'ask
)
1616 (if (y-or-n-p (format "Expose %s with layout '%s'? "
1620 (message "Skipped %s layout." (buffer-name))
1624 (message "Adjusting '%s' exposure..." (buffer-name))
1626 (allout-this-or-next-heading)
1629 (apply 'allout-expose-topic
(list allout-layout
))
1630 (message "Adjusting '%s' exposure... done." (buffer-name)))
1631 ;; Problem applying exposure - notify user, but don't
1632 ;; interrupt, eg, file visit:
1633 (error (message "%s" (car (cdr err
)))
1638 ;;;_ > allout-minor-mode
1639 (defalias 'allout-minor-mode
'allout-mode
)
1641 ;;;_ #3 Internal Position State-Tracking - "allout-recent-*" funcs
1642 ;;; All the basic outline functions that directly do string matches to
1643 ;;; evaluate heading prefix location set the variables
1644 ;;; `allout-recent-prefix-beginning' and `allout-recent-prefix-end'
1645 ;;; when successful. Functions starting with `allout-recent-' all
1646 ;;; use this state, providing the means to avoid redundant searches
1647 ;;; for just-established data. This optimization can provide
1648 ;;; significant speed improvement, but it must be employed carefully.
1649 ;;;_ = allout-recent-prefix-beginning
1650 (defvar allout-recent-prefix-beginning
0
1651 "Buffer point of the start of the last topic prefix encountered.")
1652 (make-variable-buffer-local 'allout-recent-prefix-beginning
)
1653 ;;;_ = allout-recent-prefix-end
1654 (defvar allout-recent-prefix-end
0
1655 "Buffer point of the end of the last topic prefix encountered.")
1656 (make-variable-buffer-local 'allout-recent-prefix-end
)
1657 ;;;_ = allout-recent-end-of-subtree
1658 (defvar allout-recent-end-of-subtree
0
1659 "Buffer point last returned by `allout-end-of-current-subtree'.")
1660 (make-variable-buffer-local 'allout-recent-end-of-subtree
)
1661 ;;;_ > allout-prefix-data (beg end)
1662 (defmacro allout-prefix-data
(beg end
)
1663 "Register allout-prefix state data - BEGINNING and END of prefix.
1665 For reference by `allout-recent' funcs. Returns BEGINNING."
1666 `(setq allout-recent-prefix-end
,end
1667 allout-recent-prefix-beginning
,beg
))
1668 ;;;_ > allout-recent-depth ()
1669 (defmacro allout-recent-depth
()
1670 "Return depth of last heading encountered by an outline maneuvering function.
1672 All outline functions which directly do string matches to assess
1673 headings set the variables `allout-recent-prefix-beginning' and
1674 `allout-recent-prefix-end' if successful. This function uses those settings
1675 to return the current depth."
1677 '(max 1 (- allout-recent-prefix-end
1678 allout-recent-prefix-beginning
1679 allout-header-subtraction
)))
1680 ;;;_ > allout-recent-prefix ()
1681 (defmacro allout-recent-prefix
()
1682 "Like `allout-recent-depth', but returns text of last encountered prefix.
1684 All outline functions which directly do string matches to assess
1685 headings set the variables `allout-recent-prefix-beginning' and
1686 `allout-recent-prefix-end' if successful. This function uses those settings
1687 to return the current depth."
1688 '(buffer-substring allout-recent-prefix-beginning
1689 allout-recent-prefix-end
))
1690 ;;;_ > allout-recent-bullet ()
1691 (defmacro allout-recent-bullet
()
1692 "Like allout-recent-prefix, but returns bullet of last encountered prefix.
1694 All outline functions which directly do string matches to assess
1695 headings set the variables `allout-recent-prefix-beginning' and
1696 `allout-recent-prefix-end' if successful. This function uses those settings
1697 to return the current depth of the most recently matched topic."
1698 '(buffer-substring (1- allout-recent-prefix-end
)
1699 allout-recent-prefix-end
))
1703 ;;;_ - Position Assessment
1704 ;;;_ : Location Predicates
1705 ;;;_ > allout-on-current-heading-p ()
1706 (defun allout-on-current-heading-p ()
1707 "Return non-nil if point is on current visible topics' header line.
1709 Actually, returns prefix beginning point."
1712 (and (looking-at allout-regexp
)
1713 (allout-prefix-data (match-beginning 0) (match-end 0)))))
1714 ;;;_ > allout-on-heading-p ()
1715 (defalias 'allout-on-heading-p
'allout-on-current-heading-p
)
1716 ;;;_ > allout-e-o-prefix-p ()
1717 (defun allout-e-o-prefix-p ()
1718 "True if point is located where current topic prefix ends, heading begins."
1719 (and (save-excursion (beginning-of-line)
1720 (looking-at allout-regexp
))
1721 (= (point)(save-excursion (allout-end-of-prefix)(point)))))
1722 ;;;_ > allout-hidden-p ()
1723 (defmacro allout-hidden-p
()
1724 "True if point is in hidden text."
1726 (and (re-search-backward "[\n\r]" () t
)
1727 (= ?
\r (following-char)))))
1728 ;;;_ > allout-visible-p ()
1729 (defmacro allout-visible-p
()
1730 "True if point is not in hidden text."
1732 '(not (allout-hidden-p)))
1733 ;;;_ : Location attributes
1734 ;;;_ > allout-depth ()
1735 (defsubst allout-depth
()
1736 "Like `allout-current-depth', but respects hidden as well as visible topics."
1738 (if (allout-goto-prefix)
1739 (allout-recent-depth)
1741 ;; Oops, no prefix, zero prefix data:
1742 (allout-prefix-data (point)(point))
1743 ;; ... and return 0:
1745 ;;;_ > allout-current-depth ()
1746 (defmacro allout-current-depth
()
1747 "Return nesting depth of visible topic most immediately containing point."
1749 (if (allout-back-to-current-heading)
1751 (- allout-recent-prefix-end
1752 allout-recent-prefix-beginning
1753 allout-header-subtraction
))
1755 ;;;_ > allout-get-current-prefix ()
1756 (defun allout-get-current-prefix ()
1757 "Topic prefix of the current topic."
1759 (if (allout-goto-prefix)
1760 (allout-recent-prefix))))
1761 ;;;_ > allout-get-bullet ()
1762 (defun allout-get-bullet ()
1763 "Return bullet of containing topic (visible or not)."
1765 (and (allout-goto-prefix)
1766 (allout-recent-bullet))))
1767 ;;;_ > allout-current-bullet ()
1768 (defun allout-current-bullet ()
1769 "Return bullet of current (visible) topic heading, or none if none found."
1772 (allout-back-to-current-heading)
1773 (buffer-substring (- allout-recent-prefix-end
1)
1774 allout-recent-prefix-end
))
1775 ;; Quick and dirty provision, ostensibly for missing bullet:
1776 ('args-out-of-range nil
))
1778 ;;;_ > allout-get-prefix-bullet (prefix)
1779 (defun allout-get-prefix-bullet (prefix)
1780 "Return the bullet of the header prefix string PREFIX."
1781 ;; Doesn't make sense if we're old-style prefixes, but this just
1782 ;; oughtn't be called then, so forget about it...
1783 (if (string-match allout-regexp prefix
)
1784 (substring prefix
(1- (match-end 0)) (match-end 0))))
1785 ;;;_ > allout-sibling-index (&optional depth)
1786 (defun allout-sibling-index (&optional depth
)
1787 "Item number of this prospective topic among its siblings.
1789 If optional arg DEPTH is greater than current depth, then we're
1790 opening a new level, and return 0.
1792 If less than this depth, ascend to that depth and count..."
1795 (cond ((and depth
(<= depth
0) 0))
1796 ((or (not depth
) (= depth
(allout-depth)))
1798 (while (allout-previous-sibling (allout-recent-depth) nil
)
1799 (setq index
(1+ index
)))
1801 ((< depth
(allout-recent-depth))
1802 (allout-ascend-to-depth depth
)
1803 (allout-sibling-index))
1805 ;;;_ > allout-topic-flat-index ()
1806 (defun allout-topic-flat-index ()
1807 "Return a list indicating point's numeric section.subsect.subsubsect...
1808 Outermost is first."
1809 (let* ((depth (allout-depth))
1810 (next-index (allout-sibling-index depth
))
1812 (while (> next-index
0)
1813 (setq rev-sibls
(cons next-index rev-sibls
))
1814 (setq depth
(1- depth
))
1815 (setq next-index
(allout-sibling-index depth
)))
1819 ;;;_ - Navigation macros
1820 ;;;_ > allout-next-heading ()
1821 (defsubst allout-next-heading
()
1822 "Move to the heading for the topic \(possibly invisible) before this one.
1824 Returns the location of the heading, or nil if none found."
1826 (if (and (bobp) (not (eobp)))
1829 (if (re-search-forward allout-line-boundary-regexp nil
0)
1830 (allout-prefix-data ; Got valid location state - set vars:
1831 (goto-char (or (match-beginning 2)
1832 allout-recent-prefix-beginning
))
1833 (or (match-end 2) allout-recent-prefix-end
))))
1834 ;;;_ : allout-this-or-next-heading
1835 (defun allout-this-or-next-heading ()
1836 "Position cursor on current or next heading."
1837 ;; A throwaway non-macro that is defined after allout-next-heading
1838 ;; and usable by allout-mode.
1839 (if (not (allout-goto-prefix)) (allout-next-heading)))
1840 ;;;_ > allout-previous-heading ()
1841 (defmacro allout-previous-heading
()
1842 "Move to the prior \(possibly invisible) heading line.
1844 Return the location of the beginning of the heading, or nil if not found."
1848 (allout-goto-prefix)
1850 ;; searches are unbounded and return nil if failed:
1851 (or (re-search-backward allout-line-boundary-regexp nil
0)
1852 (looking-at allout-bob-regexp
))
1853 (progn ; Got valid location state - set vars:
1855 (goto-char (or (match-beginning 2)
1856 allout-recent-prefix-beginning
))
1857 (or (match-end 2) allout-recent-prefix-end
))))))
1859 ;;;_ - Subtree Charting
1860 ;;;_ " These routines either produce or assess charts, which are
1861 ;;; nested lists of the locations of topics within a subtree.
1863 ;;; Use of charts enables efficient navigation of subtrees, by
1864 ;;; requiring only a single regexp-search based traversal, to scope
1865 ;;; out the subtopic locations. The chart then serves as the basis
1866 ;;; for assessment or adjustment of the subtree, without redundant
1867 ;;; traversal of the structure.
1869 ;;;_ > allout-chart-subtree (&optional levels orig-depth prev-depth)
1870 (defun allout-chart-subtree (&optional levels orig-depth prev-depth
)
1871 "Produce a location \"chart\" of subtopics of the containing topic.
1873 Optional argument LEVELS specifies the depth \(relative to start
1874 depth) for the chart. Subsequent optional args are not for public
1877 Point is left at the end of the subtree.
1879 Charts are used to capture outline structure, so that outline-altering
1880 routines need assess the structure only once, and then use the chart
1881 for their elaborate manipulations.
1883 Topics are entered in the chart so the last one is at the car.
1884 The entry for each topic consists of an integer indicating the point
1885 at the beginning of the topic. Charts for offspring consists of a
1886 list containing, recursively, the charts for the respective subtopics.
1887 The chart for a topics' offspring precedes the entry for the topic
1890 The other function parameters are for internal recursion, and should
1891 not be specified by external callers. ORIG-DEPTH is depth of topic at
1892 starting point, and PREV-DEPTH is depth of prior topic."
1894 (let ((original (not orig-depth
)) ; `orig-depth' set only in recursion.
1897 (if original
; Just starting?
1898 ; Register initial settings and
1899 ; position to first offspring:
1900 (progn (setq orig-depth
(allout-depth))
1901 (or prev-depth
(setq prev-depth
(1+ orig-depth
)))
1902 (allout-next-heading)))
1904 ;; Loop over the current levels' siblings. Besides being more
1905 ;; efficient than tail-recursing over a level, it avoids exceeding
1906 ;; the typically quite constrained Emacs max-lisp-eval-depth.
1908 ;; Probably would speed things up to implement loop-based stack
1909 ;; operation rather than recursing for lower levels. Bah.
1911 (while (and (not (eobp))
1912 ; Still within original topic?
1913 (< orig-depth
(setq curr-depth
(allout-recent-depth)))
1914 (cond ((= prev-depth curr-depth
)
1915 ;; Register this one and move on:
1916 (setq chart
(cons (point) chart
))
1917 (if (and levels
(<= levels
1))
1918 ;; At depth limit - skip sublevels:
1919 (or (allout-next-sibling curr-depth
)
1920 ;; or no more siblings - proceed to
1921 ;; next heading at lesser depth:
1922 (while (and (<= curr-depth
1923 (allout-recent-depth))
1924 (allout-next-heading))))
1925 (allout-next-heading)))
1927 ((and (< prev-depth curr-depth
)
1930 ;; Recurse on deeper level of curr topic:
1932 (cons (allout-chart-subtree (and levels
1937 ;; ... then continue with this one.
1940 ;; ... else nil if we've ascended back to prev-depth.
1944 (if original
; We're at the last sibling on
1945 ; the original level. Position
1947 (progn (and (not (eobp)) (forward-char -
1))
1948 (and (memq (preceding-char) '(?
\n ?
\r))
1949 (memq (aref (buffer-substring (max 1 (- (point) 3))
1954 (setq allout-recent-end-of-subtree
(point))))
1956 chart
; (nreverse chart) not necessary,
1957 ; and maybe not preferable.
1959 ;;;_ > allout-chart-siblings (&optional start end)
1960 (defun allout-chart-siblings (&optional start end
)
1961 "Produce a list of locations of this and succeeding sibling topics.
1962 Effectively a top-level chart of siblings. See `allout-chart-subtree'
1963 for an explanation of charts."
1965 (if (allout-goto-prefix)
1966 (let ((chart (list (point))))
1967 (while (allout-next-sibling)
1968 (setq chart
(cons (point) chart
)))
1969 (if chart
(setq chart
(nreverse chart
)))))))
1970 ;;;_ > allout-chart-to-reveal (chart depth)
1971 (defun allout-chart-to-reveal (chart depth
)
1973 "Return a flat list of hidden points in subtree CHART, up to DEPTH.
1975 Note that point can be left at any of the points on chart, or at the
1979 (while (and (or (eq depth t
) (> depth
0))
1981 (setq here
(car chart
))
1983 (let ((further (allout-chart-to-reveal here
(or (eq depth t
)
1985 ;; We're on the start of a subtree - recurse with it, if there's
1986 ;; more depth to go:
1987 (if further
(setq result
(append further result
)))
1988 (setq chart
(cdr chart
)))
1990 (if (= (preceding-char) ?
\r)
1991 (setq result
(cons here result
)))
1992 (setq chart
(cdr chart
))))
1994 ;;;_ X allout-chart-spec (chart spec &optional exposing)
1995 ;; (defun allout-chart-spec (chart spec &optional exposing)
1996 ;; "Not yet \(if ever) implemented.
1998 ;; Produce exposure directives given topic/subtree CHART and an exposure SPEC.
2000 ;; Exposure spec indicates the locations to be exposed and the prescribed
2001 ;; exposure status. Optional arg EXPOSING is an integer, with 0
2002 ;; indicating pending concealment, anything higher indicating depth to
2003 ;; which subtopic headers should be exposed, and negative numbers
2004 ;; indicating (negative of) the depth to which subtopic headers and
2005 ;; bodies should be exposed.
2007 ;; The produced list can have two types of entries. Bare numbers
2008 ;; indicate points in the buffer where topic headers that should be
2011 ;; - bare negative numbers indicates that the topic starting at the
2012 ;; point which is the negative of the number should be opened,
2013 ;; including their entries.
2014 ;; - bare positive values indicate that this topic header should be
2016 ;; - Lists signify the beginning and end points of regions that should
2017 ;; be flagged, and the flag to employ. (For concealment: `\(\?r\)', and
2020 ;; (cond ((listp spec)
2023 ;; (setq spec (cdr spec)))
2027 ;;;_ > allout-goto-prefix ()
2028 (defun allout-goto-prefix ()
2029 "Put point at beginning of immediately containing outline topic.
2031 Goes to most immediate subsequent topic if none immediately containing.
2033 Not sensitive to topic visibility.
2035 Returns the point at the beginning of the prefix, or nil if none."
2038 (while (and (not done
)
2039 (re-search-backward "[\n\r]" nil
1))
2041 (if (looking-at allout-regexp
)
2042 (setq done
(allout-prefix-data (match-beginning 0)
2046 (cond ((looking-at allout-regexp
)
2047 (allout-prefix-data (match-beginning 0)(match-end 0)))
2048 ((allout-next-heading))
2051 ;;;_ > allout-end-of-prefix ()
2052 (defun allout-end-of-prefix (&optional ignore-decorations
)
2053 "Position cursor at beginning of header text.
2055 If optional IGNORE-DECORATIONS is non-nil, put just after bullet,
2056 otherwise skip white space between bullet and ensuing text."
2058 (if (not (allout-goto-prefix))
2060 (let ((match-data (match-data)))
2061 (goto-char (match-end 0))
2062 (if ignore-decorations
2064 (while (looking-at "[0-9]") (forward-char 1))
2065 (if (and (not (eolp)) (looking-at "\\s-")) (forward-char 1)))
2066 (store-match-data match-data
))
2067 ;; Reestablish where we are:
2068 (allout-current-depth)))
2069 ;;;_ > allout-current-bullet-pos ()
2070 (defun allout-current-bullet-pos ()
2071 "Return position of current \(visible) topic's bullet."
2073 (if (not (allout-current-depth))
2075 (1- (match-end 0))))
2076 ;;;_ > allout-back-to-current-heading ()
2077 (defun allout-back-to-current-heading ()
2078 "Move to heading line of current topic, or beginning if already on the line."
2081 (prog1 (or (allout-on-current-heading-p)
2082 (and (re-search-backward (concat "^\\(" allout-regexp
"\\)")
2085 (allout-prefix-data (match-beginning 1)(match-end 1))))
2086 (if (interactive-p) (allout-end-of-prefix))))
2087 ;;;_ > allout-back-to-heading ()
2088 (defalias 'allout-back-to-heading
'allout-back-to-current-heading
)
2089 ;;;_ > allout-pre-next-preface ()
2090 (defun allout-pre-next-preface ()
2091 "Skip forward to just before the next heading line.
2093 Returns that character position."
2095 (if (re-search-forward allout-line-boundary-regexp nil
'move
)
2096 (prog1 (goto-char (match-beginning 0))
2097 (allout-prefix-data (match-beginning 2)(match-end 2)))))
2098 ;;;_ > allout-end-of-subtree (&optional current)
2099 (defun allout-end-of-subtree (&optional current
)
2100 "Put point at the end of the last leaf in the containing topic.
2102 If optional CURRENT is true (default false), then put point at the end of
2103 the containing visible topic.
2105 Returns the value of point."
2108 (allout-back-to-current-heading)
2109 (allout-goto-prefix))
2110 (let ((level (allout-recent-depth)))
2111 (allout-next-heading)
2112 (while (and (not (eobp))
2113 (> (allout-recent-depth) level
))
2114 (allout-next-heading))
2115 (and (not (eobp)) (forward-char -
1))
2116 (and (memq (preceding-char) '(?
\n ?
\r))
2117 (memq (aref (buffer-substring (max 1 (- (point) 3)) (point)) 1)
2120 (setq allout-recent-end-of-subtree
(point))))
2121 ;;;_ > allout-end-of-current-subtree ()
2122 (defun allout-end-of-current-subtree ()
2123 "Put point at end of last leaf in currently visible containing topic.
2125 Returns the value of point."
2127 (allout-end-of-subtree t
))
2128 ;;;_ > allout-beginning-of-current-entry ()
2129 (defun allout-beginning-of-current-entry ()
2130 "When not already there, position point at beginning of current topic header.
2132 If already there, move cursor to bullet for hot-spot operation.
2133 \(See `allout-mode' doc string for details on hot-spot operation.)"
2135 (let ((start-point (point)))
2136 (allout-end-of-prefix)
2137 (if (and (interactive-p)
2138 (= (point) start-point
))
2139 (goto-char (allout-current-bullet-pos)))))
2140 ;;;_ > allout-end-of-entry ()
2141 (defun allout-end-of-entry ()
2142 "Position the point at the end of the current topics' entry."
2144 (prog1 (allout-pre-next-preface)
2145 (if (and (not (bobp))(looking-at "^$"))
2146 (forward-char -
1))))
2147 ;;;_ > allout-end-of-current-heading ()
2148 (defun allout-end-of-current-heading ()
2150 (allout-beginning-of-current-entry)
2151 (re-search-forward "[\n\r]" nil t
)
2153 (defalias 'allout-end-of-heading
'allout-end-of-current-heading
)
2154 ;;;_ > allout-get-body-text ()
2155 (defun allout-get-body-text ()
2156 "Return the unmangled body text of the topic immediately containing point."
2158 (allout-end-of-prefix)
2159 (if (not (re-search-forward "[\n\r]" nil t
))
2162 (let ((pre-body (point)))
2165 (allout-end-of-entry)
2166 (if (not (= pre-body
(point)))
2167 (buffer-substring-no-properties (1+ pre-body
) (point))))
2174 ;;;_ > allout-ascend-to-depth (depth)
2175 (defun allout-ascend-to-depth (depth)
2176 "Ascend to depth DEPTH, returning depth if successful, nil if not."
2177 (if (and (> depth
0)(<= depth
(allout-depth)))
2178 (let ((last-good (point)))
2179 (while (and (< depth
(allout-depth))
2180 (setq last-good
(point))
2181 (allout-beginning-of-level)
2182 (allout-previous-heading)))
2183 (if (= (allout-recent-depth) depth
)
2184 (progn (goto-char allout-recent-prefix-beginning
)
2186 (goto-char last-good
)
2188 (if (interactive-p) (allout-end-of-prefix))))
2189 ;;;_ > allout-ascend ()
2190 (defun allout-ascend ()
2191 "Ascend one level, returning t if successful, nil if not."
2193 (if (allout-beginning-of-level)
2194 (allout-previous-heading))
2195 (if (interactive-p) (allout-end-of-prefix))))
2196 ;;;_ > allout-descend-to-depth (depth)
2197 (defun allout-descend-to-depth (depth)
2198 "Descend to depth DEPTH within current topic.
2200 Returning depth if successful, nil if not."
2201 (let ((start-point (point))
2202 (start-depth (allout-depth)))
2204 (and (> (allout-depth) 0)
2205 (not (= depth
(allout-recent-depth))) ; ... not there yet
2206 (allout-next-heading) ; ... go further
2207 (< start-depth
(allout-recent-depth)))) ; ... still in topic
2208 (if (and (> (allout-depth) 0)
2209 (= (allout-recent-depth) depth
))
2211 (goto-char start-point
)
2214 ;;;_ > allout-up-current-level (arg &optional dont-complain)
2215 (defun allout-up-current-level (arg &optional dont-complain
)
2216 "Move out ARG levels from current visible topic.
2218 Positions on heading line of containing topic. Error if unable to
2219 ascend that far, or nil if unable to ascend but optional arg
2220 DONT-COMPLAIN is non-nil."
2222 (allout-back-to-current-heading)
2223 (let ((present-level (allout-recent-depth))
2227 ;; Loop for iterating arg:
2228 (while (and (> (allout-recent-depth) 1)
2232 (setq last-good
(point))
2233 ;; Loop for going back over current or greater depth:
2234 (while (and (not (< (allout-recent-depth) present-level
))
2235 (or (allout-previous-visible-heading 1)
2236 (not (setq failed present-level
)))))
2237 (setq present-level
(allout-current-depth))
2238 (setq arg
(- arg
1)))
2241 (progn (goto-char last-good
)
2242 (if (interactive-p) (allout-end-of-prefix))
2243 (if (not dont-complain
)
2244 (error "Can't ascend past outermost level")
2245 (if (interactive-p) (allout-end-of-prefix))
2247 (if (interactive-p) (allout-end-of-prefix))
2248 allout-recent-prefix-beginning
)))
2251 ;;;_ > allout-next-sibling (&optional depth backward)
2252 (defun allout-next-sibling (&optional depth backward
)
2253 "Like `allout-forward-current-level', but respects invisible topics.
2255 Traverse at optional DEPTH, or current depth if none specified.
2257 Go backward if optional arg BACKWARD is non-nil.
2259 Return depth if successful, nil otherwise."
2261 (if (and backward
(bobp))
2263 (let ((start-depth (or depth
(allout-depth)))
2264 (start-point (point))
2266 (while (and (not (if backward
(bobp) (eobp)))
2267 (if backward
(allout-previous-heading)
2268 (allout-next-heading))
2269 (> (setq last-depth
(allout-recent-depth)) start-depth
)))
2270 (if (and (not (eobp))
2271 (and (> (or last-depth
(allout-depth)) 0)
2272 (= (allout-recent-depth) start-depth
)))
2273 allout-recent-prefix-beginning
2274 (goto-char start-point
)
2275 (if depth
(allout-depth) start-depth
)
2277 ;;;_ > allout-previous-sibling (&optional depth backward)
2278 (defun allout-previous-sibling (&optional depth backward
)
2279 "Like `allout-forward-current-level' backwards, respecting invisible topics.
2281 Optional DEPTH specifies depth to traverse, default current depth.
2283 Optional BACKWARD reverses direction.
2285 Return depth if successful, nil otherwise."
2286 (allout-next-sibling depth
(not backward
))
2288 ;;;_ > allout-snug-back ()
2289 (defun allout-snug-back ()
2290 "Position cursor at end of previous topic.
2292 Presumes point is at the start of a topic prefix."
2293 (if (or (bobp) (eobp))
2296 (if (or (bobp) (not (memq (preceding-char) '(?
\n ?
\r))))
2299 (if (or (bobp) (not (memq (preceding-char) '(?
\n ?
\r))))
2302 ;;;_ > allout-beginning-of-level ()
2303 (defun allout-beginning-of-level ()
2304 "Go back to the first sibling at this level, visible or not."
2305 (allout-end-of-level 'backward
))
2306 ;;;_ > allout-end-of-level (&optional backward)
2307 (defun allout-end-of-level (&optional backward
)
2308 "Go to the last sibling at this level, visible or not."
2310 (let ((depth (allout-depth)))
2311 (while (allout-previous-sibling depth nil
))
2312 (prog1 (allout-recent-depth)
2313 (if (interactive-p) (allout-end-of-prefix)))))
2314 ;;;_ > allout-next-visible-heading (arg)
2315 (defun allout-next-visible-heading (arg)
2316 "Move to the next ARG'th visible heading line, backward if arg is negative.
2318 Move as far as possible in indicated direction \(beginning or end of
2319 buffer) if headings are exhausted."
2322 (let* ((backward (if (< arg
0) (setq arg
(* -
1 arg
))))
2323 (step (if backward -
1 1))
2324 (start-point (point))
2327 (while (> arg
0) ; limit condition
2328 (while (and (not (if backward
(bobp)(eobp))) ; boundary condition
2329 ;; Move, skipping over all those concealed lines:
2330 (< -
1 (forward-line step
))
2331 (not (setq got
(looking-at allout-regexp
)))))
2332 ;; Register this got, it may be the last:
2333 (if got
(setq prev got
))
2334 (setq arg
(1- arg
)))
2335 (cond (got ; Last move was to a prefix:
2336 (allout-prefix-data (match-beginning 0) (match-end 0))
2337 (allout-end-of-prefix))
2338 (prev ; Last move wasn't, but prev was:
2339 (allout-prefix-data (match-beginning 0) (match-end 0)))
2340 ((not backward
) (end-of-line) nil
))))
2341 ;;;_ > allout-previous-visible-heading (arg)
2342 (defun allout-previous-visible-heading (arg)
2343 "Move to the previous heading line.
2345 With argument, repeats or can move forward if negative.
2346 A heading line is one that starts with a `*' (or that `allout-regexp'
2349 (allout-next-visible-heading (- arg
)))
2350 ;;;_ > allout-forward-current-level (arg)
2351 (defun allout-forward-current-level (arg)
2352 "Position point at the next heading of the same level.
2354 Takes optional repeat-count, goes backward if count is negative.
2356 Returns resulting position, else nil if none found."
2358 (let ((start-depth (allout-current-depth))
2359 (start-point (point))
2361 (backward (> 0 arg
))
2365 (if (= 0 start-depth
)
2366 (error "No siblings, not in a topic..."))
2367 (if backward
(setq arg
(* -
1 arg
)))
2368 (while (not (or (zerop arg
)
2370 (while (and (not (if backward
(bobp) (eobp)))
2371 (if backward
(allout-previous-visible-heading 1)
2372 (allout-next-visible-heading 1))
2373 (> (setq last-depth
(allout-recent-depth)) start-depth
)))
2374 (if (and last-depth
(= last-depth start-depth
)
2375 (not (if backward
(bobp) (eobp))))
2376 (setq last-good
(point)
2378 (setq at-boundary t
)))
2379 (if (and (not (eobp))
2381 (and (> (or last-depth
(allout-depth)) 0)
2382 (= (allout-recent-depth) start-depth
)))
2383 allout-recent-prefix-beginning
2384 (goto-char last-good
)
2385 (if (not (interactive-p))
2387 (allout-end-of-prefix)
2388 (error "Hit %s level %d topic, traversed %d of %d requested"
2389 (if backward
"first" "last")
2390 (allout-recent-depth)
2391 (- (abs start-arg
) arg
)
2392 (abs start-arg
))))))
2393 ;;;_ > allout-backward-current-level (arg)
2394 (defun allout-backward-current-level (arg)
2395 "Inverse of `allout-forward-current-level'."
2398 (let ((current-prefix-arg (* -
1 arg
)))
2399 (call-interactively 'allout-forward-current-level
))
2400 (allout-forward-current-level (* -
1 arg
))))
2405 ;;;_ = allout-post-goto-bullet
2406 (defvar allout-post-goto-bullet nil
2407 "Outline internal var, for `allout-pre-command-business' hot-spot operation.
2409 When set, tells post-processing to reposition on topic bullet, and
2410 then unset it. Set by `allout-pre-command-business' when implementing
2411 hot-spot operation, where literal characters typed over a topic bullet
2412 are mapped to the command of the corresponding control-key on the
2413 `allout-mode-map'.")
2414 (make-variable-buffer-local 'allout-post-goto-bullet
)
2415 ;;;_ > allout-post-command-business ()
2416 (defun allout-post-command-business ()
2417 "Outline `post-command-hook' function.
2419 - Implement (and clear) `allout-post-goto-bullet', for hot-spot
2422 - Decrypt topic currently being edited if it was encrypted for a save.
2424 - Massage buffer-undo-list so successive, standard character self-inserts are
2425 aggregated. This kludge compensates for lack of undo bunching when
2426 before-change-functions is used."
2428 ; Apply any external change func:
2429 (if (not (allout-mode-p)) ; In allout-mode.
2431 (if allout-isearch-dynamic-expose
2432 (allout-isearch-rectification))
2433 ;; Undo bunching business:
2434 (if (and (listp buffer-undo-list
) ; Undo history being kept.
2435 (equal this-command
'self-insert-command
)
2436 (equal last-command
'self-insert-command
))
2437 (let* ((prev-stuff (cdr buffer-undo-list
))
2438 (before-prev-stuff (cdr (cdr prev-stuff
)))
2439 cur-cell cur-from cur-to
2440 prev-cell prev-from prev-to
)
2441 (if (and before-prev-stuff
; Goes back far enough to bother,
2442 (not (car prev-stuff
)) ; and break before current,
2443 (not (car before-prev-stuff
)) ; !and break before prev!
2444 (setq prev-cell
(car (cdr prev-stuff
))) ; contents now,
2445 (setq cur-cell
(car buffer-undo-list
)) ; contents prev.
2447 ;; cur contents denote a single char insertion:
2448 (numberp (setq cur-from
(car cur-cell
)))
2449 (numberp (setq cur-to
(cdr cur-cell
)))
2450 (= 1 (- cur-to cur-from
))
2452 ;; prev contents denote fewer than aggregate-limit
2454 (numberp (setq prev-from
(car prev-cell
)))
2455 (numberp (setq prev-to
(cdr prev-cell
)))
2457 (> allout-undo-aggregation
(- prev-to prev-from
)))
2458 (setq buffer-undo-list
2459 (cons (cons prev-from cur-to
)
2460 (cdr (cdr (cdr buffer-undo-list
))))))))
2462 (if (and (boundp 'allout-after-save-decrypt
)
2463 allout-after-save-decrypt
)
2464 (allout-after-saves-handler))
2466 ;; Implement -post-goto-bullet, if set: (must be after undo business)
2467 (if (and allout-post-goto-bullet
2468 (allout-current-bullet-pos))
2469 (progn (goto-char (allout-current-bullet-pos))
2470 (setq allout-post-goto-bullet nil
)))
2472 ;;;_ > allout-pre-command-business ()
2473 (defun allout-pre-command-business ()
2474 "Outline `pre-command-hook' function for outline buffers.
2475 Implements special behavior when cursor is on bullet character.
2477 When the cursor is on the bullet character, self-insert characters are
2478 reinterpreted as the corresponding control-character in the
2479 `allout-mode-map'. The `allout-mode' `post-command-hook' insures that
2480 the cursor which has moved as a result of such reinterpretation is
2481 positioned on the bullet character of the destination topic.
2483 The upshot is that you can get easy, single (ie, unmodified) key
2484 outline maneuvering operations by positioning the cursor on the bullet
2485 char. When in this mode you can use regular cursor-positioning
2486 command/keystrokes to relocate the cursor off of a bullet character to
2487 return to regular interpretation of self-insert characters."
2489 (if (not (allout-mode-p))
2490 ;; Shouldn't be invoked if not in allout-mode, but just in case:
2492 ;; Register isearch status:
2493 (if (and (boundp 'isearch-mode
) isearch-mode
)
2494 (setq allout-pre-was-isearching t
)
2495 (setq allout-pre-was-isearching nil
))
2496 ;; Hot-spot navigation provisions:
2497 (if (and (eq this-command
'self-insert-command
)
2498 (eq (point)(allout-current-bullet-pos)))
2499 (let* ((this-key-num (cond
2500 ((numberp last-command-char
)
2502 ;; Only xemacs has characterp.
2503 ((and (fboundp 'characterp
)
2504 (characterp last-command-char
))
2505 (char-to-int last-command-char
))
2508 (if (zerop this-key-num
)
2510 ; Map upper-register literals
2511 ; to lower register:
2512 (if (<= 96 this-key-num
)
2513 (setq this-key-num
(- this-key-num
32)))
2514 ; Check if we have a literal:
2515 (if (and (<= 64 this-key-num
)
2516 (>= 96 this-key-num
))
2517 (setq mapped-binding
2518 (lookup-key 'allout-mode-map
2519 (concat allout-command-prefix
2520 (char-to-string (- this-key-num
2523 (setq allout-post-goto-bullet t
2524 this-command mapped-binding
)))))))
2525 ;;;_ > allout-find-file-hook ()
2526 (defun allout-find-file-hook ()
2527 "Activate `allout-mode' when `allout-auto-activation', `allout-layout' non-nil.
2529 See `allout-init' for setup instructions."
2530 (if (and allout-auto-activation
2531 (not (allout-mode-p))
2534 ;;;_ > allout-isearch-rectification
2535 (defun allout-isearch-rectification ()
2536 "Rectify outline exposure before, during, or after isearch.
2538 Called as part of `allout-post-command-business'."
2540 (let ((isearching (and (boundp 'isearch-mode
) isearch-mode
)))
2541 (cond ((and isearching
(not allout-pre-was-isearching
))
2542 (allout-isearch-expose 'start
))
2543 ((and isearching allout-pre-was-isearching
)
2544 (allout-isearch-expose 'continue
))
2545 ((and (not isearching
) allout-pre-was-isearching
)
2546 (allout-isearch-expose 'final
))
2547 ;; Not and wasn't isearching:
2548 (t (setq allout-isearch-prior-pos nil
)
2549 (setq allout-isearch-did-quit nil
)))))
2550 ;;;_ = allout-isearch-was-font-lock
2551 (defvar allout-isearch-was-font-lock
2552 (and (boundp 'font-lock-mode
) font-lock-mode
))
2553 ;;;_ > allout-isearch-expose (mode)
2554 (defun allout-isearch-expose (mode)
2555 "MODE is either 'clear, 'start, 'continue, or 'final."
2556 ;; allout-isearch-prior-pos encodes exposure status of prior pos:
2557 ;; (pos was-vis header-pos end-pos)
2558 ;; pos - point of concern
2559 ;; was-vis - t, else 'topic if entire topic was exposed, 'entry otherwise
2560 ;; Do reclosure or prior pos, as necessary:
2561 (if (eq mode
'start
)
2562 (setq allout-isearch-was-font-lock
(and (boundp 'font-lock-mode
)
2565 (if (eq mode
'final
)
2566 (setq font-lock-mode allout-isearch-was-font-lock
))
2567 (if (and allout-isearch-prior-pos
2568 (listp allout-isearch-prior-pos
))
2569 ;; Conceal prior peek:
2570 (allout-flag-region (car (cdr allout-isearch-prior-pos
))
2571 (car (cdr (cdr allout-isearch-prior-pos
)))
2573 (if (allout-visible-p)
2574 (setq allout-isearch-prior-pos nil
)
2575 (if (not (eq mode
'final
))
2576 (setq allout-isearch-prior-pos
(cons (point) (allout-show-entry)))
2577 (if allout-isearch-did-quit
2579 (setq allout-isearch-prior-pos nil
)
2580 (allout-show-children))))
2581 (setq allout-isearch-did-quit nil
))
2582 ;;;_ > allout-enwrap-isearch ()
2583 (defun allout-enwrap-isearch ()
2584 "Impose `allout-mode' isearch-abort wrapper for dynamic exposure in isearch.
2586 The function checks to ensure that the rebinding is done only once."
2588 (add-hook 'isearch-mode-end-hook
'allout-isearch-rectification
)
2589 (if (fboundp 'allout-real-isearch-abort
)
2592 ; Ensure load of isearch-mode:
2593 (if (or (and (fboundp 'isearch-mode
)
2594 (fboundp 'isearch-abort
))
2595 (condition-case error
2596 (load-library "isearch-mode")
2597 ('file-error
(message
2598 "Skipping isearch-mode provisions - %s '%s'"
2600 (car (cdr (cdr error
))))
2602 ;; Inhibit subsequent tries and return nil:
2603 (setq allout-isearch-dynamic-expose nil
))))
2604 ;; Isearch-mode loaded, encapsulate specific entry points for
2605 ;; outline dynamic-exposure business:
2607 ;; stash crucial isearch-mode funcs under known, private
2608 ;; names, then register wrapper functions under the old
2609 ;; names, in their stead:
2610 (fset 'allout-real-isearch-abort
(symbol-function 'isearch-abort
))
2611 (fset 'isearch-abort
'allout-isearch-abort
)))))
2612 ;;;_ > allout-isearch-abort ()
2613 (defun allout-isearch-abort ()
2614 "Wrapper for allout-real-isearch-abort \(which see), to register
2617 (setq allout-isearch-did-quit nil
)
2618 (condition-case what
2619 (allout-real-isearch-abort)
2620 ('quit
(setq allout-isearch-did-quit t
)
2621 (signal 'quit nil
))))
2623 ;;; Prevent unnecessary font-lock while isearching!
2624 (defvar isearch-was-font-locking nil
)
2625 (defun isearch-inhibit-font-lock ()
2626 "Inhibit `font-lock' while isearching - for use on `isearch-mode-hook'."
2627 (if (and (allout-mode-p) (boundp 'font-lock-mode
) font-lock-mode
)
2628 (setq isearch-was-font-locking t
2629 font-lock-mode nil
)))
2630 (add-hook 'isearch-mode-hook
'isearch-inhibit-font-lock
)
2631 (defun isearch-reenable-font-lock ()
2632 "Reenable font-lock after isearching - for use on `isearch-mode-end-hook'."
2633 (if (and (boundp 'font-lock-mode
) font-lock-mode
)
2634 (if (and (allout-mode-p) isearch-was-font-locking
)
2635 (setq isearch-was-font-locking nil
2636 font-lock-mode t
))))
2637 (add-hook 'isearch-mode-end-hook
'isearch-reenable-font-lock
)
2639 ;;;_ - Topic Format Assessment
2640 ;;;_ > allout-solicit-alternate-bullet (depth &optional current-bullet)
2641 (defun allout-solicit-alternate-bullet (depth &optional current-bullet
)
2643 "Prompt for and return a bullet char as an alternative to the current one.
2645 Offer one suitable for current depth DEPTH as default."
2647 (let* ((default-bullet (or (and (stringp current-bullet
) current-bullet
)
2648 (allout-bullet-for-depth depth
)))
2649 (sans-escapes (regexp-sans-escapes allout-bullets-string
))
2652 (goto-char (allout-current-bullet-pos))
2653 (setq choice
(solicit-char-in-string
2654 (format "Select bullet: %s ('%s' default): "
2660 (if (string= choice
"") default-bullet choice
))
2662 ;;;_ > allout-distinctive-bullet (bullet)
2663 (defun allout-distinctive-bullet (bullet)
2664 "True if BULLET is one of those on `allout-distinctive-bullets-string'."
2665 (string-match (regexp-quote bullet
) allout-distinctive-bullets-string
))
2666 ;;;_ > allout-numbered-type-prefix (&optional prefix)
2667 (defun allout-numbered-type-prefix (&optional prefix
)
2668 "True if current header prefix bullet is numbered bullet."
2669 (and allout-numbered-bullet
2670 (string= allout-numbered-bullet
2672 (allout-get-prefix-bullet prefix
)
2673 (allout-get-bullet)))))
2674 ;;;_ > allout-encrypted-type-prefix (&optional prefix)
2675 (defun allout-encrypted-type-prefix (&optional prefix
)
2676 "True if current header prefix bullet is for an encrypted entry \(body)."
2677 (and allout-topic-encryption-bullet
2678 (string= allout-topic-encryption-bullet
2680 (allout-get-prefix-bullet prefix
)
2681 (allout-get-bullet)))))
2682 ;;;_ > allout-bullet-for-depth (&optional depth)
2683 (defun allout-bullet-for-depth (&optional depth
)
2684 "Return outline topic bullet suited to optional DEPTH, or current depth."
2685 ;; Find bullet in plain-bullets-string modulo DEPTH.
2686 (if allout-stylish-prefixes
2687 (char-to-string (aref allout-plain-bullets-string
2688 (%
(max 0 (- depth
2))
2689 allout-plain-bullets-string-len
)))
2690 allout-primary-bullet
)
2693 ;;;_ - Topic Production
2694 ;;;_ > allout-make-topic-prefix (&optional prior-bullet
2695 (defun allout-make-topic-prefix (&optional prior-bullet
2701 ;; Depth null means use current depth, non-null means we're either
2702 ;; opening a new topic after current topic, lower or higher, or we're
2703 ;; changing level of current topic.
2704 ;; Solicit dominates specified bullet-char.
2706 "Generate a topic prefix suitable for optional arg DEPTH, or current depth.
2708 All the arguments are optional.
2710 PRIOR-BULLET indicates the bullet of the prefix being changed, or
2711 nil if none. This bullet may be preserved (other options
2712 notwithstanding) if it is on the `allout-distinctive-bullets-string',
2715 Second arg NEW indicates that a new topic is being opened after the
2716 topic at point, if non-nil. Default bullet for new topics, eg, may
2717 be set (contingent to other args) to numbered bullets if previous
2718 sibling is one. The implication otherwise is that the current topic
2719 is being adjusted - shifted or rebulleted - and we don't consider
2720 bullet or previous sibling.
2722 Third arg DEPTH forces the topic prefix to that depth, regardless of
2723 the current topics' depth.
2725 If SOLICIT is non-nil, then the choice of bullet is solicited from
2726 user. If it's a character, then that character is offered as the
2727 default, otherwise the one suited to the context \(according to
2728 distinction or depth) is offered. \(This overrides other options,
2729 including, eg, a distinctive PRIOR-BULLET.) If non-nil, then the
2730 context-specific bullet is used.
2732 Fifth arg, NUMBER-CONTROL, matters only if `allout-numbered-bullet'
2733 is non-nil *and* soliciting was not explicitly invoked. Then
2734 NUMBER-CONTROL non-nil forces prefix to either numbered or
2735 denumbered format, depending on the value of the sixth arg, INDEX.
2737 \(Note that NUMBER-CONTROL does *not* apply to level 1 topics. Sorry...)
2739 If NUMBER-CONTROL is non-nil and sixth arg INDEX is non-nil then
2740 the prefix of the topic is forced to be numbered. Non-nil
2741 NUMBER-CONTROL and nil INDEX forces non-numbered format on the
2742 bullet. Non-nil NUMBER-CONTROL and non-nil, non-number INDEX means
2743 that the index for the numbered prefix will be derived, by counting
2744 siblings back to start of level. If INDEX is a number, then that
2745 number is used as the index for the numbered prefix (allowing, eg,
2746 sequential renumbering to not require this function counting back the
2747 index for each successive sibling)."
2749 ;; The options are ordered in likely frequence of use, most common
2750 ;; highest, least lowest. Ie, more likely to be doing prefix
2751 ;; adjustments than soliciting, and yet more than numbering.
2752 ;; Current prefix is least dominant, but most likely to be commonly
2758 (depth (or depth
(allout-depth)))
2759 (header-lead allout-header-prefix
)
2762 ;; Getting value for bullet char is practically the whole job:
2765 ; Simplest situation - level 1:
2766 ((<= depth
1) (setq header-lead
"") allout-primary-bullet
)
2767 ; Simple, too: all asterisks:
2768 (allout-old-style-prefixes
2769 ;; Cheat - make body the whole thing, null out header-lead and
2771 (setq body
(make-string depth
2772 (string-to-char allout-primary-bullet
)))
2773 (setq header-lead
"")
2776 ;; (Neither level 1 nor old-style, so we're space padding.
2777 ;; Sneak it in the condition of the next case, whatever it is.)
2779 ;; Solicitation overrides numbering and other cases:
2780 ((progn (setq body
(make-string (- depth
2) ?\
))
2781 ;; The actual condition:
2783 (let* ((got (allout-solicit-alternate-bullet depth solicit
)))
2784 ;; Gotta check whether we're numbering and got a numbered bullet:
2785 (setq numbering
(and allout-numbered-bullet
2786 (not (and number-control
(not index
)))
2787 (string= got allout-numbered-bullet
)))
2788 ;; Now return what we got, regardless:
2791 ;; Numbering invoked through args:
2792 ((and allout-numbered-bullet number-control
)
2793 (if (setq numbering
(not (setq denumbering
(not index
))))
2794 allout-numbered-bullet
2795 (if (and prior-bullet
2796 (not (string= allout-numbered-bullet
2799 (allout-bullet-for-depth depth
))))
2801 ;;; Neither soliciting nor controlled numbering ;;;
2802 ;;; (may be controlled denumbering, tho) ;;;
2804 ;; Check wrt previous sibling:
2805 ((and new
; only check for new prefixes
2806 (<= depth
(allout-depth))
2807 allout-numbered-bullet
; ... & numbering enabled
2809 (let ((sibling-bullet
2811 ;; Locate correct sibling:
2812 (or (>= depth
(allout-depth))
2813 (allout-ascend-to-depth depth
))
2814 (allout-get-bullet))))
2815 (if (and sibling-bullet
2816 (string= allout-numbered-bullet sibling-bullet
))
2817 (setq numbering sibling-bullet
)))))
2819 ;; Distinctive prior bullet?
2821 (allout-distinctive-bullet prior-bullet
)
2822 ;; Either non-numbered:
2823 (or (not (and allout-numbered-bullet
2824 (string= prior-bullet allout-numbered-bullet
)))
2825 ;; or numbered, and not denumbering:
2826 (setq numbering
(not denumbering
)))
2830 ;; Else, standard bullet per depth:
2831 ((allout-bullet-for-depth depth
)))))
2837 (format "%d" (cond ((and index
(numberp index
)) index
)
2838 (new (1+ (allout-sibling-index depth
)))
2839 ((allout-sibling-index))))))
2842 ;;;_ > allout-open-topic (relative-depth &optional before use_recent_bullet)
2843 (defun allout-open-topic (relative-depth &optional before use_recent_bullet
)
2844 "Open a new topic at depth DEPTH.
2846 New topic is situated after current one, unless optional flag BEFORE
2847 is non-nil, or unless current line is complete empty (not even
2848 whitespace), in which case open is done on current line.
2850 If USE_RECENT_BULLET is true, offer to use the bullet of the prior sibling.
2854 - Creation of new topics is with respect to the visible topic
2855 containing the cursor, regardless of intervening concealed ones.
2857 - New headers are generally created after/before the body of a
2858 topic. However, they are created right at cursor location if the
2859 cursor is on a blank line, even if that breaks the current topic
2860 body. This is intentional, to provide a simple means for
2861 deliberately dividing topic bodies.
2863 - Double spacing of topic lists is preserved. Also, the first
2864 level two topic is created double-spaced (and so would be
2865 subsequent siblings, if that's left intact). Otherwise,
2866 single-spacing is used.
2868 - Creation of sibling or nested topics is with respect to the topic
2869 you're starting from, even when creating backwards. This way you
2870 can easily create a sibling in front of the current topic without
2871 having to go to its preceding sibling, and then open forward
2874 (let* ((depth (+ (allout-current-depth) relative-depth
))
2875 (opening-on-blank (if (looking-at "^\$")
2876 (not (setq before nil
))))
2877 ;; bunch o vars set while computing ref-topic
2882 (ref-topic (save-excursion
2883 (cond ((< relative-depth
0)
2884 (allout-ascend-to-depth depth
))
2885 ((>= relative-depth
1) nil
)
2886 (t (allout-back-to-current-heading)))
2887 (setq ref-depth
(allout-recent-depth))
2889 (if (> allout-recent-prefix-end
1)
2890 (allout-recent-bullet)
2892 (setq opening-numbered
2894 (and allout-numbered-bullet
2895 (or (<= relative-depth
0)
2896 (allout-descend-to-depth depth
))
2897 (if (allout-numbered-type-prefix)
2898 allout-numbered-bullet
))))
2899 (setq opening-encrypted
2901 (and allout-topic-encryption-bullet
2902 (or (<= relative-depth
0)
2903 (allout-descend-to-depth depth
))
2904 (if (allout-numbered-type-prefix)
2905 allout-numbered-bullet
))))
2910 (if (not opening-on-blank
)
2911 ; Positioning and vertical
2912 ; padding - only if not
2915 (goto-char ref-topic
)
2916 (setq dbl-space
; Determine double space action:
2917 (or (and (<= relative-depth
0) ; not descending;
2919 ;; at b-o-b or preceded by a blank line?
2920 (or (> 0 (forward-line -
1))
2921 (looking-at "^\\s-*$")
2924 ;; succeeded by a blank line?
2925 (allout-end-of-current-subtree)
2927 (and (= ref-depth
1)
2931 ;; Don't already have following
2932 ;; vertical padding:
2933 (not (allout-pre-next-preface)))))))
2935 ; Position to prior heading,
2936 ; if inserting backwards, and
2937 ; not going outwards:
2938 (if (and before
(>= relative-depth
0))
2939 (progn (allout-back-to-current-heading)
2940 (setq doing-beginning
(bobp))
2942 (allout-previous-heading)))
2943 (if (and before
(bobp))
2944 (allout-unprotected (allout-open-line-not-read-only))))
2946 (if (<= relative-depth
0)
2947 ;; Not going inwards, don't snug up:
2951 (allout-open-line-not-read-only)
2952 (allout-open-line-not-read-only)
2953 (allout-open-line-not-read-only)))
2955 (progn (end-of-line)
2956 (allout-pre-next-preface)
2957 (while (= ?
\r (following-char))
2959 (if (not (looking-at "^$"))
2961 (allout-open-line-not-read-only))))
2962 (allout-end-of-current-subtree)))
2963 ;; Going inwards - double-space if first offspring is,
2964 ;; otherwise snug up.
2965 (end-of-line) ; So we skip any concealed progeny.
2966 (allout-pre-next-preface)
2968 ;; Blank lines between current header body and next
2969 ;; header - get to last substantive (non-white-space)
2971 (re-search-backward "[^ \t\n]" nil t
))
2973 (allout-next-heading)
2974 (if (> (allout-recent-depth) ref-depth
)
2975 ;; This is an offspring.
2976 (progn (forward-line -
1)
2977 (looking-at "^\\s-*$"))))
2978 (progn (forward-line 1)
2980 (allout-open-line-not-read-only))
2983 ;;(if doing-beginning (goto-char doing-beginning))
2985 ;; We insert a newline char rather than using open-line to
2986 ;; avoid rear-stickiness inheritence of read-only property.
2987 (progn (if (and (not (> depth ref-depth
))
2990 (allout-open-line-not-read-only))
2991 (if (> depth ref-depth
)
2993 (allout-open-line-not-read-only))
2996 (allout-open-line-not-read-only))
2998 (allout-unprotected (newline 1))))))
3000 (allout-unprotected (newline 1)))
3001 (if (and (not (eobp))
3005 (insert (concat (allout-make-topic-prefix opening-numbered
3010 ;;(if doing-beginning (save-excursion (newline (if dbl-space 2 1))))
3013 (allout-rebullet-heading (and use_recent_bullet
;;; solicit
3016 nil
;;; number-control
3022 ;;;_ . open-topic contingencies
3023 ;;;_ ; base topic - one from which open was issued
3024 ;;;_ , beginning char
3025 ;;;_ , amount of space before will be used, unless opening in place
3026 ;;;_ , end char will be used, unless opening before (and it still may)
3027 ;;;_ ; absolute depth of new topic
3028 ;;;_ ! insert in place - overrides most stuff
3029 ;;;_ ; relative depth of new re base
3030 ;;;_ ; before or after base topic
3031 ;;;_ ; spacing around topic, if any, prior to new topic and at same depth
3032 ;;;_ ; buffer boundaries - special provisions for beginning and end ob
3033 ;;;_ ; level 1 topics have special provisions also - double space.
3034 ;;;_ ; location of new topic
3035 ;;;_ > allout-open-line-not-read-only ()
3036 (defun allout-open-line-not-read-only ()
3037 "Open line and remove inherited read-only text prop from new char, if any."
3039 (if (plist-get (text-properties-at (point)) 'read-only
)
3041 (remove-text-properties (point) (+ 1 (point)) '(read-only nil
)))))
3042 ;;;_ > allout-open-subtopic (arg)
3043 (defun allout-open-subtopic (arg)
3044 "Open new topic header at deeper level than the current one.
3046 Negative universal arg means to open deeper, but place the new topic
3047 prior to the current one."
3049 (allout-open-topic 1 (> 0 arg
) (< 1 arg
)))
3050 ;;;_ > allout-open-sibtopic (arg)
3051 (defun allout-open-sibtopic (arg)
3052 "Open new topic header at same level as the current one.
3054 Positive universal arg means to use the bullet of the prior sibling.
3056 Negative universal arg means to place the new topic prior to the current
3059 (allout-open-topic 0 (> 0 arg
) (not (= 1 arg
))))
3060 ;;;_ > allout-open-supertopic (arg)
3061 (defun allout-open-supertopic (arg)
3062 "Open new topic header at shallower level than the current one.
3064 Negative universal arg means to open shallower, but place the new
3065 topic prior to the current one."
3068 (allout-open-topic -
1 (> 0 arg
) (< 1 arg
)))
3070 ;;;_ - Outline Alteration
3071 ;;;_ : Topic Modification
3072 ;;;_ = allout-former-auto-filler
3073 (defvar allout-former-auto-filler nil
3074 "Name of modal fill function being wrapped by `allout-auto-fill'.")
3075 ;;;_ > allout-auto-fill ()
3076 (defun allout-auto-fill ()
3077 "`allout-mode' autofill function.
3079 Maintains outline hanging topic indentation if
3080 `allout-use-hanging-indents' is set."
3081 (let ((fill-prefix (if allout-use-hanging-indents
3082 ;; Check for topic header indentation:
3085 (if (looking-at allout-regexp
)
3086 ;; ... construct indentation to account for
3087 ;; length of topic prefix:
3088 (make-string (progn (allout-end-of-prefix)
3091 (if (or allout-former-auto-filler allout-use-hanging-indents
)
3093 ;;;_ > allout-reindent-body (old-depth new-depth &optional number)
3094 (defun allout-reindent-body (old-depth new-depth
&optional number
)
3095 "Reindent body lines which were indented at OLD-DEPTH to NEW-DEPTH.
3097 Optional arg NUMBER indicates numbering is being added, and it must
3100 Note that refill of indented paragraphs is not done."
3103 (allout-end-of-prefix)
3104 (let* ((new-margin (current-column))
3105 excess old-indent-begin old-indent-end
3107 ;; We want the column where the header-prefix text started
3108 ;; *before* the prefix was changed, so we infer it relative
3109 ;; to the new margin and the shift in depth:
3110 (old-margin (+ old-depth
(- new-margin new-depth
))))
3112 ;; Process lines up to (but excluding) next topic header:
3116 (and (re-search-forward "[\n\r]\\(\\s-*\\)"
3119 ;; Register the indent data, before we reset the
3120 ;; match data with a subsequent `looking-at':
3121 (setq old-indent-begin
(match-beginning 1)
3122 old-indent-end
(match-end 1))
3123 (not (looking-at allout-regexp
)))
3124 (if (> 0 (setq excess
(- (- old-indent-end old-indent-begin
)
3126 ;; Text starts left of old margin - don't adjust:
3128 ;; Text was hanging at or right of old left margin -
3129 ;; reindent it, preserving its existing indentation
3130 ;; beyond the old margin:
3131 (delete-region old-indent-begin old-indent-end
)
3132 (indent-to (+ new-margin excess
(current-column))))))))))
3133 ;;;_ > allout-rebullet-current-heading (arg)
3134 (defun allout-rebullet-current-heading (arg)
3135 "Solicit new bullet for current visible heading."
3137 (let ((initial-col (current-column))
3138 (on-bullet (eq (point)(allout-current-bullet-pos)))
3139 (backwards (if (< arg
0)
3140 (setq arg
(* arg -
1)))))
3142 (save-excursion (allout-back-to-current-heading)
3143 (allout-end-of-prefix)
3144 (allout-rebullet-heading t
;;; solicit
3146 nil
;;; number-control
3148 t
)) ;;; do-successors
3152 (setq initial-col nil
) ; Override positioning back to init col
3154 (allout-next-visible-heading 1)
3155 (allout-goto-prefix)
3156 (allout-next-visible-heading -
1))))
3158 (cond (on-bullet (goto-char (allout-current-bullet-pos)))
3159 (initial-col (move-to-column initial-col
)))))
3160 ;;;_ > allout-rebullet-heading (&optional solicit ...)
3161 (defun allout-rebullet-heading (&optional solicit
3167 "Adjust bullet of current topic prefix.
3169 All args are optional.
3171 If SOLICIT is non-nil, then the choice of bullet is solicited from
3172 user. If it's a character, then that character is offered as the
3173 default, otherwise the one suited to the context \(according to
3174 distinction or depth) is offered. If non-nil, then the
3175 context-specific bullet is just used.
3177 Second arg DEPTH forces the topic prefix to that depth, regardless
3178 of the topic's current depth.
3180 Third arg NUMBER-CONTROL can force the prefix to or away from
3181 numbered form. It has effect only if `allout-numbered-bullet' is
3182 non-nil and soliciting was not explicitly invoked (via first arg).
3183 Its effect, numbering or denumbering, then depends on the setting
3184 of the forth arg, INDEX.
3186 If NUMBER-CONTROL is non-nil and forth arg INDEX is nil, then the
3187 prefix of the topic is forced to be non-numbered. Null index and
3188 non-nil NUMBER-CONTROL forces denumbering. Non-nil INDEX (and
3189 non-nil NUMBER-CONTROL) forces a numbered-prefix form. If non-nil
3190 INDEX is a number, then that number is used for the numbered
3191 prefix. Non-nil and non-number means that the index for the
3192 numbered prefix will be derived by allout-make-topic-prefix.
3194 Fifth arg DO-SUCCESSORS t means re-resolve count on succeeding
3197 Cf vars `allout-stylish-prefixes', `allout-old-style-prefixes',
3198 and `allout-numbered-bullet', which all affect the behavior of
3201 (let* ((current-depth (allout-depth))
3202 (new-depth (or new-depth current-depth
))
3203 (mb allout-recent-prefix-beginning
)
3204 (me allout-recent-prefix-end
)
3205 (current-bullet (buffer-substring (- me
1) me
))
3206 (new-prefix (allout-make-topic-prefix current-bullet
3213 ;; Is new one is identical to old?
3214 (if (and (= current-depth new-depth
)
3215 (string= current-bullet
3216 (substring new-prefix
(1- (length new-prefix
)))))
3220 ;; New prefix probably different from old:
3221 ; get rid of old one:
3222 (allout-unprotected (delete-region mb me
))
3224 ; Dispense with number if
3225 ; numbered-bullet prefix:
3226 (if (and allout-numbered-bullet
3227 (string= allout-numbered-bullet current-bullet
)
3228 (looking-at "[0-9]+"))
3230 (delete-region (match-beginning 0)(match-end 0))))
3232 ; Put in new prefix:
3233 (allout-unprotected (insert new-prefix
))
3235 ;; Reindent the body if elected, margin changed, and not encrypted body:
3236 (if (and allout-reindent-bodies
3237 (not (= new-depth current-depth
))
3238 (not (allout-encrypted-topic-p)))
3239 (allout-reindent-body current-depth new-depth
))
3241 ;; Recursively rectify successive siblings of orig topic if
3242 ;; caller elected for it:
3245 (while (allout-next-sibling new-depth nil
)
3247 (cond ((numberp index
) (1+ index
))
3248 ((not number-control
) (allout-sibling-index))))
3249 (if (allout-numbered-type-prefix)
3250 (allout-rebullet-heading nil
;;; solicit
3251 new-depth
;;; new-depth
3252 number-control
;;; number-control
3254 nil
))))) ;;;(dont!)do-successors
3255 ) ; (if (and (= current-depth new-depth)...))
3256 ) ; let* ((current-depth (allout-depth))...)
3258 ;;;_ > allout-rebullet-topic (arg)
3259 (defun allout-rebullet-topic (arg)
3260 "Rebullet the visible topic containing point and all contained subtopics.
3262 Descends into invisible as well as visible topics, however.
3264 With repeat count, shift topic depth by that amount."
3266 (let ((start-col (current-column))
3270 (cond ((null arg
) (setq arg
0))
3271 ((listp arg
) (setq arg
(car arg
))))
3272 ;; Fill the user in, in case we're shifting a big topic:
3273 (if (not (zerop arg
)) (message "Shifting..."))
3274 (allout-back-to-current-heading)
3275 (if (<= (+ (allout-recent-depth) arg
) 0)
3276 (error "Attempt to shift topic below level 1"))
3277 (allout-rebullet-topic-grunt arg
)
3278 (if (not (zerop arg
)) (message "Shifting... done.")))
3279 (move-to-column (max 0 (+ start-col arg
)))))
3280 ;;;_ > allout-rebullet-topic-grunt (&optional relative-depth ...)
3281 (defun allout-rebullet-topic-grunt (&optional relative-depth
3286 "Like `allout-rebullet-topic', but on nearest containing topic
3289 See `allout-rebullet-heading' for rebulleting behavior.
3291 All arguments are optional.
3293 First arg RELATIVE-DEPTH means to shift the depth of the entire
3296 The rest of the args are for internal recursive use by the function
3297 itself. The are STARTING-DEPTH, STARTING-POINT, and INDEX."
3299 (let* ((relative-depth (or relative-depth
0))
3300 (new-depth (allout-depth))
3301 (starting-depth (or starting-depth new-depth
))
3302 (on-starting-call (null starting-point
))
3304 ;; Leave index null on starting call, so rebullet-heading
3305 ;; calculates it at what might be new depth:
3306 (and (or (zerop relative-depth
)
3307 (not on-starting-call
))
3308 (allout-sibling-index))))
3309 (moving-outwards (< 0 relative-depth
))
3310 (starting-point (or starting-point
(point))))
3312 ;; Sanity check for excessive promotion done only on starting call:
3313 (and on-starting-call
3315 (> 0 (+ starting-depth relative-depth
))
3316 (error "Attempt to shift topic out beyond level 1")) ;;; ====>
3318 (cond ((= starting-depth new-depth
)
3319 ;; We're at depth to work on this one:
3320 (allout-rebullet-heading nil
;;; solicit
3321 (+ starting-depth
;;; starting-depth
3325 ;; Every contained topic will get hit,
3326 ;; and we have to get to outside ones
3328 nil
) ;;; do-successors
3329 ;; ... and work on subsequent ones which are at greater depth:
3331 (allout-next-heading)
3332 (while (and (not (eobp))
3333 (< starting-depth
(allout-recent-depth)))
3334 (setq index
(1+ index
))
3335 (allout-rebullet-topic-grunt relative-depth
;;; relative-depth
3336 (1+ starting-depth
);;;starting-depth
3337 starting-point
;;; starting-point
3340 ((< starting-depth new-depth
)
3341 ;; Rare case - subtopic more than one level deeper than parent.
3342 ;; Treat this one at an even deeper level:
3343 (allout-rebullet-topic-grunt relative-depth
;;; relative-depth
3344 new-depth
;;; starting-depth
3345 starting-point
;;; starting-point
3348 (if on-starting-call
3350 ;; Rectify numbering of former siblings of the adjusted topic,
3351 ;; if topic has changed depth
3352 (if (or do-successors
3353 (and (not (zerop relative-depth
))
3354 (or (= (allout-recent-depth) starting-depth
)
3355 (= (allout-recent-depth) (+ starting-depth
3357 (allout-rebullet-heading nil nil nil nil t
))
3358 ;; Now rectify numbering of new siblings of the adjusted topic,
3359 ;; if depth has been changed:
3360 (progn (goto-char starting-point
)
3361 (if (not (zerop relative-depth
))
3362 (allout-rebullet-heading nil nil nil nil t
)))))
3365 ;;;_ > allout-renumber-to-depth (&optional depth)
3366 (defun allout-renumber-to-depth (&optional depth
)
3367 "Renumber siblings at current depth.
3369 Affects superior topics if optional arg DEPTH is less than current depth.
3371 Returns final depth."
3373 ;; Proceed by level, processing subsequent siblings on each,
3374 ;; ascending until we get shallower than the start depth:
3376 (let ((ascender (allout-depth))
3378 (while (and (not (eobp))
3380 (>= (allout-recent-depth) depth
)
3381 (>= ascender depth
))
3382 ; Skip over all topics at
3383 ; lesser depths, which can not
3384 ; have been disturbed:
3385 (while (and (not (setq was-eobp
(eobp)))
3386 (> (allout-recent-depth) ascender
))
3387 (allout-next-heading))
3388 ; Prime ascender for ascension:
3389 (setq ascender
(1- (allout-recent-depth)))
3390 (if (>= (allout-recent-depth) depth
)
3391 (allout-rebullet-heading nil
;;; solicit
3393 nil
;;; number-control
3395 t
)) ;;; do-successors
3396 (if was-eobp
(goto-char (point-max)))))
3397 (allout-recent-depth))
3398 ;;;_ > allout-number-siblings (&optional denumber)
3399 (defun allout-number-siblings (&optional denumber
)
3400 "Assign numbered topic prefix to this topic and its siblings.
3402 With universal argument, denumber - assign default bullet to this
3403 topic and its siblings.
3405 With repeated universal argument (`^U^U'), solicit bullet for each
3406 rebulleting each topic at this level."
3411 (allout-back-to-current-heading)
3412 (allout-beginning-of-level)
3413 (let ((depth (allout-recent-depth))
3414 (index (if (not denumber
) 1))
3415 (use-bullet (equal '(16) denumber
))
3418 (allout-rebullet-heading use-bullet
;;; solicit
3420 t
;;; number-control
3422 nil
) ;;; do-successors
3423 (if index
(setq index
(1+ index
)))
3424 (setq more
(allout-next-sibling depth nil
))))))
3425 ;;;_ > allout-shift-in (arg)
3426 (defun allout-shift-in (arg)
3427 "Increase depth of current heading and any topics collapsed within it.
3429 We disallow shifts that would result in the topic having a depth more than
3430 one level greater than the immediately previous topic, to avoid containment
3431 discontinuity. The first topic in the file can be adjusted to any positive
3436 (allout-back-to-current-heading)
3438 (let* ((current-depth (allout-recent-depth))
3439 (start-point (point))
3440 (predecessor-depth (progn
3442 (allout-goto-prefix)
3443 (if (< (point) start-point
)
3444 (allout-recent-depth)
3446 (if (and (> predecessor-depth
0)
3447 (> (+ current-depth arg
)
3448 (1+ predecessor-depth
)))
3449 (error (concat "May not shift deeper than offspring depth"
3450 " of previous topic")))))))
3451 (allout-rebullet-topic arg
))
3452 ;;;_ > allout-shift-out (arg)
3453 (defun allout-shift-out (arg)
3454 "Decrease depth of current heading and any topics collapsed within it.
3456 We disallow shifts that would result in the topic having a depth more than
3457 one level greater than the immediately previous topic, to avoid containment
3458 discontinuity. The first topic in the file can be adjusted to any positive
3462 (allout-shift-in (* arg -
1)))
3463 (allout-rebullet-topic (* arg -
1)))
3464 ;;;_ : Surgery (kill-ring) functions with special provisions for outlines:
3465 ;;;_ > allout-kill-line (&optional arg)
3466 (defun allout-kill-line (&optional arg
)
3467 "Kill line, adjusting subsequent lines suitably for outline mode."
3471 (let ((start-point (point))
3472 (leading-kill-ring-entry (car kill-ring
))
3477 (if (not (and (allout-mode-p) ; active outline mode,
3478 allout-numbered-bullet
; numbers may need adjustment,
3479 (bolp) ; may be clipping topic head,
3480 (looking-at allout-regexp
))) ; are clipping topic head.
3481 ;; Above conditions do not obtain - just do a regular kill:
3483 ;; Ah, have to watch out for adjustments:
3484 (let* ((depth (allout-depth))
3485 (start-point (point))
3487 ; Do the kill, presenting option
3488 ; for read-only text:
3490 ; Provide some feedback:
3493 ; Start with the topic
3494 ; following killed line:
3495 (if (not (looking-at allout-regexp
))
3496 (allout-next-heading))
3497 (allout-renumber-to-depth depth
))))
3498 ;; condition case handler:
3500 (goto-char start-point
)
3501 (setq binding
(where-is-internal 'allout-kill-topic nil t
))
3502 (cond ((not binding
) (setq binding
""))
3504 (setq binding
(mapconcat 'key-description
(list binding
) ", ")))
3505 (t (setq binding
(format "%s" binding
))))
3506 ;; ensure prior kill-ring leader is properly restored:
3507 (if (eq leading-kill-ring-entry
(cadr kill-ring
))
3508 ;; Aborted kill got pushed on front - ditch it:
3510 ;; Aborted kill got appended to prior - resurrect prior:
3511 (setcar kill-ring leading-kill-ring-entry
))
3512 ;; make last-command skip this failed command, so kill-appending
3513 ;; conditions track:
3514 (setq this-command last-command
)
3515 (error (concat "read-only text hit - use %s allout-kill-topic to"
3516 " discard collapsed stuff")
3520 ;;;_ > allout-kill-topic ()
3521 (defun allout-kill-topic ()
3522 "Kill topic together with subtopics.
3524 Leaves primary topic's trailing vertical whitespace, if any."
3526 ;; Some finagling is done to make complex topic kills appear faster
3527 ;; than they actually are. A redisplay is performed immediately
3528 ;; after the region is disposed of, though the renumbering process
3529 ;; has yet to be performed. This means that there may appear to be
3530 ;; a lag *after* the kill has been performed.
3533 (let* ((beg (prog1 (allout-back-to-current-heading)(beginning-of-line)))
3534 (depth (allout-recent-depth)))
3535 (allout-end-of-current-subtree)
3537 (if (or (not (looking-at "^$"))
3538 ;; A blank line - cut it with this topic *unless* this
3539 ;; is the last topic at this level, in which case
3540 ;; we'll leave the blank line as part of the
3541 ;; containing topic:
3543 (and (allout-next-heading)
3544 (>= (allout-recent-depth) depth
))))
3547 (allout-unprotected (kill-region beg
(point)))
3550 (allout-renumber-to-depth depth
))))
3551 ;;;_ > allout-yank-processing ()
3552 (defun allout-yank-processing (&optional arg
)
3554 "Incidental outline-specific business to be done just after text yanks.
3556 Does depth adjustment of yanked topics, when:
3558 1 the stuff being yanked starts with a valid outline header prefix, and
3559 2 it is being yanked at the end of a line which consists of only a valid
3562 Also, adjusts numbering of subsequent siblings when appropriate.
3564 Depth adjustment alters the depth of all the topics being yanked
3565 the amount it takes to make the first topic have the depth of the
3566 header into which it's being yanked.
3568 The point is left in front of yanked, adjusted topics, rather than
3569 at the end (and vice-versa with the mark). Non-adjusted yanks,
3570 however, are left exactly like normal, non-allout-specific yanks."
3573 ; Get to beginning, leaving
3574 ; region around subject:
3575 (if (< (my-mark-marker t
) (point))
3576 (exchange-point-and-mark))
3577 (let* ((subj-beg (point))
3578 (subj-end (my-mark-marker t
))
3579 ;; 'resituate' if yanking an entire topic into topic header:
3580 (resituate (and (allout-e-o-prefix-p)
3581 (looking-at (concat "\\(" allout-regexp
"\\)"))
3582 (allout-prefix-data (match-beginning 1)
3584 ;; `rectify-numbering' if resituating (where several topics may
3585 ;; be resituating) or yanking a topic into a topic slot (bol):
3586 (rectify-numbering (or resituate
3587 (and (bolp) (looking-at allout-regexp
)))))
3589 ; The yanked stuff is a topic:
3590 (let* ((prefix-len (- (match-end 1) subj-beg
))
3591 (subj-depth (allout-recent-depth))
3592 (prefix-bullet (allout-recent-bullet))
3594 ;; Nil if adjustment unnecessary, otherwise depth to which
3595 ;; adjustment should be made:
3597 (and (goto-char subj-end
)
3599 (goto-char subj-beg
)
3600 (and (looking-at allout-regexp
)
3603 (not (= (point) subj-beg
)))
3604 (looking-at allout-regexp
)
3605 (allout-prefix-data (match-beginning 0)
3607 (allout-recent-depth))))
3610 (setq rectify-numbering allout-numbered-bullet
)
3612 ; Do the adjustment:
3614 (message "... yanking") (sit-for 0)
3616 (narrow-to-region subj-beg subj-end
)
3617 ; Trim off excessive blank
3618 ; line at end, if any:
3619 (goto-char (point-max))
3620 (if (looking-at "^$")
3621 (allout-unprotected (delete-char -
1)))
3622 ; Work backwards, with each
3624 ; successively excluding the
3625 ; last processed topic from
3626 ; the narrow region:
3628 (allout-back-to-current-heading)
3629 ; go as high as we can in each bunch:
3630 (while (allout-ascend-to-depth (1- (allout-depth))))
3632 (allout-rebullet-topic-grunt (- adjust-to-depth
3635 (if (setq more
(not (bobp)))
3638 (narrow-to-region subj-beg
(point))))))
3640 ;; Preserve new bullet if it's a distinctive one, otherwise
3642 (if (string-match (regexp-quote prefix-bullet
)
3643 allout-distinctive-bullets-string
)
3644 ; Delete from bullet of old to
3645 ; before bullet of new:
3648 (delete-region (point) subj-beg
)
3649 (set-marker (my-mark-marker t
) subj-end
)
3650 (goto-char subj-beg
)
3651 (allout-end-of-prefix))
3652 ; Delete base subj prefix,
3654 (delete-region (point) (+ (point)
3656 (- adjust-to-depth subj-depth
)))
3657 ; and delete residual subj
3658 ; prefix digits and space:
3659 (while (looking-at "[0-9]") (delete-char 1))
3660 (if (looking-at " ") (delete-char 1))))
3661 (exchange-point-and-mark))))
3662 (if rectify-numbering
3665 ; Give some preliminary feedback:
3666 (message "... reconciling numbers") (sit-for 0)
3667 ; ... and renumber, in case necessary:
3668 (goto-char subj-beg
)
3669 (if (allout-goto-prefix)
3670 (allout-rebullet-heading nil
;;; solicit
3671 (allout-depth) ;;; depth
3672 nil
;;; number-control
3677 (exchange-point-and-mark))))
3678 ;;;_ > allout-yank (&optional arg)
3679 (defun allout-yank (&optional arg
)
3680 "`allout-mode' yank, with depth and numbering adjustment of yanked topics.
3682 Non-topic yanks work no differently than normal yanks.
3684 If a topic is being yanked into a bare topic prefix, the depth of the
3685 yanked topic is adjusted to the depth of the topic prefix.
3687 1 we're yanking in an `allout-mode' buffer
3688 2 the stuff being yanked starts with a valid outline header prefix, and
3689 3 it is being yanked at the end of a line which consists of only a valid
3692 If these conditions hold then the depth of the yanked topics are all
3693 adjusted the amount it takes to make the first one at the depth of the
3694 header into which it's being yanked.
3696 The point is left in front of yanked, adjusted topics, rather than
3697 at the end (and vice-versa with the mark). Non-adjusted yanks,
3698 however, (ones that don't qualify for adjustment) are handled
3699 exactly like normal yanks.
3701 Numbering of yanked topics, and the successive siblings at the depth
3702 into which they're being yanked, is adjusted.
3704 `allout-yank-pop' works with `allout-yank' just like normal `yank-pop'
3705 works with normal `yank' in non-outline buffers."
3708 (setq this-command
'yank
)
3711 (allout-yank-processing)))
3712 ;;;_ > allout-yank-pop (&optional arg)
3713 (defun allout-yank-pop (&optional arg
)
3714 "Yank-pop like `allout-yank' when popping to bare outline prefixes.
3716 Adapts level of popped topics to level of fresh prefix.
3718 Note - prefix changes to distinctive bullets will stick, if followed
3719 by pops to non-distinctive yanks. Bug..."
3722 (setq this-command
'yank
)
3725 (allout-yank-processing)))
3727 ;;;_ - Specialty bullet functions
3728 ;;;_ : File Cross references
3729 ;;;_ > allout-resolve-xref ()
3730 (defun allout-resolve-xref ()
3731 "Pop to file associated with current heading, if it has an xref bullet.
3733 \(Works according to setting of `allout-file-xref-bullet')."
3735 (if (not allout-file-xref-bullet
)
3737 "Outline cross references disabled - no `allout-file-xref-bullet'")
3738 (if (not (string= (allout-current-bullet) allout-file-xref-bullet
))
3739 (error "Current heading lacks cross-reference bullet `%s'"
3740 allout-file-xref-bullet
)
3743 (let* ((text-start allout-recent-prefix-end
)
3744 (heading-end (progn (end-of-line) (point))))
3745 (goto-char text-start
)
3747 (if (re-search-forward "\\s-\\(\\S-*\\)" heading-end t
)
3748 (buffer-substring (match-beginning 1) (match-end 1))))))
3750 (if (not (= (aref file-name
0) ?
:))
3751 (expand-file-name file-name
)
3752 ; A registry-files ref, strip the `:'
3753 ; and try to follow it:
3754 (let ((reg-ref (reference-registered-file
3755 (substring file-name
1) nil t
)))
3756 (if reg-ref
(car (cdr reg-ref
))))))
3757 (if (or (file-exists-p file-name
)
3758 (if (file-writable-p file-name
)
3759 (y-or-n-p (format "%s not there, create one? "
3761 (error "%s not found and can't be created" file-name
)))
3762 (condition-case failure
3763 (find-file-other-window file-name
)
3765 (error "%s not found" file-name
))
3771 ;;;_ #6 Exposure Control
3774 ;;;_ > allout-flag-region (from to flag)
3775 (defun allout-flag-region (from to flag
)
3776 "Hide or show lines from FROM to TO, via Emacs selective-display FLAG char.
3777 Ie, text following flag C-m \(carriage-return) is hidden until the
3778 next C-j (newline) char.
3780 Returns the endpoint of the region."
3781 ;; "OFR-" prefixes to avoid collisions with vars in code calling the macro.
3782 ;; ie, elisp macro vars are not 'hygenic', so distinct names are necessary.
3783 (let ((was-inhibit-r-o inhibit-read-only
)
3784 (was-undo-list buffer-undo-list
)
3785 (was-modified (buffer-modified-p))
3789 (setq inhibit-read-only t
)
3790 (setq buffer-undo-list t
)
3792 (setq trans from from to to trans
))
3793 (subst-char-in-region from to
3794 (if (= flag ?
\n) ?
\r ?
\n)
3796 ;; adjust character read-protection on all the affected lines.
3797 ;; we handle the region line-by-line.
3800 (setq to
(min (+ 2 (point)) (point-max)))
3803 (while (< (point) to
)
3804 ;; handle from start of exposed to beginning of hidden, or eol:
3805 (remove-text-properties (point)
3806 (progn (if (re-search-forward "[\r\n]"
3811 ;; handle from start of hidden, if any, to eol:
3812 (if (and (not (eobp)) (= (char-after (point)) ?
\r))
3813 (put-text-property (point) (progn (end-of-line) (point))
3815 ;; Handle the end-of-line to beginning of next line:
3817 (progn (forward-char 1)
3818 (remove-text-properties (1- (point)) (point)
3819 '(read-only nil
)))))
3821 (if (not was-modified
)
3822 (set-buffer-modified-p nil
))
3823 (setq inhibit-read-only was-inhibit-r-o
)
3824 (setq buffer-undo-list was-undo-list
)
3828 ;;;_ > allout-flag-current-subtree (flag)
3829 (defun allout-flag-current-subtree (flag)
3830 "Hide or show subtree of currently-visible topic.
3832 See `allout-flag-region' for more details."
3835 (allout-back-to-current-heading)
3836 (let ((from (point))
3837 (to (progn (allout-end-of-current-subtree) (1- (point)))))
3838 (allout-flag-region from to flag
))))
3840 ;;;_ - Topic-specific
3841 ;;;_ > allout-show-entry ()
3842 (defun allout-show-entry ()
3843 "Like `allout-show-current-entry', reveals entries nested in hidden topics.
3845 This is a way to give restricted peek at a concealed locality without the
3846 expense of exposing its context, but can leave the outline with aberrant
3847 exposure. `allout-hide-current-entry-completely' or `allout-show-offshoot'
3848 should be used after the peek to rectify the exposure."
3854 (allout-goto-prefix)
3855 (setq beg
(if (= (preceding-char) ?
\r) (1- (point)) (point)))
3856 (re-search-forward "[\n\r]" nil t
)
3857 (setq end
(1- (if (< at
(point))
3858 ;; We're on topic head line - show only it:
3860 ;; or we're in body - include it:
3861 (max beg
(or (allout-pre-next-preface) (point))))))
3862 (allout-flag-region beg end ?
\n)
3864 ;;;_ > allout-show-children (&optional level strict)
3865 (defun allout-show-children (&optional level strict
)
3867 "If point is visible, show all direct subheadings of this heading.
3869 Otherwise, do `allout-show-to-offshoot', and then show subheadings.
3871 Optional LEVEL specifies how many levels below the current level
3872 should be shown, or all levels if t. Default is 1.
3874 Optional STRICT means don't resort to -show-to-offshoot, no matter
3875 what. This is basically so -show-to-offshoot, which is called by
3876 this function, can employ the pure offspring-revealing capabilities of
3879 Returns point at end of subtree that was opened, if any. (May get a
3880 point of non-opened subtree?)"
3884 (if (and (not strict
)
3887 (progn (allout-show-to-offshoot) ; Point's concealed, open to
3889 ;; Then recurse, but with "strict" set so we don't
3890 ;; infinite regress:
3891 (setq max-pos
(allout-show-children level t
)))
3895 (let* ((start-pt (point))
3896 (chart (allout-chart-subtree (or level
1)))
3897 (to-reveal (allout-chart-to-reveal chart
(or level
1))))
3898 (goto-char start-pt
)
3899 (if (and strict
(= (preceding-char) ?
\r))
3900 ;; Concealed root would already have been taken care of,
3901 ;; unless strict was set.
3903 (allout-flag-region (point) (allout-snug-back) ?
\n)
3904 (if allout-show-bodies
3905 (progn (goto-char (car to-reveal
))
3906 (allout-show-current-entry)))))
3908 (goto-char (car to-reveal
))
3909 (allout-flag-region (point) (allout-snug-back) ?
\n)
3910 (if allout-show-bodies
3911 (progn (goto-char (car to-reveal
))
3912 (allout-show-current-entry)))
3913 (setq to-reveal
(cdr to-reveal
)))))))))
3914 ;;;_ > allout-hide-point-reconcile ()
3915 (defun allout-hide-reconcile ()
3916 "Like `allout-hide-current-entry'; hides completely if within hidden region.
3918 Specifically intended for aberrant exposure states, like entries that were
3919 exposed by `allout-show-entry' but are within otherwise concealed regions."
3922 (allout-goto-prefix)
3923 (allout-flag-region (if (not (bobp)) (1- (point)) (point))
3924 (progn (allout-pre-next-preface)
3925 (if (= ?
\r (following-char))
3929 ;;;_ > allout-show-to-offshoot ()
3930 (defun allout-show-to-offshoot ()
3931 "Like `allout-show-entry', but reveals all concealed ancestors, as well.
3933 As with `allout-hide-current-entry-completely', useful for rectifying
3934 aberrant exposure states produced by `allout-show-entry'."
3938 (let ((orig-pt (point))
3939 (orig-pref (allout-goto-prefix))
3942 (while (or bag-it
(= (preceding-char) ?
\r))
3944 (if (= last-at
(setq last-at
(point)))
3945 ;; Oops, we're not making any progress! Show the current
3946 ;; topic completely, and bag this try.
3947 (progn (beginning-of-line)
3948 (allout-show-current-subtree)
3953 "allout-show-to-offshoot: "
3954 "Aberrant nesting encountered.")))
3955 (allout-show-children)
3956 (goto-char orig-pref
))
3957 (goto-char orig-pt
)))
3958 (if (allout-hidden-p)
3959 (allout-show-entry)))
3960 ;;;_ > allout-hide-current-entry ()
3961 (defun allout-hide-current-entry ()
3962 "Hide the body directly following this heading."
3964 (allout-back-to-current-heading)
3966 (allout-flag-region (point)
3967 (progn (allout-end-of-entry) (point))
3969 ;;;_ > allout-show-current-entry (&optional arg)
3970 (defun allout-show-current-entry (&optional arg
)
3972 "Show body following current heading, or hide the entry if repeat count."
3976 (allout-hide-current-entry)
3978 (allout-flag-region (point)
3979 (progn (allout-end-of-entry) (point))
3982 ;;;_ > allout-hide-current-entry-completely ()
3983 ; ... allout-hide-current-entry-completely also for isearch dynamic exposure:
3984 (defun allout-hide-current-entry-completely ()
3985 "Like `allout-hide-current-entry', but conceal topic completely.
3987 Specifically intended for aberrant exposure states, like entries that were
3988 exposed by `allout-show-entry' but are within otherwise concealed regions."
3991 (allout-goto-prefix)
3992 (allout-flag-region (if (not (bobp)) (1- (point)) (point))
3993 (progn (allout-pre-next-preface)
3994 (if (= ?
\r (following-char))
3998 ;;;_ > allout-show-current-subtree (&optional arg)
3999 (defun allout-show-current-subtree (&optional arg
)
4000 "Show everything within the current topic. With a repeat-count,
4001 expose this topic and its siblings."
4004 (if (<= (allout-current-depth) 0)
4005 ;; Outside any topics - try to get to the first:
4006 (if (not (allout-next-heading))
4008 ;; got to first, outermost topic - set to expose it and siblings:
4009 (message "Above outermost topic - exposing all.")
4010 (allout-flag-region (point-min)(point-max) ?
\n))
4012 (allout-flag-current-subtree ?
\n)
4013 (allout-beginning-of-level)
4014 (allout-expose-topic '(* :))))))
4015 ;;;_ > allout-hide-current-subtree (&optional just-close)
4016 (defun allout-hide-current-subtree (&optional just-close
)
4017 "Close the current topic, or containing topic if this one is already closed.
4019 If this topic is closed and it's a top level topic, close this topic
4022 If optional arg JUST-CLOSE is non-nil, do not treat the parent or
4023 siblings, even if the target topic is already closed."
4026 (let ((from (point))
4027 (orig-eol (progn (end-of-line)
4028 (if (not (allout-goto-prefix))
4029 (error "No topics found")
4030 (end-of-line)(point)))))
4031 (allout-flag-current-subtree ?
\r)
4033 (if (and (= orig-eol
(progn (goto-char orig-eol
)
4037 ;; Structure didn't change - try hiding current level:
4039 (if (allout-up-current-level 1 t
)
4043 "Top-level topic already closed - closing siblings..."))
4045 (allout-expose-topic '(0 :))
4046 (message (concat msg
" Done.")))
4048 (/= (allout-recent-depth) 0))
4049 (allout-hide-current-subtree))
4051 ;;;_ > allout-show-current-branches ()
4052 (defun allout-show-current-branches ()
4053 "Show all subheadings of this heading, but not their bodies."
4056 (allout-show-children t
))
4057 ;;;_ > allout-hide-current-leaves ()
4058 (defun allout-hide-current-leaves ()
4059 "Hide the bodies of the current topic and all its offspring."
4061 (allout-back-to-current-heading)
4062 (allout-hide-region-body (point) (progn (allout-end-of-current-subtree)
4065 ;;;_ - Region and beyond
4066 ;;;_ > allout-show-all ()
4067 (defun allout-show-all ()
4068 "Show all of the text in the buffer."
4070 (message "Exposing entire buffer...")
4071 (allout-flag-region (point-min) (point-max) ?
\n)
4072 (message "Exposing entire buffer... Done."))
4073 ;;;_ > allout-hide-bodies ()
4074 (defun allout-hide-bodies ()
4075 "Hide all of buffer except headings."
4077 (allout-hide-region-body (point-min) (point-max)))
4078 ;;;_ > allout-hide-region-body (start end)
4079 (defun allout-hide-region-body (start end
)
4080 "Hide all body lines in the region, but not headings."
4083 (narrow-to-region start end
)
4084 (goto-char (point-min))
4086 (allout-flag-region (point)
4087 (progn (allout-pre-next-preface) (point)) ?
\r)
4090 (if (looking-at "[\n\r][\n\r]")
4093 ;;;_ > allout-expose-topic (spec)
4094 (defun allout-expose-topic (spec)
4095 "Apply exposure specs to successive outline topic items.
4097 Use the more convenient frontend, `allout-new-exposure', if you don't
4098 need evaluation of the arguments, or even better, the `allout-layout'
4099 variable-keyed mode-activation/auto-exposure feature of allout outline
4100 mode. See the respective documentation strings for more details.
4102 Cursor is left at start position.
4104 SPEC is either a number or a list.
4106 Successive specs on a list are applied to successive sibling topics.
4108 A simple spec \(either a number, one of a few symbols, or the null
4109 list) dictates the exposure for the corresponding topic.
4111 Non-null lists recursively designate exposure specs for respective
4112 subtopics of the current topic.
4114 The `:' repeat spec is used to specify exposure for any number of
4115 successive siblings, up to the trailing ones for which there are
4116 explicit specs following the `:'.
4118 Simple (numeric and null-list) specs are interpreted as follows:
4120 Numbers indicate the relative depth to open the corresponding topic.
4121 - negative numbers force the topic to be closed before opening to the
4122 absolute value of the number, so all siblings are open only to
4124 - positive numbers open to the relative depth indicated by the
4125 number, but do not force already opened subtopics to be closed.
4126 - 0 means to close topic - hide all offspring.
4128 apply prior element to all siblings at current level, *up to*
4129 those siblings that would be covered by specs following the `:'
4130 on the list. Ie, apply to all topics at level but the last
4131 ones. \(Only first of multiple colons at same level is
4132 respected - subsequent ones are discarded.)
4133 * - completely opens the topic, including bodies.
4134 + - shows all the sub headers, but not the bodies
4135 - - exposes the body of the corresponding topic.
4138 \(allout-expose-topic '(-1 : 0))
4139 Close this and all following topics at current level, exposing
4140 only their immediate children, but close down the last topic
4141 at this current level completely.
4142 \(allout-expose-topic '(-1 () : 1 0))
4143 Close current topic so only the immediate subtopics are shown;
4144 show the children in the second to last topic, and completely
4146 \(allout-expose-topic '(-2 : -1 *))
4147 Expose children and grandchildren of all topics at current
4148 level except the last two; expose children of the second to
4149 last and completely open the last one."
4151 (interactive "xExposure spec: ")
4152 (if (not (listp spec
))
4154 (let ((depth (allout-depth))
4161 (setq prev-elem curr-elem
4162 curr-elem
(car spec
)
4164 (cond ; Do current element:
4165 ((null curr-elem
) nil
)
4166 ((symbolp curr-elem
)
4167 (cond ((eq curr-elem
'*) (allout-show-current-subtree)
4168 (if (> allout-recent-end-of-subtree max-pos
)
4169 (setq max-pos allout-recent-end-of-subtree
)))
4170 ((eq curr-elem
'+) (allout-show-current-branches)
4171 (if (> allout-recent-end-of-subtree max-pos
)
4172 (setq max-pos allout-recent-end-of-subtree
)))
4173 ((eq curr-elem
'-
) (allout-show-current-entry))
4176 ;; Expand the `repeat' spec to an explicit version,
4177 ;; w.r.t. remaining siblings:
4178 (let ((residue ; = # of sibs not covered by remaining spec
4179 ;; Dang - could be nice to make use of the chart, sigh:
4180 (- (length (allout-chart-siblings))
4183 ;; Some residue - cover it with prev-elem:
4184 (setq spec
(append (make-list residue prev-elem
)
4186 ((numberp curr-elem
)
4187 (if (and (>= 0 curr-elem
) (allout-visible-p))
4188 (save-excursion (allout-hide-current-subtree t
)
4191 (if (> allout-recent-end-of-subtree max-pos
)
4193 allout-recent-end-of-subtree
)))))
4194 (if (> (abs curr-elem
) 0)
4195 (progn (allout-show-children (abs curr-elem
))
4196 (if (> allout-recent-end-of-subtree max-pos
)
4197 (setq max-pos allout-recent-end-of-subtree
)))))
4199 (if (allout-descend-to-depth (1+ depth
))
4200 (let ((got (allout-expose-topic curr-elem
)))
4201 (if (and got
(> got max-pos
)) (setq max-pos got
))))))
4202 (cond (stay (setq stay nil
))
4203 ((listp (car spec
)) nil
)
4204 ((> max-pos
(point))
4205 ;; Capitalize on max-pos state to get us nearer next sibling:
4206 (progn (goto-char (min (point-max) max-pos
))
4207 (allout-next-heading)))
4208 ((allout-next-sibling depth
))))
4210 ;;;_ > allout-old-expose-topic (spec &rest followers)
4211 (defun allout-old-expose-topic (spec &rest followers
)
4213 "Deprecated. Use `allout-expose-topic' \(with different schema
4216 Dictate wholesale exposure scheme for current topic, according to SPEC.
4218 SPEC is either a number or a list. Optional successive args
4219 dictate exposure for subsequent siblings of current topic.
4221 A simple spec (either a number, a special symbol, or the null list)
4222 dictates the overall exposure for a topic. Non null lists are
4223 composite specs whose first element dictates the overall exposure for
4224 a topic, with the subsequent elements in the list interpreted as specs
4225 that dictate the exposure for the successive offspring of the topic.
4227 Simple (numeric and null-list) specs are interpreted as follows:
4229 - Numbers indicate the relative depth to open the corresponding topic:
4230 - negative numbers force the topic to be close before opening to the
4231 absolute value of the number.
4232 - positive numbers just open to the relative depth indicated by the number.
4234 - `*' completely opens the topic, including bodies.
4235 - `+' shows all the sub headers, but not the bodies
4236 - `-' exposes the body and immediate offspring of the corresponding topic.
4238 If the spec is a list, the first element must be a number, which
4239 dictates the exposure depth of the topic as a whole. Subsequent
4240 elements of the list are nested SPECs, dictating the specific exposure
4241 for the corresponding offspring of the topic.
4243 Optional FOLLOWERS arguments dictate exposure for succeeding siblings."
4245 (interactive "xExposure spec: ")
4246 (let ((depth (allout-current-depth))
4249 (cond ((null spec
) nil
)
4251 (if (eq spec
'*) (allout-show-current-subtree))
4252 (if (eq spec
'+) (allout-show-current-branches))
4253 (if (eq spec
'-
) (allout-show-current-entry)))
4256 (save-excursion (allout-hide-current-subtree t
)
4258 (if (or (not max-pos
)
4259 (> (point) max-pos
))
4260 (setq max-pos
(point)))
4262 (setq spec
(* -
1 spec
)))))
4264 (allout-show-children spec
)))
4266 ;(let ((got (allout-old-expose-topic (car spec))))
4267 ; (if (and got (or (not max-pos) (> got max-pos)))
4268 ; (setq max-pos got)))
4269 (let ((new-depth (+ (allout-current-depth) 1))
4271 (setq max-pos
(allout-old-expose-topic (car spec
)))
4272 (setq spec
(cdr spec
))
4274 (allout-descend-to-depth new-depth
)
4275 (not (allout-hidden-p)))
4276 (progn (setq got
(apply 'allout-old-expose-topic spec
))
4277 (if (and got
(or (not max-pos
) (> got max-pos
)))
4278 (setq max-pos got
)))))))
4279 (while (and followers
4280 (progn (if (and max-pos
(< (point) max-pos
))
4281 (progn (goto-char max-pos
)
4282 (setq max-pos nil
)))
4284 (allout-next-sibling depth
)))
4285 (allout-old-expose-topic (car followers
))
4286 (setq followers
(cdr followers
)))
4288 ;;;_ > allout-new-exposure '()
4289 (defmacro allout-new-exposure
(&rest spec
)
4290 "Literal frontend for `allout-expose-topic', doesn't evaluate arguments.
4291 Some arguments that would need to be quoted in `allout-expose-topic'
4292 need not be quoted in `allout-new-exposure'.
4294 Cursor is left at start position.
4296 Use this instead of obsolete `allout-exposure'.
4299 \(allout-new-exposure (-1 () () () 1) 0)
4300 Close current topic at current level so only the immediate
4301 subtopics are shown, except also show the children of the
4302 third subtopic; and close the next topic at the current level.
4303 \(allout-new-exposure : -1 0)
4304 Close all topics at current level to expose only their
4305 immediate children, except for the last topic at the current
4306 level, in which even its immediate children are hidden.
4307 \(allout-new-exposure -2 : -1 *)
4308 Expose children and grandchildren of first topic at current
4309 level, and expose children of subsequent topics at current
4310 level *except* for the last, which should be opened completely."
4311 (list 'save-excursion
4312 '(if (not (or (allout-goto-prefix)
4313 (allout-next-heading)))
4314 (error "allout-new-exposure: Can't find any outline topics"))
4315 (list 'allout-expose-topic
(list 'quote spec
))))
4317 ;;;_ #7 Systematic outline presentation - copying, printing, flattening
4319 ;;;_ - Mapping and processing of topics
4320 ;;;_ ( See also Subtree Charting, in Navigation code.)
4321 ;;;_ > allout-stringify-flat-index (flat-index)
4322 (defun allout-stringify-flat-index (flat-index &optional context
)
4323 "Convert list representing section/subsection/... to document string.
4325 Optional arg CONTEXT indicates interior levels to include."
4329 (context-depth (or (and context
2) 1)))
4330 ;; Take care of the explicit context:
4331 (while (> context-depth
0)
4332 (setq numstr
(int-to-string (car flat-index
))
4333 flat-index
(cdr flat-index
)
4334 result
(if flat-index
4335 (cons delim
(cons numstr result
))
4336 (cons numstr result
))
4337 context-depth
(if flat-index
(1- context-depth
) 0)))
4339 ;; Take care of the indentation:
4346 (1+ (truncate (if (zerop (car flat-index
))
4348 (log10 (car flat-index
)))))
4351 (setq flat-index
(cdr flat-index
)))
4352 ;; Dispose of single extra delim:
4353 (setq result
(cdr result
))))
4354 (apply 'concat result
)))
4355 ;;;_ > allout-stringify-flat-index-plain (flat-index)
4356 (defun allout-stringify-flat-index-plain (flat-index)
4357 "Convert list representing section/subsection/... to document string."
4361 (setq result
(cons (int-to-string (car flat-index
))
4363 (cons delim result
))))
4364 (setq flat-index
(cdr flat-index
)))
4365 (apply 'concat result
)))
4366 ;;;_ > allout-stringify-flat-index-indented (flat-index)
4367 (defun allout-stringify-flat-index-indented (flat-index)
4368 "Convert list representing section/subsection/... to document string."
4372 ;; Take care of the explicit context:
4373 (setq numstr
(int-to-string (car flat-index
))
4374 flat-index
(cdr flat-index
)
4375 result
(if flat-index
4376 (cons delim
(cons numstr result
))
4377 (cons numstr result
)))
4379 ;; Take care of the indentation:
4386 (1+ (truncate (if (zerop (car flat-index
))
4388 (log10 (car flat-index
)))))
4391 (setq flat-index
(cdr flat-index
)))
4392 ;; Dispose of single extra delim:
4393 (setq result
(cdr result
))))
4394 (apply 'concat result
)))
4395 ;;;_ > allout-listify-exposed (&optional start end format)
4396 (defun allout-listify-exposed (&optional start end format
)
4398 "Produce a list representing exposed topics in current region.
4400 This list can then be used by `allout-process-exposed' to manipulate
4403 Optional START and END indicate bounds of region.
4405 optional arg, FORMAT, designates an alternate presentation form for
4408 list - Present prefix as numeric section.subsection..., starting with
4409 section indicated by the list, innermost nesting first.
4410 `indent' \(symbol) - Convert header prefixes to all white space,
4411 except for distinctive bullets.
4413 The elements of the list produced are lists that represents a topic
4414 header and body. The elements of that list are:
4416 - a number representing the depth of the topic,
4417 - a string representing the header-prefix, including trailing whitespace and
4419 - a string representing the bullet character,
4420 - and a series of strings, each containing one line of the exposed
4421 portion of the topic entry."
4427 (strings prefix pad result depth new-depth out gone-out bullet beg
4432 ;; Goto initial topic, and register preceeding stuff, if any:
4433 (if (> (allout-goto-prefix) start
)
4434 ;; First topic follows beginning point - register preliminary stuff:
4435 (setq result
(list (list 0 "" nil
4436 (buffer-substring start
(1- (point)))))))
4437 (while (and (not done
)
4438 (not (eobp)) ; Loop until we've covered the region.
4439 (not (> (point) end
)))
4440 (setq depth
(allout-recent-depth) ; Current topics depth,
4441 bullet
(allout-recent-bullet) ; ... bullet,
4442 prefix
(allout-recent-prefix)
4443 beg
(progn (allout-end-of-prefix t
) (point))) ; and beginning.
4444 (setq done
; The boundary for the current topic:
4445 (not (allout-next-visible-heading 1)))
4446 (setq new-depth
(allout-recent-depth))
4448 out
(< new-depth depth
))
4453 (while (> next
(point)) ; Get all the exposed text in
4455 (cons (buffer-substring
4457 ;To hidden text or end of line:
4459 (search-forward "\r"
4460 (save-excursion (end-of-line)
4463 (if (= (preceding-char) ?
\r)
4467 (if (< (point) next
) ; Resume from after hid text, if any.
4470 ;; Accumulate list for this topic:
4471 (setq strings
(nreverse strings
))
4475 (let ((special (if (string-match
4476 (regexp-quote bullet
)
4477 allout-distinctive-bullets-string
)
4479 (cond ((listp format
)
4481 (if allout-abbreviate-flattened-numbering
4482 (allout-stringify-flat-index format
4484 (allout-stringify-flat-index-plain
4488 ((eq format
'indent
)
4491 (concat (make-string (1+ depth
) ?
)
4492 (substring prefix -
1))
4495 (make-string depth ?
)
4497 (t (error "allout-listify-exposed: %s %s"
4498 "invalid format" format
))))
4499 (list depth prefix strings
))
4501 ;; Reasses format, if any:
4502 (if (and format
(listp format
))
4503 (cond ((= new-depth depth
)
4504 (setq format
(cons (1+ (car format
))
4506 ((> new-depth depth
) ; descending - assume by 1:
4507 (setq format
(cons 1 format
)))
4510 (while (< new-depth depth
)
4511 (setq format
(cdr format
))
4512 (setq depth
(1- depth
)))
4513 ; And increment the current one:
4515 (cons (1+ (or (car format
)
4518 ;; Put the list with first at front, to last at back:
4519 (nreverse result
))))
4520 ;;;_ > my-region-active-p ()
4521 (defmacro my-region-active-p
()
4522 (if (fboundp 'region-active-p
)
4525 ;;;_ > allout-process-exposed (&optional func from to frombuf
4527 (defun allout-process-exposed (&optional func from to frombuf tobuf
4528 format
&optional start-num
)
4529 "Map function on exposed parts of current topic; results to another buffer.
4531 All args are options; default values itemized below.
4533 Apply FUNCTION to exposed portions FROM position TO position in buffer
4534 FROMBUF to buffer TOBUF. Sixth optional arg, FORMAT, designates an
4535 alternate presentation form:
4537 `flat' - Present prefix as numeric section.subsection..., starting with
4538 section indicated by the start-num, innermost nesting first.
4539 X`flat-indented' - Prefix is like `flat' for first topic at each
4540 X level, but subsequent topics have only leaf topic
4541 X number, padded with blanks to line up with first.
4542 `indent' \(symbol) - Convert header prefixes to all white space,
4543 except for distinctive bullets.
4546 FUNCTION: `allout-insert-listified'
4547 FROM: region start, if region active, else start of buffer
4548 TO: region end, if region active, else end of buffer
4549 FROMBUF: current buffer
4550 TOBUF: buffer name derived: \"*current-buffer-name exposed*\"
4553 ; Resolve arguments,
4554 ; defaulting if necessary:
4555 (if (not func
) (setq func
'allout-insert-listified
))
4556 (if (not (and from to
))
4557 (if (my-region-active-p)
4558 (setq from
(region-beginning) to
(region-end))
4559 (setq from
(point-min) to
(point-max))))
4561 (if (not (bufferp frombuf
))
4562 ;; Specified but not a buffer - get it:
4563 (let ((got (get-buffer frombuf
)))
4565 (error (concat "allout-process-exposed: source buffer "
4568 (setq frombuf got
))))
4569 ;; not specified - default it:
4570 (setq frombuf
(current-buffer)))
4572 (if (not (bufferp tobuf
))
4573 (setq tobuf
(get-buffer-create tobuf
)))
4574 ;; not specified - default it:
4575 (setq tobuf
(concat "*" (buffer-name frombuf
) " exposed*")))
4580 (progn (set-buffer frombuf
)
4581 (allout-listify-exposed from to format
))))
4583 (mapcar func listified
)
4584 (pop-to-buffer tobuf
)))
4587 ;;;_ > allout-insert-listified (listified)
4588 (defun allout-insert-listified (listified)
4589 "Insert contents of listified outline portion in current buffer.
4591 LISTIFIED is a list representing each topic header and body:
4593 \`(depth prefix text)'
4595 or \`(depth prefix text bullet-plus)'
4597 If `bullet-plus' is specified, it is inserted just after the entire prefix."
4598 (setq listified
(cdr listified
))
4599 (let ((prefix (prog1
4601 (setq listified
(cdr listified
))))
4604 (setq listified
(cdr listified
))))
4605 (bullet-plus (car listified
)))
4607 (if bullet-plus
(insert (concat " " bullet-plus
)))
4610 (if (setq text
(cdr text
))
4611 (insert-string "\n")))
4613 ;;;_ > allout-copy-exposed-to-buffer (&optional arg tobuf format)
4614 (defun allout-copy-exposed-to-buffer (&optional arg tobuf format
)
4615 "Duplicate exposed portions of current outline to another buffer.
4617 Other buffer has current buffers name with \" exposed\" appended to it.
4619 With repeat count, copy the exposed parts of only the current topic.
4621 Optional second arg TOBUF is target buffer name.
4623 Optional third arg FORMAT, if non-nil, symbolically designates an
4624 alternate presentation format for the outline:
4626 `flat' - Convert topic header prefixes to numeric
4627 section.subsection... identifiers.
4628 `indent' - Convert header prefixes to all white space, except for
4629 distinctive bullets.
4630 `indent-flat' - The best of both - only the first of each level has
4631 the full path, the rest have only the section number
4632 of the leaf, preceded by the right amount of indentation."
4636 (setq tobuf
(get-buffer-create (concat "*" (buffer-name) " exposed*"))))
4637 (let* ((start-pt (point))
4638 (beg (if arg
(allout-back-to-current-heading) (point-min)))
4639 (end (if arg
(allout-end-of-current-subtree) (point-max)))
4640 (buf (current-buffer))
4642 (if (eq format
'flat
)
4643 (setq format
(if arg
(save-excursion
4645 (allout-topic-flat-index))
4647 (save-excursion (set-buffer tobuf
)(erase-buffer))
4648 (allout-process-exposed 'allout-insert-listified
4654 (goto-char (point-min))
4656 (goto-char start-pt
)))
4657 ;;;_ > allout-flatten-exposed-to-buffer (&optional arg tobuf)
4658 (defun allout-flatten-exposed-to-buffer (&optional arg tobuf
)
4659 "Present numeric outline of outline's exposed portions in another buffer.
4661 The resulting outline is not compatible with outline mode - use
4662 `allout-copy-exposed-to-buffer' if you want that.
4664 Use `allout-indented-exposed-to-buffer' for indented presentation.
4666 With repeat count, copy the exposed portions of only current topic.
4668 Other buffer has current buffer's name with \" exposed\" appended to
4669 it, unless optional second arg TOBUF is specified, in which case it is
4672 (allout-copy-exposed-to-buffer arg tobuf
'flat
))
4673 ;;;_ > allout-indented-exposed-to-buffer (&optional arg tobuf)
4674 (defun allout-indented-exposed-to-buffer (&optional arg tobuf
)
4675 "Present indented outline of outline's exposed portions in another buffer.
4677 The resulting outline is not compatible with outline mode - use
4678 `allout-copy-exposed-to-buffer' if you want that.
4680 Use `allout-flatten-exposed-to-buffer' for numeric sectional presentation.
4682 With repeat count, copy the exposed portions of only current topic.
4684 Other buffer has current buffer's name with \" exposed\" appended to
4685 it, unless optional second arg TOBUF is specified, in which case it is
4688 (allout-copy-exposed-to-buffer arg tobuf
'indent
))
4690 ;;;_ - LaTeX formatting
4691 ;;;_ > allout-latex-verb-quote (string &optional flow)
4692 (defun allout-latex-verb-quote (string &optional flow
)
4693 "Return copy of STRING for literal reproduction across LaTeX processing.
4694 Expresses the original characters \(including carriage returns) of the
4695 string across LaTeX processing."
4696 (mapconcat (function
4698 (cond ((memq char
'(?
\\ ?$ ?% ?
# ?
& ?
{ ?
} ?_ ?^ ?- ?
*))
4699 (concat "\\char" (number-to-string char
) "{}"))
4700 ((= char ?
\n) "\\\\")
4701 (t (char-to-string char
)))))
4704 ;;;_ > allout-latex-verbatim-quote-curr-line ()
4705 (defun allout-latex-verbatim-quote-curr-line ()
4706 "Express line for exact \(literal) representation across LaTeX processing.
4708 Adjust line contents so it is unaltered \(from the original line)
4709 across LaTeX processing, within the context of a `verbatim'
4710 environment. Leaves point at the end of the line."
4713 (end (progn (end-of-line)(point))))
4715 (while (re-search-forward "\\\\"
4716 ;;"\\\\\\|\\{\\|\\}\\|\\_\\|\\$\\|\\\"\\|\\&\\|\\^\\|\\-\\|\\*\\|#"
4717 end
; bounded by end-of-line
4718 1) ; no matches, move to end & return nil
4719 (goto-char (match-beginning 0))
4722 (goto-char (1+ (match-end 0))))))
4723 ;;;_ > allout-insert-latex-header (buffer)
4724 (defun allout-insert-latex-header (buffer)
4725 "Insert initial LaTeX commands at point in BUFFER."
4726 ;; Much of this is being derived from the stuff in appendix of E in
4727 ;; the TeXBook, pg 421.
4729 (let ((doc-style (format "\n\\documentstyle{%s}\n"
4731 (page-numbering (if allout-number-pages
4732 "\\pagestyle{empty}\n"
4734 (linesdef (concat "\\def\\beginlines{"
4735 "\\par\\begingroup\\nobreak\\medskip"
4737 " \\kern1pt\\nobreak \\obeylines \\obeyspaces "
4738 "\\everypar{\\strut}}\n"
4740 "\\kern1pt\\endgroup\\medbreak\\noindent}\n"))
4741 (titlecmd (format "\\newcommand{\\titlecmd}[1]{{%s #1}}\n"
4742 allout-title-style
))
4743 (labelcmd (format "\\newcommand{\\labelcmd}[1]{{%s #1}}\n"
4744 allout-label-style
))
4745 (headlinecmd (format "\\newcommand{\\headlinecmd}[1]{{%s #1}}\n"
4746 allout-head-line-style
))
4747 (bodylinecmd (format "\\newcommand{\\bodylinecmd}[1]{{%s #1}}\n"
4748 allout-body-line-style
))
4749 (setlength (format "%s%s%s%s"
4750 "\\newlength{\\stepsize}\n"
4751 "\\setlength{\\stepsize}{"
4754 (oneheadline (format "%s%s%s%s%s%s%s"
4755 "\\newcommand{\\OneHeadLine}[3]{%\n"
4757 "\\hspace*{#2\\stepsize}%\n"
4758 "\\labelcmd{#1}\\hspace*{.2cm}"
4759 "\\headlinecmd{#3}\\\\["
4762 (onebodyline (format "%s%s%s%s%s%s"
4763 "\\newcommand{\\OneBodyLine}[2]{%\n"
4765 "\\hspace*{#1\\stepsize}%\n"
4766 "\\bodylinecmd{#2}\\\\["
4769 (begindoc "\\begin{document}\n\\begin{center}\n")
4770 (title (format "%s%s%s%s"
4772 (allout-latex-verb-quote (if allout-title
4775 ('error
"<unnamed buffer>"))
4778 "\\end{center}\n\n"))
4779 (hsize "\\hsize = 7.5 true in\n")
4780 (hoffset "\\hoffset = -1.5 true in\n")
4781 (vspace "\\vspace{.1cm}\n\n"))
4782 (insert (concat doc-style
4797 ;;;_ > allout-insert-latex-trailer (buffer)
4798 (defun allout-insert-latex-trailer (buffer)
4799 "Insert concluding LaTeX commands at point in BUFFER."
4801 (insert "\n\\end{document}\n"))
4802 ;;;_ > allout-latexify-one-item (depth prefix bullet text)
4803 (defun allout-latexify-one-item (depth prefix bullet text
)
4804 "Insert LaTeX commands for formatting one outline item.
4806 Args are the topics numeric DEPTH, the header PREFIX lead string, the
4807 BULLET string, and a list of TEXT strings for the body."
4808 (let* ((head-line (if text
(car text
)))
4809 (body-lines (cdr text
))
4813 (insert (concat "\\OneHeadLine{\\verb\1 "
4814 (allout-latex-verb-quote bullet
)
4819 (allout-latex-verb-quote head-line
)
4822 (if (not body-lines
)
4824 ;;(insert "\\beginlines\n")
4825 (insert "\\begin{verbatim}\n")
4827 (setq curr-line
(car body-lines
))
4828 (if (and (not body-content
)
4829 (not (string-match "^\\s-*$" curr-line
)))
4830 (setq body-content t
))
4831 ; Mangle any occurrences of
4832 ; "\end{verbatim}" in text,
4834 (if (and body-content
4835 (setq bop
(string-match "\\end{verbatim}" curr-line
)))
4836 (setq curr-line
(concat (substring curr-line
0 bop
)
4838 (substring curr-line bop
))))
4839 ;;(insert "|" (car body-lines) "|")
4841 (allout-latex-verbatim-quote-curr-line)
4843 (setq body-lines
(cdr body-lines
)))
4845 (setq body-content nil
)
4849 ;;(insert "\\endlines\n")
4850 (insert "\\end{verbatim}\n")
4852 ;;;_ > allout-latexify-exposed (arg &optional tobuf)
4853 (defun allout-latexify-exposed (arg &optional tobuf
)
4854 "Format current topics exposed portions to TOBUF for LaTeX processing.
4855 TOBUF defaults to a buffer named the same as the current buffer, but
4856 with \"*\" prepended and \" latex-formed*\" appended.
4858 With repeat count, copy the exposed portions of entire buffer."
4863 (get-buffer-create (concat "*" (buffer-name) " latexified*"))))
4864 (let* ((start-pt (point))
4865 (beg (if arg
(point-min) (allout-back-to-current-heading)))
4866 (end (if arg
(point-max) (allout-end-of-current-subtree)))
4867 (buf (current-buffer)))
4870 (allout-insert-latex-header tobuf
)
4871 (goto-char (point-max))
4872 (allout-process-exposed 'allout-latexify-one-item
4877 (goto-char (point-max))
4878 (allout-insert-latex-trailer tobuf
)
4879 (goto-char (point-min))
4881 (goto-char start-pt
)))
4884 ;;;_ > allout-toggle-current-subtree-encryption (&optional fetch-key)
4885 (defun allout-toggle-current-subtree-encryption (&optional fetch-key
)
4886 "Encrypt clear text or decrypt encoded contents of a topic.
4888 Contents includes body and subtopics.
4890 Currently only GnuPG encryption is supported.
4892 \**NOTE WELL** that the encrypted text must be ascii-armored. For gnupg
4893 encryption, include the option ``armor'' in your ~/.gnupg/gpg.conf file.
4895 Both symmetric-key and key-pair encryption is implemented. Symmetric is
4896 the default, use a single \(x4) universal argument for keypair mode.
4898 Encrypted topic's bullet is set to a `~' to signal that the contents of the
4899 topic \(body and subtopics, but not heading) is pending encryption or
4900 encrypted. An `*' asterisk immediately after the bullet signals that the
4901 body is encrypted, its absence means it's meant to be encrypted but is not
4902 - it's \"disclosed\". When a file with disclosed topics is saved, the user
4903 prompted for an ok to \(symmetric-key) encrypt the disclosed topics. NOTE
4904 WELL that you must explicitly \(re)encrypt key-pair encrypted topics if you
4905 want them to continue to be in key-pair mode.
4907 Level-1 topics, with prefix consisting solely of an `*' asterisk, cannot be
4908 encrypted. If you want to encrypt the contents of a top-level topic, use
4909 \\[allout-shift-in] to increase its depth.
4911 Failed transformation does not change the an entry being encrypted -
4912 instead, the key is re-solicited and the transformation is retried.
4913 \\[keyboard-quit] to abort.
4915 Decryption does symmetric or key-pair key mode depending on how the text
4916 was encrypted. The encryption key is solicited if not currently available
4917 from the key cache from a recent prior encryption action.
4919 Optional FETCH-KEY universal argument is used for two purposes - to provoke
4920 key-pair instead of symmetric encryption, or to provoke clearing of the key
4921 cache so keys are freshly fetched.
4923 - Without any universal arguments, then the appropriate key for the is
4924 obtained from the cache, if available, else from the user.
4926 - If FETCH-KEY is the result of one universal argument - ie, equal to 4 -
4927 then key-pair encryption is used.
4929 - With repeated universal argument - equal to 16 - then the key cache is
4930 cleared before any encryption transformations, to force prompting of the
4933 The solicited key is retained for reuse in a buffer-specific cache for some
4934 set period of time \(default, 60 seconds), after which the string is
4935 nulled. `mailcrypt' provides the key caching functionality. You can
4936 adjust the key cache timeout by ajdusting the setting of the elisp variable
4937 `mc-passwd-timeout'.
4939 If the file previously had no associated key, or had a different key than
4940 specified, the user is prompted to repeat the new one for corroboration. A
4941 random string encrypted by the new key is set on the buffer-specific
4942 variable `allout-key-verifier-string', for confirmation of the key when
4943 next obtained, before encrypting or decrypting anything with it. This
4944 helps avoid mistakenly shifting between keys.
4946 If allout customization var `allout-key-verifier-handling' is non-nil, an
4947 entry for `allout-key-verifier-string' and its value is added to an Emacs
4948 'local variables' section at the end of the file, which is created if
4949 necessary. That setting is for retention of the key verifier across emacs
4952 Similarly, `allout-key-hint-string' stores a user-provided reminder about
4953 their key, and `allout-key-hint-handling' specifies when the hint is
4954 presented, or if key hints are disabled. If enabled \(see the
4955 `allout-key-hint-handling' docstring for details), the hint string is
4956 stored in the local-variables section of the file, and solicited whenever
4957 the key is changed."
4959 ;;; This routine handles allout-specific business, dispatching
4960 ;;; encryption-specific business to allout-encrypt-string.
4964 (allout-end-of-prefix t
)
4966 (if (= (allout-recent-depth) 1)
4967 (error (concat "Cannot encrypt or decrypt level 1 topics -"
4968 " shift it in to make it encryptable")))
4971 (not (equal fetch-key
'(4))))
4972 (mc-deactivate-passwd))
4974 (let* ((allout-buffer (current-buffer))
4976 (after-bullet-pos (point))
4978 (progn (if (= (point-max) after-bullet-pos
)
4979 (error "no body to encrypt"))
4980 (looking-at "\\*")))
4981 (was-collapsed (if (not (re-search-forward "[\n\r]" nil t
))
4985 (subtree-beg (1+ (point)))
4986 (subtree-end (allout-end-of-subtree))
4987 (subject-text (buffer-substring-no-properties subtree-beg
4989 (subtree-end-char (char-after (1- subtree-end
)))
4990 (subtree-trailling-char (char-after subtree-end
))
4991 (place-holder (if (or (string= "" subject-text
)
4992 (string= "\n" subject-text
))
4993 (error "No topic contents to %scrypt"
4994 (if was-encrypted
"de" "en"))))
4995 ;; Assess key parameters:
4997 ;; detect the type by which it is already encrypted
4999 (allout-encrypted-text-type subject-text
))
5000 (and (member fetch-key
'(4 (4)))
5001 (yes-or-no-p "Use key-pair encryption instead? ")
5004 (fetch-key (and fetch-key
(not (member fetch-key
'(16 (16))))))
5008 (allout-encrypt-string subject-text was-encrypted
5009 (current-buffer) key-type fetch-key
))
5011 ;; Replace the subtree with the processed product.
5014 (set-buffer allout-buffer
)
5015 (delete-region subtree-beg subtree-end
)
5016 (insert result-text
)
5018 (allout-flag-region subtree-beg
(1- (point)) ?
\r))
5019 ;; adjust trailling-blank-lines to preserve topic spacing:
5020 (if (not was-encrypted
)
5021 (if (and (member subtree-end-char
'(?
\r ?
\n))
5022 (member subtree-trailling-char
'(?
\r ?
\n)))
5023 (insert subtree-trailling-char
)))
5024 ;; Ensure that the item has an encrypted-entry bullet:
5025 (if (not (string= (buffer-substring-no-properties
5026 (1- after-bullet-pos
) after-bullet-pos
)
5027 allout-topic-encryption-bullet
))
5028 (progn (goto-char (1- after-bullet-pos
))
5030 (insert allout-topic-encryption-bullet
)))
5032 ;; Remove the is-encrypted bullet qualifier:
5033 (progn (goto-char after-bullet-pos
)
5035 ;; Add the is-encrypted bullet qualifier:
5036 (goto-char after-bullet-pos
)
5043 ;;;_ > allout-encrypt-string (text decrypt allout-buffer key-type rekey
5044 ;;; &optional retried verifying)
5045 (defun allout-encrypt-string (text decrypt allout-buffer key-type rekey
5046 &optional retried verifying
)
5047 "Encrypt or decrypt a string TEXT using KEY.
5049 If optional DECRYPT is true (default false), then decrypt instead of
5052 Optional REKEY (default false) provokes clearing of the key cache to force
5053 fresh prompting for the key.
5055 Optional RETRIED is for internal use - conveys the number of failed keys have
5056 been solicited in sequence leading to this current call.
5058 Optional VERIFYING is for internal use, signifying processing of text
5059 solely for verification of the cached key.
5061 Returns the resulting string, or nil if the transformation fails."
5063 ;; Ensure that we have an alternate handle on the real mc-activate-passwd:
5064 (if (not (fboundp 'real-mc-activate-passwd
))
5065 ;; Force loads of the primary mailcrypt packages, so flet below holds.
5066 (progn (require 'mailcrypt
)
5068 (fset 'real-mc-activate-passwd
5069 (symbol-function 'mc-activate-passwd
))))
5071 (if (and rekey
(not verifying
)) (mc-deactivate-passwd))
5073 (catch 'encryption-failed
5076 (let* ((mc-default-scheme (or allout-encryption-scheme
5077 allout-default-encryption-scheme
))
5078 (id (format "%s-%s" key-type
5079 (or (buffer-file-name allout-buffer
)
5080 (buffer-name allout-buffer
))))
5081 (cached (real-mc-activate-passwd id nil
))
5082 (comment "Processed by allout driving mailcrypt")
5083 key work-buffer result result-text encryption-process-status
)
5087 ;; Interject our mc-activate-passwd wrapper:
5088 (flet ((mc-activate-passwd (id &optional prompt
)
5089 (allout-mc-activate-passwd id prompt
)))
5092 (set-buffer (allout-encryption-produce-work-buffer text
)))
5097 ((equal key-type
'symmetric
)
5098 (setq key
(if verifying
5099 (real-mc-activate-passwd id nil
)
5100 (allout-mc-activate-passwd id
)))
5101 (setq encryption-process-status
5102 (crypt-encrypt-buffer key decrypt
))
5103 (if (zerop encryption-process-status
)
5106 (throw 'encryption-failed nil
)
5107 (mc-deactivate-passwd)
5108 (error "Symmetric-key encryption failed (%s) - wrong key?"
5109 encryption-process-status
))))
5111 ;; encrypt 'keypair:
5113 (condition-case result
5114 (mailcrypt-encrypt 1)
5115 (error (mc-deactivate-passwd)
5116 (error "encryption failed: %s"
5119 ;; decrypt 'keypair:
5120 (t (condition-case result
5122 (error (mc-deactivate-passwd)
5123 (error "decryption failed: %s"
5126 (setq result-text
(if (or (equal key-type
'keypair
)
5128 (buffer-substring 1 (1- (point-max)))
5130 ;; validate result - non-empty
5131 (cond ((not result-text
)
5134 ;; Transformation was fruitless - retry with new key.
5135 (mc-deactivate-passwd)
5136 (allout-encrypt-string text allout-buffer decrypt nil
5137 (if retried
(1+ retried
) 1)
5140 ;; Barf if encryption yields extraordinary control chars:
5142 (string-match "[\C-a\C-k\C-o-\C-z\C-@]" result-text
))
5143 (error (concat "encryption produced unusable"
5144 " non-armored text - reconfigure!")))
5146 ;; valid result and just verifying or non-symmetric:
5147 ((or verifying
(not (equal key-type
'symmetric
)))
5150 ;; valid result and regular symmetric - situate validator:
5152 ;; valid result and verifier needs to be situated in
5154 (set-buffer allout-buffer
)
5155 (if (and (or rekey
(not cached
))
5156 (not (allout-verify-key key allout-buffer
)))
5157 (allout-situate-encryption-key-verifier key id
))
5162 ;; unwind-protect emergence:
5164 (kill-buffer work-buffer
))
5170 ;;;_ > allout-mc-activate-passwd (id &optional prompt)
5171 (defun allout-mc-activate-passwd (id &optional prompt
)
5172 "Substituted for mc-activate-passwd during allout outline encryption.
5174 We add key-verification to vanilla mc-activate-passwd.
5176 We depend in some cases on values of the following allout-encrypt-string
5177 internal or prevailing variables:
5178 - key-type - 'symmetric or 'keypair
5179 - id - id associated with current key in key cache
5180 - allout-buffer - where subject text resides
5181 - retried - number of current attempts to obtain this key
5182 - rekey - user asked to present a new key - needs to be confirmed"
5184 ;; - if we're doing non-symmetric key, just do normal mc-activate-passwd
5185 ;; - otherwise, if we are have a cached version of the key, then assume
5186 ;; it's verified and return it
5187 ;; - otherwise, prompt for a key, and:
5188 ;; - if we have a key verifier \(a string value which should decrypt
5189 ;; against a symmetric key), validate against the verifier
5190 ;; - if successful, return the verified key
5191 ;; - if unsuccessful:
5192 ;; - offer to use the new key
5193 ;; - if accepted, do confirm process
5194 ;; - if refused, try again until we get a correctly spelled one or the
5196 ;; - if no key verifier, resolicit the key to get corroboration and return
5197 ;; the corroborated key if spelled identically, or error if not.
5199 (if (not (equal key-type
'symmetric
))
5200 ;; do regular mc-activate-passwd on non-symmetric key
5201 (real-mc-activate-passwd id prompt
)
5203 ;; Symmetric hereon:
5206 (set-buffer allout-buffer
)
5207 (let* ((hint (if (and (not (string= allout-key-hint-string
""))
5208 (or (equal allout-key-hint-handling
'always
)
5209 (and (equal allout-key-hint-handling
'needed
)
5211 (format " [%s]" allout-key-hint-string
)
5213 (retry-message (if retried
(format " (%s retry)" retried
) ""))
5214 (prompt-sans-hint (format "'%s' symmetric key%s: "
5215 (buffer-name allout-buffer
)
5217 (full-prompt (format "'%s' symmetric key%s%s: "
5218 (buffer-name allout-buffer
)
5219 hint retry-message
))
5220 (prompt full-prompt
)
5221 (verifier-string (allout-get-encryption-key-verifier))
5222 ;; force retention of cached passwords for five minutes while
5223 ;; we're in this particular routine:
5224 (mc-passwd-timeout 300)
5225 (cached (real-mc-activate-passwd id nil
))
5226 (got (or cached
(real-mc-activate-passwd id full-prompt
)))
5232 ;; Duplicate our handle on the key so it's not clobbered by
5233 ;; deactivate-passwd memory clearing:
5234 (setq got
(format "%s" got
))
5236 (cond (verifier-string
5237 (if (and (not (allout-encrypt-string
5238 verifier-string
'decrypt allout-buffer
5239 'symmetric nil
0 'verifying
))
5241 (concat "Key differs from established"
5242 " - use new one instead? "))
5243 ;; deactivate password for subsequent
5245 (progn (mc-deactivate-passwd)
5246 (setq prompt prompt-sans-hint
)
5249 (progn (mc-deactivate-passwd)
5250 (error "Wrong key."))))
5251 ;; Force confirmation by repetition for new key:
5252 ((or rekey
(not cached
)) (mc-deactivate-passwd))))
5253 ;; we have a key and it's either verified and cached.
5254 ;; confirmation vs new input - doing mc-activate-passwd will do the
5255 ;; right thing, in either case:
5257 (real-mc-activate-passwd id
(concat prompt
5258 " ... confirm spelling: ")))
5260 (if (equal got confirmation
)
5262 (if (yes-or-no-p (concat "spelling of original and"
5263 " confirmation differ - retry? "))
5264 (progn (setq retried
(if retried
(1+ retried
) 1))
5265 (mc-deactivate-passwd)
5266 ;; recurse to this routine:
5267 (mc-activate-passwd id prompt-sans-hint
))
5268 (mc-deactivate-passwd)
5269 (error "Confirmation failed.")))
5270 ;; reduce opportunity for memory cherry-picking by zeroing duplicate:
5271 (dotimes (i (length got
))
5278 ;;;_ > allout-encryption-produce-work-buffer (text)
5279 (defun allout-encryption-produce-work-buffer (text)
5280 "Establish a new buffer filled with TEXT, for outline encrypion processing.
5282 TEXT is massaged so outline collapsing, if any, is removed."
5283 (let ((work-buffer (generate-new-buffer " *allout encryption*")))
5285 (set-buffer work-buffer
)
5286 (insert (subst-char-in-string ?
\r ?
\n text
)))
5288 ;;;_ > allout-encrypted-topic-p ()
5289 (defun allout-encrypted-topic-p ()
5290 "True if the current topic is encryptable and encrypted."
5292 (allout-end-of-prefix t
)
5293 (and (string= (buffer-substring-no-properties (1- (point)) (point))
5294 allout-topic-encryption-bullet
)
5298 ;;;_ > allout-encrypted-text-type (text)
5299 ;;; XXX gpg-specific, not generic!
5300 (defun allout-encrypted-text-type (text)
5301 "For gpg encrypted text, return 'symmetric or 'keypair."
5303 ;; Ensure mc-gpg-path has a value:
5304 (if (not (boundp 'mc-gpg-path
))
5305 (load-library "mc-gpg"))
5308 (let* ((work-buffer (set-buffer
5309 (allout-encryption-produce-work-buffer text
)))
5310 (result (mc-gpg-process-region (point-min) (point-max)
5312 '("--batch" "--decrypt")
5313 'mc-gpg-decrypt-parser
5315 (cond ((equal (nth 0 result
) 'symmetric
)
5317 ((equal (nth 0 result
) t
)
5319 (t (error "Unrecognized/unsupported encryption type %S"
5324 ;;;_ > allout-create-encryption-key-verifier (key id)
5325 (defun allout-create-encryption-key-verifier (key id
)
5326 "Encrypt a random message for later validation of symmetric key."
5327 ;; use 20 random ascii characters, across the entire ascii range.
5329 (let ((spew (make-string 20 ?\
0)))
5330 (dotimes (i (length spew
))
5331 (aset spew i
(1+ (random 254))))
5332 (allout-encrypt-string spew nil nil
'symmetric nil nil t
))
5334 ;;;_ > allout-situate-encryption-key-verifier (key id)
5335 (defun allout-situate-encryption-key-verifier (key id
)
5336 "Establish key verifier string on file variable.
5338 We also prompt for and situate a new reminder, if reminders are enabled.
5340 We massage the string to simplify programmatic adjustment. File variable
5341 is `allout-file-key-verifier-string'."
5342 (let ((verifier-string
5343 ;; Collapse to a single line and enclose in string quotes:
5344 (subst-char-in-string ?
\n ?\C-a
5345 (allout-create-encryption-key-verifier
5347 (reminder (if (not (equal allout-key-hint-handling
'disabled
))
5348 (read-from-minibuffer
5349 "Key hint to jog your memory next time: "
5350 allout-key-hint-string
))))
5351 (setq allout-key-verifier-string verifier-string
)
5352 (allout-adjust-file-variable "allout-key-verifier-string"
5354 (cond ((equal allout-key-hint-handling
'disabled
)
5356 ((not (string= reminder allout-key-hint-string
))
5357 (setq allout-key-hint-string reminder
)
5358 (allout-adjust-file-variable "allout-key-hint-string"
5362 ;;;_ > allout-get-encryption-key-verifier ()
5363 (defun allout-get-encryption-key-verifier ()
5364 "Return the text of the encrypt key verifier, unmassaged, or nil if none.
5366 Derived from value of `allout-file-key-verifier-string'."
5368 (let ((verifier-string (and (boundp 'allout-key-verifier-string
)
5369 allout-key-verifier-string
)))
5371 ;; Return it uncollapsed
5372 (subst-char-in-string ?\C-a ?
\n verifier-string
)
5376 ;;;_ > allout-verify-key (key)
5377 (defun allout-verify-key (key allout-buffer
)
5378 "True if key successfully decrypts key verifier, nil otherwise.
5380 \"Otherwise\" includes absence of key verifier."
5382 (set-buffer allout-buffer
)
5383 (and (boundp 'allout-key-verifier-string
)
5384 allout-key-verifier-string
5385 (allout-encrypt-string (allout-get-encryption-key-verifier)
5386 'decrypt allout-buffer
'symmetric
5389 ;;;_ > allout-next-topic-pending-encryption (&optional except-mark)
5390 (defun allout-next-topic-pending-encryption (&optional except-mark
)
5391 "Return the point of the next topic pending encryption, or nil if none.
5393 EXCEPT-MARK identifies a point whose containing topics should be excluded
5394 from encryption. This supports 'except-current mode of
5395 `allout-encrypt-unencrypted-on-saves'.
5397 Such a topic has the allout-topic-encryption-bullet without an
5398 immediately following '*' that would mark the topic as being encrypted. It
5399 must also have content."
5400 (let (done got content-beg
)
5403 (if (not (re-search-forward
5404 (format "\\(\\`\\|[\n\r]\\)%s *%s[^*]"
5405 (regexp-quote allout-header-prefix
)
5406 (regexp-quote allout-topic-encryption-bullet
))
5410 (goto-char (setq got
(match-beginning 0)))
5411 (if (looking-at "[\n\r]")
5418 ((not (re-search-forward "[\n\r]"))
5427 (setq content-beg
(point))
5429 (allout-end-of-subtree)
5430 (if (or (<= (point) content-beg
)
5432 (<= content-beg except-mark
)
5433 (>= (point) except-mark
)))
5444 ;;;_ > allout-encrypt-decrypted (&optional except-mark)
5445 (defun allout-encrypt-decrypted (&optional except-mark
)
5446 "Encrypt topics pending encryption except those containing exemption point.
5448 EXCEPT-MARK identifies a point whose containing topics should be excluded
5449 from encryption. This supports 'except-current mode of
5450 `allout-encrypt-unencrypted-on-saves'.
5452 If a topic that is currently being edited was encrypted, we return a list
5453 containing the location of the topic and the location of the cursor just
5454 before the topic was encrypted. This can be used, eg, to decrypt the topic
5455 and exactly resituate the cursor if this is being done as part of a file
5456 save. See `allout-encrypt-unencrypted-on-saves' for more info."
5460 (let ((current-mark (point-marker))
5463 editing-topic editing-point
)
5464 (goto-char (point-min))
5465 (while (allout-next-topic-pending-encryption except-mark
)
5466 (setq was-modified
(buffer-modified-p))
5468 (and (boundp 'allout-encrypt-unencrypted-on-saves
)
5469 allout-encrypt-unencrypted-on-saves
5470 (setq bo-subtree
(re-search-forward "[\n\r]"))
5472 (string= (match-string 0) "\n")
5473 (>= current-mark
(point))
5474 (allout-end-of-current-subtree)
5475 (<= current-mark
(point))))
5476 (setq editing-topic
(point)
5477 ;; we had to wait for this 'til now so prior topics are
5478 ;; encrypted, any relevant text shifts are in place:
5479 editing-point
(marker-position current-mark
)))
5480 (allout-toggle-current-subtree-encryption)
5481 (if (not was-modified
)
5482 (set-buffer-modified-p nil
))
5484 (if (not was-modified
)
5485 (set-buffer-modified-p nil
))
5486 (if editing-topic
(list editing-topic editing-point
))
5491 ;;;_ #9 miscellaneous
5492 ;;;_ > allout-mark-topic ()
5493 (defun allout-mark-topic ()
5494 "Put the region around topic currently containing point."
5497 (allout-goto-prefix)
5499 (allout-end-of-current-subtree)
5500 (exchange-point-and-mark))
5501 ;;;_ > outlineify-sticky ()
5502 ;; outlinify-sticky is correct spelling; provide this alias for sticklers:
5503 (defalias 'outlinify-sticky
'outlineify-sticky
)
5504 (defun outlineify-sticky (&optional arg
)
5505 "Activate outline mode and establish file var so it is started subsequently.
5507 See doc-string for `allout-layout' and `allout-init' for details on
5508 setup for auto-startup."
5515 (goto-char (point-min))
5516 (if (looking-at allout-regexp
)
5518 (allout-open-topic 2)
5519 (insert (concat "Dummy outline topic header - see"
5520 "`allout-mode' docstring: `^Hm'."))
5521 (allout-adjust-file-variable
5522 "allout-layout" (format "%s" (or allout-layout
'(-1 : 0)))))))
5523 ;;;_ > allout-file-vars-section-data ()
5524 (defun allout-file-vars-section-data ()
5525 "Return data identifying the file-vars section, or nil if none.
5527 Returns list `(beginning-point prefix-string suffix-string)'."
5528 ;; minimally gleaned from emacs 21.4 files.el hack-local-variables function.
5529 (let (beg prefix suffix
)
5531 (goto-char (point-max))
5532 (search-backward "\n\^L" (max (- (point-max) 3000) (point-min)) 'move
)
5533 (if (let ((case-fold-search t
))
5534 (not (search-forward "Local Variables:" nil t
)))
5536 (setq beg
(- (point) 16))
5537 (setq suffix
(buffer-substring-no-properties
5539 (progn (if (re-search-forward "[\n\r]" nil t
)
5542 (setq prefix
(buffer-substring-no-properties
5543 (progn (if (re-search-backward "[\n\r]" nil t
)
5547 (list beg prefix suffix
))
5551 ;;;_ > allout-adjust-file-variable (varname value)
5552 (defun allout-adjust-file-variable (varname value
)
5553 "Adjust the setting of an emacs file variable named VARNAME to VALUE.
5555 This activity is inhibited if either `enable-local-variables'
5556 `allout-enable-file-variable-adjustment' are nil.
5558 When enabled, an entry for the variable is created if not already present,
5559 or changed if established with a different value. The section for the file
5560 variables, itself, is created if not already present. When created, the
5561 section lines \(including the section line) exist as second-level topics in
5562 a top-level topic at the end of the file.
5564 enable-local-variables must be true for any of this to happen."
5565 (if (not (and enable-local-variables
5566 allout-enable-file-variable-adjustment
))
5569 (let ((section-data (allout-file-vars-section-data))
5572 (setq beg
(car section-data
)
5573 prefix
(cadr section-data
)
5574 suffix
(car (cddr section-data
)))
5575 ;; create the section
5576 (goto-char (point-max))
5578 (allout-open-topic 0)
5580 (insert "Local emacs vars.\n")
5581 (allout-open-topic 1)
5584 prefix
(buffer-substring-no-properties (progn
5589 (insert "Local variables:\n")
5590 (allout-open-topic 0)
5593 ;; look for existing entry or create one, leaving point for insertion
5596 (allout-show-to-offshoot)
5597 (if (search-forward (concat "\n" prefix varname
":") nil t
)
5598 (let* ((value-beg (point))
5599 (line-end (progn (if (re-search-forward "[\n\r]" nil t
)
5602 (value-end (- line-end
(length suffix
))))
5603 (if (> value-end value-beg
)
5604 (delete-region value-beg value-end
)))
5608 (insert (concat prefix varname
":")))
5609 (insert (format " %S%s" value suffix
))
5614 ;;;_ > solicit-char-in-string (prompt string &optional do-defaulting)
5615 (defun solicit-char-in-string (prompt string
&optional do-defaulting
)
5616 "Solicit (with first arg PROMPT) choice of a character from string STRING.
5618 Optional arg DO-DEFAULTING indicates to accept empty input (CR)."
5620 (let ((new-prompt prompt
)
5624 (message "%s" new-prompt
)
5626 ;; We do our own reading here, so we can circumvent, eg, special
5627 ;; treatment for `?' character. (Oughta use minibuffer keymap instead.)
5629 (char-to-string (let ((cursor-in-echo-area nil
)) (read-char))))
5632 (cond ((string-match (regexp-quote got
) string
) got
)
5633 ((and do-defaulting
(string= got
"\r"))
5634 ;; Return empty string to default:
5636 ((string= got
"\C-g") (signal 'quit nil
))
5638 (setq new-prompt
(concat prompt
5644 ;; got something out of loop - return it:
5647 ;;;_ > regexp-sans-escapes (string)
5648 (defun regexp-sans-escapes (regexp &optional successive-backslashes
)
5649 "Return a copy of REGEXP with all character escapes stripped out.
5651 Representations of actual backslashes - '\\\\\\\\' - are left as a
5654 Optional arg SUCCESSIVE-BACKSLASHES is used internally for recursion."
5656 (if (string= regexp
"")
5658 ;; Set successive-backslashes to number if current char is
5659 ;; backslash, or else to nil:
5660 (setq successive-backslashes
5661 (if (= (aref regexp
0) ?
\\)
5662 (if successive-backslashes
(1+ successive-backslashes
) 1)
5664 (if (or (not successive-backslashes
) (= 2 successive-backslashes
))
5665 ;; Include first char:
5666 (concat (substring regexp
0 1)
5667 (regexp-sans-escapes (substring regexp
1)))
5668 ;; Exclude first char, but maintain count:
5669 (regexp-sans-escapes (substring regexp
1) successive-backslashes
))))
5670 ;;;_ - add-hook definition for divergent emacsen
5671 ;;;_ > add-hook (hook function &optional append)
5672 (if (not (fboundp 'add-hook
))
5673 (defun add-hook (hook function
&optional append
)
5674 "Add to the value of HOOK the function FUNCTION unless already present.
5675 \(It becomes the first hook on the list unless optional APPEND is non-nil, in
5676 which case it becomes the last). HOOK should be a symbol, and FUNCTION may be
5677 any valid function. HOOK's value should be a list of functions, not a single
5678 function. If HOOK is void, it is first set to nil."
5679 (or (boundp hook
) (set hook nil
))
5680 (or (if (consp function
)
5681 ;; Clever way to tell whether a given lambda-expression
5682 ;; is equal to anything in the hook.
5683 (let ((tail (assoc (cdr function
) (symbol-value hook
))))
5684 (equal function tail
))
5685 (memq function
(symbol-value hook
)))
5688 (nconc (symbol-value hook
) (list function
))
5689 (cons function
(symbol-value hook
)))))))
5690 ;;;_ > subst-char-in-string if necessary
5691 (if (not (fboundp 'subst-char-in-string
))
5692 (defun subst-char-in-string (fromchar tochar string
&optional inplace
)
5693 "Replace FROMCHAR with TOCHAR in STRING each time it occurs.
5694 Unless optional argument INPLACE is non-nil, return a new string."
5695 (let ((i (length string
))
5696 (newstr (if inplace string
(copy-sequence string
))))
5699 (if (eq (aref newstr i
) fromchar
)
5700 (aset newstr i tochar
)))
5703 ;;;_ : my-mark-marker to accommodate divergent emacsen:
5704 (defun my-mark-marker (&optional force buffer
)
5705 "Accommodate the different signature for `mark-marker' across Emacsen.
5707 XEmacs takes two optional args, while mainline GNU Emacs does not,
5708 so pass them along when appropriate."
5709 (if (string-match " XEmacs " emacs-version
)
5710 (mark-marker force buffer
)
5713 ;;;_ #10 Under development
5714 ;;;_ > allout-bullet-isearch (&optional bullet)
5715 (defun allout-bullet-isearch (&optional bullet
)
5716 "Isearch \(regexp) for topic with bullet BULLET."
5719 (setq bullet
(solicit-char-in-string
5720 "ISearch for topic with bullet: "
5721 (regexp-sans-escapes allout-bullets-string
))))
5723 (let ((isearch-regexp t
)
5724 (isearch-string (concat "^"
5725 allout-header-prefix
5728 (isearch-repeat 'forward
)
5730 ;;;_ ? Re hooking up with isearch - use isearch-op-fun rather than
5731 ;;; wrapping the isearch functions.
5733 ;;;_* Local emacs vars.
5734 ;;; The following `allout-layout' local variable setting:
5735 ;;; - closes all topics from the first topic to just before the third-to-last,
5736 ;;; - shows the children of the third to last (config vars)
5737 ;;; - and the second to last (code section),
5738 ;;; - and closes the last topic (this local-variables section).
5740 ;;;allout-layout: (0 : -1 -1 0)
5743 ;;; arch-tag: cf38fbc3-c044-450f-8bff-afed8ba5681c
5744 ;;; allout.el ends here