X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/eb8c3be94e12644f506b8857e49ffef88046bb0b..ec38bb4664eacfe1d91ae56c10aa03a5d6d1ca96:/lisp/allout.el diff --git a/lisp/allout.el b/lisp/allout.el index b76d90c7b2..a64ba4b8f9 100644 --- a/lisp/allout.el +++ b/lisp/allout.el @@ -1,296 +1,671 @@ -;;;_* Allout - An extensive outline-mode for Emacs. -;;; Note - the lines beginning with ';;;_' are outline topic headers. -;;; Load this file (or 'eval-current-buffer') and revisit the -;;; file to give it a whirl. +;;; allout.el --- extensive outline mode for use alone and with other modes -;;;_ + Provide -(provide 'outline) +;; Copyright (C) 1992, 1993, 1994, 2001, 2002, 2003, 2004, +;; 2005 Free Software Foundation, Inc. -;;;_ + Package Identification Stuff - -;;;_ - Author: Ken Manheimer -;;;_ - Maintainer: Ken Manheimer -;;;_ - Created: Dec 1991 - first release to usenet -;;;_ - Version: $Id: allout.el,v 1.2 1993/06/07 18:48:08 rms Exp jimb $|| -;;;_ - Keywords: outline mode - -;;;_ - LCD Archive Entry - -;; LCD Archive Entry: -;; allout|Ken Manheimer|klm@nist.gov -;; |A more thorough outline-mode -;; |27-May-1993|$Id: allout.el,v 1.2 1993/06/07 18:48:08 rms Exp jimb $|| - -;;;_ - Description -;; A full-fledged outline mode, based on the original rudimentary -;; GNU emacs outline functionality. -;; -;; Ken Manheimer Nat'l Inst of Standards and Technology -;; klm@nist.gov (301)975-3539 (Formerly Nat'l Bureau of Standards) -;; NIST Shared File Service Manager and Developer - -;;;_ - Copyright -;; Copyright (C) 1992, 1993 Free Software Foundation, Inc. +;; Author: Ken Manheimer +;; Maintainer: Ken Manheimer +;; Created: Dec 1991 - first release to usenet +;; Keywords: outlines mode wp languages ;; This file is part of GNU Emacs. +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + ;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY. No author or distributor -;; accepts responsibility to anyone for the consequences of using it -;; or for whether it serves any particular purpose or works at all, -;; unless he says so in writing. Refer to the GNU Emacs General Public -;; License for full details. - -;; Everyone is granted permission to copy, modify and redistribute -;; GNU Emacs, but only under the conditions described in the -;; GNU Emacs General Public License. A copy of this license is -;; supposed to have been given to you along with GNU Emacs so you -;; can know your rights and responsibilities. It should be in a -;; file named COPYING. Among other things, the copyright notice -;; and this notice must be preserved on all copies. - -;;;_ + User Customization variables - -;;;_ - Topic Header configuration - -;;;_ = outline-header-prefix -(defvar outline-header-prefix "." - "* Leading string for greater than level 0 topic headers.") -(make-variable-buffer-local 'outline-header-prefix) - -;;;_ = outline-header-subtraction -(defvar outline-header-subtraction (1- (length outline-header-prefix)) - "* Leading string for greater than level 0 topic headers.") -(make-variable-buffer-local 'outline-header-subtraction) - -;;;_ = outline-primary-bullet -(defvar outline-primary-bullet "*") ;; Changing this var disables any - ;; backwards compatibility with - ;; the original outline mode. -(make-variable-buffer-local 'outline-primary-bullet) - -;;;_ = outline-plain-bullets-string -(defvar outline-plain-bullets-string "" - "* The bullets normally used in outline topic prefixes. See - 'outline-distinctive-bullets-string' for the other kind of - bullets. - - DO NOT include the close-square-bracket, ']', among any bullets. - - You must run 'set-outline-regexp' in order for changes to the - value of this var to effect outline-mode operation.") -(setq outline-plain-bullets-string (concat outline-primary-bullet - "+-:.;,")) -(make-variable-buffer-local 'outline-plain-bullets-string) - -;;;_ = outline-distinctive-bullets-string -(defvar outline-distinctive-bullets-string "" - "* The bullets used for distinguishing outline topics. These - bullets are not offered among the regular rotation, and are not - changed when automatically rebulleting, as when shifting the - level of a topic. See 'outline-plain-bullets-string' for the - other kind of bullets. - - DO NOT include the close-square-bracket, ']', among any bullets. - - You must run 'set-outline-regexp' in order for changes - to the value of this var to effect outline-mode operation.") -(setq outline-distinctive-bullets-string "=>([{}&!?#%\"X@$~") -(make-variable-buffer-local 'outline-distinctive-bullets-string) - -;;;_ > outline-numbered-bullet () -(defvar outline-numbered-bullet () - "* Bullet signifying outline prefixes which are to be numbered. - Leave it nil if you don't want any numbering, or set it to a - string with the bullet you want to be used.") -(setq outline-numbered-bullet "#") -(make-variable-buffer-local 'outline-numbered-bullet) - -;;;_ = outline-file-xref-bullet -(defvar outline-file-xref-bullet "@" - "* Set this var to the bullet you want to use for file cross-references. - Set it 'nil' if you want to inhibit this capability.") - -;;;_ - Miscellaneous customization - -;;;_ = outline-stylish-prefixes -(defvar outline-stylish-prefixes t - "*A true value for this var makes the topic-prefix creation and modification - functions vary the prefix bullet char according to level. Otherwise, only - asterisks ('*') and distinctive bullets are used. - - This is how an outline can look with stylish prefixes: - - * Top level - .* A topic - . + One level 3 subtopic - . . One level 4 subtopic - . + Another level 3 subtopic - . . A level 4 subtopic - . #2 A distinguished, numbered level 4 subtopic - . ! A distinguished ('!') level 4 subtopic - . #4 Another numbered level 4 subtopic - - This would be an outline with stylish prefixes inhibited: - - * Top level - .* A topic - .! A distinctive (but measly) subtopic - . * A sub-subtopic - no bullets from outline-plain-bullets-string but '*' - - Stylish and constant prefixes (as well as old-style prefixes) are - always respected by the topic maneuvering functions, regardless of - this variable setting. - - The setting of this var is not relevant when outline-old-style-prefixes - is t.") -(make-variable-buffer-local 'outline-stylish-prefixes) - -;;;_ = outline-old-style-prefixes -(defvar outline-old-style-prefixes nil - "*Setting this var causes the topic-prefix creation and modification - functions to make only asterix-padded prefixes, so they look exactly - like the old style prefixes. - - Both old and new style prefixes are always respected by the topic - maneuvering functions.") -(make-variable-buffer-local 'outline-old-style-prefixes) - -;;;_ = outline-enwrap-isearch-mode - ; Spiffy dynamic-exposure - ; during searches requires - ; Dan LaLiberte's isearch-mode: -(defvar outline-enwrap-isearch-mode "isearch-mode.el" - "* Set this var to the name of the (non-compiled) elisp code for - isearch-mode, if you have Dan LaLiberte's 'isearch-mode' - stuff and want isearches to reveal hidden stuff encountered in the - course of a search, and reconceal it if you go past. Set it nil if - you don't have the package, or don't want to use this feature.") - -;;;_ = outline-use-hanging-indents -(defvar outline-use-hanging-indents t - "* Set this var non-nil if you have Kyle E Jones' filladapt stuff, - and you want outline to fill topics as hanging indents to the - bullets.") -(make-variable-buffer-local 'outline-use-hanging-indents) - -;;;_ = outline-reindent-bodies -(defvar outline-reindent-bodies t - "* Set this var non-nil if you want topic depth adjustments to - reindent hanging bodies (ie, bodies lines indented to beginning of - heading text). The performance hit is small. - - Avoid this strenuously when using outline mode on program code. - It's great for text, though.") -(make-variable-buffer-local 'outline-reindent-bodies) - -;;;_ = outline-mode-keys -;;; You have to restart outline-mode - '(outline-mode t)' - to have -;;; any changes take hold. -(defvar outline-mode-keys () - "Assoc list of outline-mode-keybindings, for common reference in setting -up major and minor-mode keybindings.") -(setq outline-mode-keys +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; Allout outline mode provides extensive outline formatting and +;; and manipulation beyond standard emacs outline mode. It provides +;; for structured editing of outlines, as well as navigation and +;; exposure. It also provides for syntax-sensitive text like +;; programming languages. (For an example, see the allout code +;; itself, which is organized in ;; an outline framework.) +;; +;; In addition to outline navigation and exposure, allout includes: +;; +;; - topic-oriented repositioning, cut, and paste +;; - integral outline exposure-layout +;; - incremental search with dynamic exposure and reconcealment of hidden text +;; - automatic topic-number maintenance +;; - "Hot-spot" operation, for single-keystroke maneuvering and +;; exposure control. (See the `allout-mode' docstring.) +;; +;; and many other features. +;; +;; The outline menubar additions provide quick reference to many of +;; the features, and see the docstring of the function `allout-init' +;; for instructions on priming your Emacs session for automatic +;; activation of `allout-mode'. +;; +;; See the docstring of the variables `allout-layout' and +;; `allout-auto-activation' for details on automatic activation of +;; allout `allout-mode' as a minor mode. (It has changed since allout +;; 3.x, for those of you that depend on the old method.) +;; +;; Note - the lines beginning with `;;;_' are outline topic headers. +;; Just `ESC-x eval-current-buffer' to give it a whirl. + +;; Ken Manheimer klm@zope.com + +;;; Code: + +;;;_* Provide +(provide 'allout) + +;;;_* USER CUSTOMIZATION VARIABLES: +(defgroup allout nil + "Extensive outline mode for use alone and with other modes." + :prefix "allout-" + :group 'editing + :version "22.1") + +;;;_ + Layout, Mode, and Topic Header Configuration + +;;;_ = allout-auto-activation +(defcustom allout-auto-activation nil + "*Regulates auto-activation modality of allout outlines - see `allout-init'. + +Setq-default by `allout-init' to regulate whether or not allout +outline mode is automatically activated when the buffer-specific +variable `allout-layout' is non-nil, and whether or not the layout +dictated by `allout-layout' should be imposed on mode activation. + +With value t, auto-mode-activation and auto-layout are enabled. +\(This also depends on `allout-find-file-hook' being installed in +`find-file-hook', which is also done by `allout-init'.) + +With value `ask', auto-mode-activation is enabled, and endorsement for +performing auto-layout is asked of the user each time. + +With value `activate', only auto-mode-activation is enabled, +auto-layout is not. + +With value nil, neither auto-mode-activation nor auto-layout are +enabled. + +See the docstring for `allout-init' for the proper interface to +this variable." + :type '(choice (const :tag "On" t) + (const :tag "Ask about layout" "ask") + (const :tag "Mode only" "activate") + (const :tag "Off" nil)) + :group 'allout) +;;;_ = allout-layout +(defvar allout-layout nil + "*Layout specification and provisional mode trigger for allout outlines. + +Buffer-specific. + +A list value specifies a default layout for the current buffer, to be +applied upon activation of `allout-mode'. Any non-nil value will +automatically trigger `allout-mode', provided `allout-init' +has been called to enable it. + +See the docstring for `allout-init' for details on setting up for +auto-mode-activation, and for `allout-expose-topic' for the format of +the layout specification. + +You can associate a particular outline layout with a file by setting +this var via the file's local variables. For example, the following +lines at the bottom of an Emacs Lisp file: + +;;;Local variables: +;;;allout-layout: \(0 : -1 -1 0) +;;;End: + +will, modulo the above-mentioned conditions, cause the mode to be +activated when the file is visited, followed by the equivalent of +`\(allout-expose-topic 0 : -1 -1 0)'. \(This is the layout used for +the allout.el, itself.) + +Also, allout's mode-specific provisions will make topic prefixes default +to the comment-start string, if any, of the language of the file. This +is modulo the setting of `allout-use-mode-specific-leader', which see.") +(make-variable-buffer-local 'allout-layout) +;;;_ = allout-show-bodies +(defcustom allout-show-bodies nil + "*If non-nil, show entire body when exposing a topic, rather than +just the header." + :type 'boolean + :group 'allout) +(make-variable-buffer-local 'allout-show-bodies) + +;;;_ = allout-header-prefix +(defcustom allout-header-prefix "." + "*Leading string which helps distinguish topic headers. + +Outline topic header lines are identified by a leading topic +header prefix, which mostly have the value of this var at their front. +\(Level 1 topics are exceptions. They consist of only a single +character, which is typically set to the `allout-primary-bullet'. Many +outlines start at level 2 to avoid this discrepancy." + :type 'string + :group 'allout) +(make-variable-buffer-local 'allout-header-prefix) +;;;_ = allout-primary-bullet +(defcustom allout-primary-bullet "*" + "Bullet used for top-level outline topics. + +Outline topic header lines are identified by a leading topic header +prefix, which is concluded by bullets that includes the value of this +var and the respective allout-*-bullets-string vars. + +The value of an asterisk (`*') provides for backwards compatibility +with the original Emacs outline mode. See `allout-plain-bullets-string' +and `allout-distinctive-bullets-string' for the range of available +bullets." + :type 'string + :group 'allout) +(make-variable-buffer-local 'allout-primary-bullet) +;;;_ = allout-plain-bullets-string +(defcustom allout-plain-bullets-string ".:,;" + "*The bullets normally used in outline topic prefixes. + +See `allout-distinctive-bullets-string' for the other kind of +bullets. + +DO NOT include the close-square-bracket, `]', as a bullet. + +Outline mode has to be reactivated in order for changes to the value +of this var to take effect." + :type 'string + :group 'allout) +(make-variable-buffer-local 'allout-plain-bullets-string) +;;;_ = allout-distinctive-bullets-string +(defcustom allout-distinctive-bullets-string "*+-=>([{}&!?#%\"X@$~_\\" + "*Persistent outline header bullets used to distinguish special topics. + +These bullets are used to distinguish topics from the run-of-the-mill +ones. They are not used in the standard topic headers created by +the topic-opening, shifting, and rebulleting \(eg, on topic shift, +topic paste, blanket rebulleting) routines, but are offered among the +choices for rebulleting. They are not altered by the above automatic +rebulleting, so they can be used to characterize topics, eg: + + `?' question topics + `\(' parenthetic comment \(with a matching close paren inside) + `[' meta-note \(with a matching close ] inside) + `\"' a quote + `=' value settings + `~' \"more or less\" + +... just for example. (`#' typically has a special meaning to the +software, according to the value of `allout-numbered-bullet'.) + +See `allout-plain-bullets-string' for the selection of +alternating bullets. + +You must run `set-allout-regexp' in order for outline mode to +reconcile to changes of this value. + +DO NOT include the close-square-bracket, `]', on either of the bullet +strings." + :type 'string + :group 'allout) +(make-variable-buffer-local 'allout-distinctive-bullets-string) + +;;;_ = allout-use-mode-specific-leader +(defcustom allout-use-mode-specific-leader t + "*When non-nil, use mode-specific topic-header prefixes. + +Allout outline mode will use the mode-specific `allout-mode-leaders' +and/or comment-start string, if any, to lead the topic prefix string, +so topic headers look like comments in the programming language. + +String values are used as they stand. + +Value t means to first check for assoc value in `allout-mode-leaders' +alist, then use comment-start string, if any, then use default \(`.'). +\(See note about use of comment-start strings, below.) + +Set to the symbol for either of `allout-mode-leaders' or +`comment-start' to use only one of them, respectively. + +Value nil means to always use the default \(`.'). + +comment-start strings that do not end in spaces are tripled, and an +`_' underscore is tacked on the end, to distinguish them from regular +comment strings. comment-start strings that do end in spaces are not +tripled, but an underscore is substituted for the space. [This +presumes that the space is for appearance, not comment syntax. You +can use `allout-mode-leaders' to override this behavior, when +incorrect.]" + :type '(choice (const t) (const nil) string + (const allout-mode-leaders) + (const comment-start)) + :group 'allout) +;;;_ = allout-mode-leaders +(defvar allout-mode-leaders '() + "Specific allout-prefix leading strings per major modes. + +Entries will be used instead or in lieu of mode-specific +comment-start strings. See also `allout-use-mode-specific-leader'. + +If you're constructing a string that will comment-out outline +structuring so it can be included in program code, append an extra +character, like an \"_\" underscore, to distinguish the lead string +from regular comments that start at bol.") + +;;;_ = allout-old-style-prefixes +(defcustom allout-old-style-prefixes nil + "*When non-nil, use only old-and-crusty `outline-mode' `*' topic prefixes. + +Non-nil restricts the topic creation and modification +functions to asterix-padded prefixes, so they look exactly +like the original Emacs-outline style prefixes. + +Whatever the setting of this variable, both old and new style prefixes +are always respected by the topic maneuvering functions." + :type 'boolean + :group 'allout) +(make-variable-buffer-local 'allout-old-style-prefixes) +;;;_ = allout-stylish-prefixes - alternating bullets +(defcustom allout-stylish-prefixes t + "*Do fancy stuff with topic prefix bullets according to level, etc. + +Non-nil enables topic creation, modification, and repositioning +functions to vary the topic bullet char (the char that marks the topic +depth) just preceding the start of the topic text) according to level. +Otherwise, only asterisks (`*') and distinctive bullets are used. + +This is how an outline can look (but sans indentation) with stylish +prefixes: + + * Top level + .* A topic + . + One level 3 subtopic + . . One level 4 subtopic + . . A second 4 subtopic + . + Another level 3 subtopic + . #1 A numbered level 4 subtopic + . #2 Another + . ! Another level 4 subtopic with a different distinctive bullet + . #4 And another numbered level 4 subtopic + +This would be an outline with stylish prefixes inhibited (but the +numbered and other distinctive bullets retained): + + * Top level + .* A topic + . * One level 3 subtopic + . * One level 4 subtopic + . * A second 4 subtopic + . * Another level 3 subtopic + . #1 A numbered level 4 subtopic + . #2 Another + . ! Another level 4 subtopic with a different distinctive bullet + . #4 And another numbered level 4 subtopic + +Stylish and constant prefixes (as well as old-style prefixes) are +always respected by the topic maneuvering functions, regardless of +this variable setting. + +The setting of this var is not relevant when `allout-old-style-prefixes' +is non-nil." + :type 'boolean + :group 'allout) +(make-variable-buffer-local 'allout-stylish-prefixes) + +;;;_ = allout-numbered-bullet +(defcustom allout-numbered-bullet "#" + "*String designating bullet of topics that have auto-numbering; nil for none. + +Topics having this bullet have automatic maintenance of a sibling +sequence-number tacked on, just after the bullet. Conventionally set +to \"#\", you can set it to a bullet of your choice. A nil value +disables numbering maintenance." + :type '(choice (const nil) string) + :group 'allout) +(make-variable-buffer-local 'allout-numbered-bullet) +;;;_ = allout-file-xref-bullet +(defcustom allout-file-xref-bullet "@" + "*Bullet signifying file cross-references, for `allout-resolve-xref'. + +Set this var to the bullet you want to use for file cross-references." + :type '(choice (const nil) string) + :group 'allout) + +;;;_ = allout-presentation-padding +(defcustom allout-presentation-padding 2 + "*Presentation-format white-space padding factor, for greater indent." + :type 'integer + :group 'allout) + +(make-variable-buffer-local 'allout-presentation-padding) + +;;;_ = allout-abbreviate-flattened-numbering +(defcustom allout-abbreviate-flattened-numbering nil + "*If non-nil, `allout-flatten-exposed-to-buffer' abbreviates topic +numbers to minimal amount with some context. Otherwise, entire +numbers are always used." + :type 'boolean + :group 'allout) + +;;;_ + LaTeX formatting +;;;_ - allout-number-pages +(defcustom allout-number-pages nil + "*Non-nil turns on page numbering for LaTeX formatting of an outline." + :type 'boolean + :group 'allout) +;;;_ - allout-label-style +(defcustom allout-label-style "\\large\\bf" + "*Font and size of labels for LaTeX formatting of an outline." + :type 'string + :group 'allout) +;;;_ - allout-head-line-style +(defcustom allout-head-line-style "\\large\\sl " + "*Font and size of entries for LaTeX formatting of an outline." + :type 'string + :group 'allout) +;;;_ - allout-body-line-style +(defcustom allout-body-line-style " " + "*Font and size of entries for LaTeX formatting of an outline." + :type 'string + :group 'allout) +;;;_ - allout-title-style +(defcustom allout-title-style "\\Large\\bf" + "*Font and size of titles for LaTeX formatting of an outline." + :type 'string + :group 'allout) +;;;_ - allout-title +(defcustom allout-title '(or buffer-file-name (current-buffer-name)) + "*Expression to be evaluated to determine the title for LaTeX +formatted copy." + :type 'sexp + :group 'allout) +;;;_ - allout-line-skip +(defcustom allout-line-skip ".05cm" + "*Space between lines for LaTeX formatting of an outline." + :type 'string + :group 'allout) +;;;_ - allout-indent +(defcustom allout-indent ".3cm" + "*LaTeX formatted depth-indent spacing." + :type 'string + :group 'allout) + +;;;_ + Miscellaneous customization + +;;;_ = allout-command-prefix +(defcustom allout-command-prefix "\C-c" + "*Key sequence to be used as prefix for outline mode command key bindings." + :type 'string + :group 'allout) + +;;;_ = allout-keybindings-list +;;; You have to reactivate allout-mode - `(allout-mode t)' - to +;;; institute changes to this var. +(defvar allout-keybindings-list () + "*List of `allout-mode' key / function bindings, for `allout-mode-map'. + +String or vector key will be prefaced with `allout-command-prefix', +unless optional third, non-nil element is present.") +(setq allout-keybindings-list '( ; Motion commands: - ("\C-c\C-n" outline-next-visible-heading) - ("\C-c\C-p" outline-previous-visible-heading) - ("\C-c\C-u" outline-up-current-level) - ("\C-c\C-f" outline-forward-current-level) - ("\C-c\C-b" outline-backward-current-level) - ("\C-c\C-a" outline-beginning-of-current-entry) - ("\C-c\C-e" outline-end-of-current-entry) + ("\C-n" allout-next-visible-heading) + ("\C-p" allout-previous-visible-heading) + ("\C-u" allout-up-current-level) + ("\C-f" allout-forward-current-level) + ("\C-b" allout-backward-current-level) + ("\C-a" allout-beginning-of-current-entry) + ("\C-e" allout-end-of-current-entry) ; Exposure commands: - ("\C-c\C-i" outline-show-current-children) - ("\C-c\C-s" outline-show-current-subtree) - ("\C-c\C-h" outline-hide-current-subtree) - ("\C-c\C-o" outline-show-current-entry) - ("\C-c!" outline-show-all) + ("\C-i" allout-show-children) + ("\C-s" allout-show-current-subtree) + ("\C-h" allout-hide-current-subtree) + ("\C-o" allout-show-current-entry) + ("!" allout-show-all) ; Alteration commands: - ("\C-c " open-sibtopic) - ("\C-c." open-subtopic) - ("\C-c," open-supertopic) - ("\C-c'" outline-shift-in) - ("\C-c>" outline-shift-in) - ("\C-c<" outline-shift-out) - ("\C-c\C-m" outline-rebullet-topic) - ("\C-cb" outline-rebullet-current-heading) - ("\C-c#" outline-number-siblings) - ("\C-k" outline-kill-line) - ("\C-y" outline-yank) - ("\M-y" outline-yank-pop) - ("\C-c\C-k" outline-kill-topic) + (" " allout-open-sibtopic) + ("." allout-open-subtopic) + ("," allout-open-supertopic) + ("'" allout-shift-in) + (">" allout-shift-in) + ("<" allout-shift-out) + ("\C-m" allout-rebullet-topic) + ("*" allout-rebullet-current-heading) + ("#" allout-number-siblings) + ("\C-k" allout-kill-line t) + ("\C-y" allout-yank t) + ("\M-y" allout-yank-pop t) + ("\C-k" allout-kill-topic) ; Miscellaneous commands: - ("\C-c@" outline-resolve-xref) - ("\C-cc" outline-copy-exposed))) - -;;;_ + Code - no user customizations below. - -;;;_ #1 Outline Format and Internal Mode Configuration - -;;;_ : Topic header format -;;;_ = outline-regexp -(defvar outline-regexp "" - "* Regular expression to match the beginning of a heading line. - Any line whose beginning matches this regexp is considered a - heading. This var is set according to the user configuration vars - by set-outline-regexp.") -(make-variable-buffer-local 'outline-regexp) -;;;_ = outline-bullets-string -(defvar outline-bullets-string "" - " A string dictating the valid set of outline topic bullets. This - var should *not* be set by the user - it is set by 'set-outline-regexp', - and is composed from the elements of 'outline-plain-bullets-string' - and 'outline-distinctive-bullets-string'.") -(make-variable-buffer-local 'outline-bullets-string) -;;;_ = outline-line-boundary-regexp -(defvar outline-line-boundary-regexp () - " outline-regexp with outline-style beginning of line anchor (ie, - C-j, *or* C-m, for prefixes of hidden topics). This is properly - set when outline-regexp is produced by 'set-outline-regexp', so - that (match-beginning 2) and (match-end 2) delimit the prefix.") -(make-variable-buffer-local 'outline-line-boundary-regexp) -;;;_ = outline-bob-regexp -(defvar outline-bob-regexp () - " Like outline-line-boundary-regexp, this is an outline-regexp for - outline headers at the beginning of the buffer. (match-beginning 2) - and (match-end 2) - delimit the prefix.") -(make-variable-buffer-local 'outline-line-bob-regexp) -;;;_ > outline-reset-header-lead (header-lead) -(defun outline-reset-header-lead (header-lead) - "* Reset the leading string used to identify topic headers." + ;([?\C-\ ] allout-mark-topic) + ("@" allout-resolve-xref) + ("=c" allout-copy-exposed-to-buffer) + ("=i" allout-indented-exposed-to-buffer) + ("=t" allout-latexify-exposed) + ("=p" allout-flatten-exposed-to-buffer))) + +;;;_ = allout-isearch-dynamic-expose +(defcustom allout-isearch-dynamic-expose t + "*Non-nil enable dynamic exposure of hidden incremental-search +targets as they're encountered." + :type 'boolean + :group 'allout) +(make-variable-buffer-local 'allout-isearch-dynamic-expose) + +;;;_ = allout-use-hanging-indents +(defcustom allout-use-hanging-indents t + "*If non-nil, topic body text auto-indent defaults to indent of the header. +Ie, it is indented to be just past the header prefix. This is +relevant mostly for use with indented-text-mode, or other situations +where auto-fill occurs. + +\[This feature no longer depends in any way on the `filladapt.el' +lisp-archive package.\]" + :type 'boolean + :group 'allout) +(make-variable-buffer-local 'allout-use-hanging-indents) + +;;;_ = allout-reindent-bodies +(defcustom allout-reindent-bodies (if allout-use-hanging-indents + 'text) + "*Non-nil enables auto-adjust of topic body hanging indent with depth shifts. + +When active, topic body lines that are indented even with or beyond +their topic header are reindented to correspond with depth shifts of +the header. + +A value of t enables reindent in non-programming-code buffers, ie +those that do not have the variable `comment-start' set. A value of +`force' enables reindent whether or not `comment-start' is set." + :type '(choice (const nil) (const t) (const text) (const force)) + :group 'allout) + +(make-variable-buffer-local 'allout-reindent-bodies) + +;;;_ = allout-inhibit-protection +(defcustom allout-inhibit-protection nil + "*Non-nil disables warnings and confirmation-checks for concealed-text edits. + +Outline mode uses Emacs change-triggered functions to detect unruly +changes to concealed regions. Set this var non-nil to disable the +protection, potentially increasing text-entry responsiveness a bit. + +This var takes effect at `allout-mode' activation, so you may have to +deactivate and then reactivate the mode if you want to toggle the +behavior." + :type 'boolean + :group 'allout) + +;;;_* CODE - no user customizations below. + +;;;_ #1 Internal Outline Formatting and Configuration +;;;_ : Version +;;;_ = allout-version +(defvar allout-version + (let ((rcs-rev "$Revision$")) + (condition-case err + (save-match-data + (string-match "Revision: \\([0-9]+\\.[0-9]+\\)" rcs-rev) + (substring rcs-rev (match-beginning 1) (match-end 1))) + ('error rcs-rev))) + "Revision number of currently loaded outline package. \(allout.el)") +;;;_ > allout-version +(defun allout-version (&optional here) + "Return string describing the loaded outline version." + (interactive "P") + (let ((msg (concat "Allout Outline Mode v " allout-version))) + (if here (insert msg)) + (message "%s" msg) + msg)) +;;;_ : Topic header format +;;;_ = allout-regexp +(defvar allout-regexp "" + "*Regular expression to match the beginning of a heading line. + +Any line whose beginning matches this regexp is considered a +heading. This var is set according to the user configuration vars +by `set-allout-regexp'.") +(make-variable-buffer-local 'allout-regexp) +;;;_ = allout-bullets-string +(defvar allout-bullets-string "" + "A string dictating the valid set of outline topic bullets. + +This var should *not* be set by the user - it is set by `set-allout-regexp', +and is produced from the elements of `allout-plain-bullets-string' +and `allout-distinctive-bullets-string'.") +(make-variable-buffer-local 'allout-bullets-string) +;;;_ = allout-bullets-string-len +(defvar allout-bullets-string-len 0 + "Length of current buffers' `allout-plain-bullets-string'.") +(make-variable-buffer-local 'allout-bullets-string-len) +;;;_ = allout-line-boundary-regexp +(defvar allout-line-boundary-regexp () + "`allout-regexp' with outline style beginning-of-line anchor. + +\(Ie, C-j, *or* C-m, for prefixes of hidden topics). This is properly +set when `allout-regexp' is produced by `set-allout-regexp', so +that (match-beginning 2) and (match-end 2) delimit the prefix.") +(make-variable-buffer-local 'allout-line-boundary-regexp) +;;;_ = allout-bob-regexp +(defvar allout-bob-regexp () + "Like `allout-line-boundary-regexp', for headers at beginning of buffer. +\(match-beginning 2) and \(match-end 2) delimit the prefix.") +(make-variable-buffer-local 'allout-bob-regexp) +;;;_ = allout-header-subtraction +(defvar allout-header-subtraction (1- (length allout-header-prefix)) + "Allout-header prefix length to subtract when computing topic depth.") +(make-variable-buffer-local 'allout-header-subtraction) +;;;_ = allout-plain-bullets-string-len +(defvar allout-plain-bullets-string-len (length allout-plain-bullets-string) + "Length of `allout-plain-bullets-string', updated by `set-allout-regexp'.") +(make-variable-buffer-local 'allout-plain-bullets-string-len) + + +;;;_ X allout-reset-header-lead (header-lead) +(defun allout-reset-header-lead (header-lead) + "*Reset the leading string used to identify topic headers." (interactive "sNew lead string: ") - ;;() - (setq outline-header-prefix header-lead) - (setq outline-header-subtraction (1- (length outline-header-prefix))) - (set-outline-regexp) - ) -;;;_ > outline-lead-with-comment-string (header-lead) -(defun outline-lead-with-comment-string (&optional header-lead) - "* Set the topic-header leading string to specified string. Useful - when for encapsulating outline structure in programming language - comments. Returns the leading string." + (setq allout-header-prefix header-lead) + (setq allout-header-subtraction (1- (length allout-header-prefix))) + (set-allout-regexp)) +;;;_ X allout-lead-with-comment-string (header-lead) +(defun allout-lead-with-comment-string (&optional header-lead) + "*Set the topic-header leading string to specified string. + +Useful when for encapsulating outline structure in programming +language comments. Returns the leading string." (interactive "P") (if (not (stringp header-lead)) (setq header-lead (read-string "String prefix for topic headers: "))) - (setq outline-reindent-bodies nil) - (outline-reset-header-lead header-lead) + (setq allout-reindent-bodies nil) + (allout-reset-header-lead header-lead) header-lead) -;;;_ > set-outline-regexp () -(defun set-outline-regexp () - " Generate proper topic-header regexp form for outline functions, from - outline-plain-bullets-string and outline-distinctive-bullets-string." +;;;_ > allout-infer-header-lead () +(defun allout-infer-header-lead () + "Determine appropriate `allout-header-prefix'. + +Works according to settings of: + + `comment-start' + `allout-header-prefix' (default) + `allout-use-mode-specific-leader' +and `allout-mode-leaders'. + +Apply this via \(re)activation of `allout-mode', rather than +invoking it directly." + (let* ((use-leader (and (boundp 'allout-use-mode-specific-leader) + (if (or (stringp allout-use-mode-specific-leader) + (memq allout-use-mode-specific-leader + '(allout-mode-leaders + comment-start + t))) + allout-use-mode-specific-leader + ;; Oops - garbled value, equate with effect of 't: + t))) + (leader + (cond + ((not use-leader) nil) + ;; Use the explicitly designated leader: + ((stringp use-leader) use-leader) + (t (or (and (memq use-leader '(t allout-mode-leaders)) + ;; Get it from outline mode leaders? + (cdr (assq major-mode allout-mode-leaders))) + ;; ... didn't get from allout-mode-leaders... + (and (memq use-leader '(t comment-start)) + comment-start + ;; Use comment-start, maybe tripled, and with + ;; underscore: + (concat + (if (string= " " + (substring comment-start + (1- (length comment-start)))) + ;; Use comment-start, sans trailing space: + (substring comment-start 0 -1) + (concat comment-start comment-start comment-start)) + ;; ... and append underscore, whichever: + "_"))))))) + (if (not leader) + nil + (if (string= leader allout-header-prefix) + nil ; no change, nothing to do. + (setq allout-header-prefix leader) + allout-header-prefix)))) +;;;_ > allout-infer-body-reindent () +(defun allout-infer-body-reindent () + "Determine proper setting for `allout-reindent-bodies'. + +Depends on default setting of `allout-reindent-bodies' \(which see) +and presence of setting for `comment-start', to tell whether the +file is programming code." + (if (and allout-reindent-bodies + comment-start + (not (eq 'force allout-reindent-bodies))) + (setq allout-reindent-bodies nil))) +;;;_ > set-allout-regexp () +(defun set-allout-regexp () + "Generate proper topic-header regexp form for outline functions. + +Works with respect to `allout-plain-bullets-string' and +`allout-distinctive-bullets-string'." (interactive) - ;; Derive outline-bullets-string from user configured components: - (setq outline-bullets-string "") - (let ((strings (list 'outline-plain-bullets-string - 'outline-distinctive-bullets-string)) + ;; Derive allout-bullets-string from user configured components: + (setq allout-bullets-string "") + (let ((strings (list 'allout-plain-bullets-string + 'allout-distinctive-bullets-string + 'allout-primary-bullet)) cur-string cur-len + cur-char cur-char-string index new-string) @@ -299,8 +674,8 @@ up major and minor-mode keybindings.") (setq cur-len (length (setq cur-string (symbol-value (car strings))))) (while (< index cur-len) (setq cur-char (aref cur-string index)) - (setq outline-bullets-string - (concat outline-bullets-string + (setq allout-bullets-string + (concat allout-bullets-string (cond ; Single dash would denote a ; sequence, repeated denotes @@ -314,172 +689,128 @@ up major and minor-mode keybindings.") (setq index (1+ index))) (setq strings (cdr strings))) ) - ;; Derive next for repeated use in outline-pending-bullet: - (setq outline-plain-bullets-string-len (length outline-plain-bullets-string)) - (setq outline-header-subtraction (1- (length outline-header-prefix))) - ;; Produce the new outline-regexp: - (setq outline-regexp (concat "\\(\\" - outline-header-prefix + ;; Derive next for repeated use in allout-pending-bullet: + (setq allout-plain-bullets-string-len (length allout-plain-bullets-string)) + (setq allout-header-subtraction (1- (length allout-header-prefix))) + ;; Produce the new allout-regexp: + (setq allout-regexp (concat "\\(\\" + allout-header-prefix "[ \t]*[" - outline-bullets-string + allout-bullets-string "]\\)\\|\\" - outline-primary-bullet + allout-primary-bullet "+\\|\^l")) - (setq outline-line-boundary-regexp - (concat "\\([\C-j\C-m]\\)\\(" outline-regexp "\\)")) - (setq outline-bob-regexp - (concat "\\(\\`\\)\\(" outline-regexp "\\)")) - ) - -;;;_ : Key bindings -;;;_ = Generic minor keybindings control -;;;_ ; Stallman's suggestion -(defvar outline-mode-map nil "") - -(if outline-mode-map - nil - (setq outline-mode-map (nconc (make-sparse-keymap) text-mode-map)) - (define-key outline-mode-map "\C-c\C-n" 'outline-next-visible-heading) - (define-key outline-mode-map "\C-c\C-p" 'outline-previous-visible-heading) - (define-key outline-mode-map "\C-c\C-i" 'show-children) - (define-key outline-mode-map "\C-c\C-s" 'show-subtree) - (define-key outline-mode-map "\C-c\C-h" 'hide-subtree) - (define-key outline-mode-map "\C-c\C-u" 'outline-up-heading) - (define-key outline-mode-map "\C-c\C-f" 'outline-forward-same-level) - (define-key outline-mode-map "\C-c\C-b" 'outline-backward-same-level)) - -(defvar outline-minor-mode nil - "Non-nil if using Outline mode as a minor mode of some other mode.") -(make-variable-buffer-local 'outline-minor-mode) -(put 'outline-minor-mode 'permanent-local t) -(setq minor-mode-alist (append minor-mode-alist - (list '(outline-minor-mode " Outl")))) - -(defvar outline-minor-mode-map nil) -(if outline-minor-mode-map - nil - (setq outline-minor-mode-map (make-sparse-keymap)) - (define-key outline-minor-mode-map "\C-c" - (lookup-key outline-mode-map "\C-c"))) - -(or (assq 'outline-minor-mode minor-mode-map-alist) - (setq minor-mode-map-alist - (cons (cons 'outline-minor-mode outline-minor-mode-map) - minor-mode-map-alist))) - -(defun outline-minor-mode (&optional arg) - "Toggle Outline minor mode. -With arg, turn Outline minor mode on if arg is positive, off otherwise. -See the command `outline-mode' for more information on this mode." - (interactive "P") - (setq outline-minor-mode - (if (null arg) (not outline-minor-mode) - (> (prefix-numeric-value arg) 0))) - (if outline-minor-mode - (progn - (setq selective-display t) - (run-hooks 'outline-minor-mode-hook)) - (setq selective-display nil))) -;;;_ ; minor-bind-keys (keys-assoc) -(defun minor-bind-keys (keys-assoc) - " Establish BINDINGS assoc list in current buffer, returning a list - for subsequent use by minor-unbind-keys to resume overloaded local - bindings." - (interactive) - ;; Cycle thru key list, registering prevailing local binding for key, if - ;; any (for prospective resumption by outline-minor-unbind-keys), then - ;; overloading it with outline-mode one. - (let ((local-map (or (current-local-map) - (make-sparse-keymap))) - key new-func unbinding-registry prevailing-func) - (while keys-assoc - (setq curr-key (car (car keys-assoc))) - (setq new-func (car (cdr (car keys-assoc)))) - (setq prevailing-func (local-key-binding curr-key)) - (if (not (symbolp prevailing-func)) - (setq prevailing-func nil)) - ;; Register key being changed, prevailing local binding, & new binding: - (setq unbinding-registry - (cons (list curr-key (local-key-binding curr-key) new-func) - unbinding-registry)) - ; Make the binding: - - (define-key local-map curr-key new-func) - ; Increment for next iteration: - (setq keys-assoc (cdr keys-assoc))) - ; Establish modified map: - (use-local-map local-map) - ; Return the registry: - unbinding-registry) - ) - -;;;_ ; minor-relinquish-keys (unbinding-registry) -(defun minor-relinquish-keys (unbinding-registry) - " Given registry of MODAL-BINDINGS, as produced by minor-bind-keys, - resume the former local keybindings of those keys that retain the - local bindings set by minor-bind-keys. Changed local bindings are - left alone, so other minor (user or modal) bindings are not disrupted. - - Returns a list of those registrations which were not, because of - tampering subsequent to the registration by minor-bind-keys, resumed." - (interactive) - (let (residue curr-item curr-key curr-resume curr-relinquish) - (while unbinding-registry - (setq curr-item (car unbinding-registry)) - (setq curr-key (car curr-item)) - (setq curr-resume (car (cdr curr-item))) - (setq curr-relinquish (car (cdr (cdr curr-item)))) - (if (equal (local-key-binding curr-key) curr-relinquish) - (if curr-resume - ;; Was a local binding to be resumed - do so: - (local-set-key curr-key curr-resume) - (local-unset-key curr-key)) - ;; Bindings been tampered with since registration - leave it be, and - ;; register so on residue list: - (setq residue (cons residue curr-item))) - (setq unbinding-registry (cdr unbinding-registry))) - residue) + (setq allout-line-boundary-regexp + (concat "\\([\n\r]\\)\\(" allout-regexp "\\)")) + (setq allout-bob-regexp + (concat "\\(\\`\\)\\(" allout-regexp "\\)")) ) -;;;_ = outline-minor-prior-keys -(defvar outline-minor-prior-keys () - "Former key bindings assoc-list, for resumption from outline minor-mode.") -(make-variable-buffer-local 'outline-minor-prior-keys) - - ; Both major and minor mode - ; bindings are dictated by - ; this list - put your - ; settings here. -;;;_ > outline-minor-bind-keys () -(defun outline-minor-bind-keys () - " Establish outline-mode keybindings as MINOR modality of current buffer." - (setq outline-minor-prior-keys - (minor-bind-keys outline-mode-keys))) -;;;_ > outline-minor-relinquish-keys () -(defun outline-minor-relinquish-keys () - " Resurrect local keybindings as they were before outline-minor-bind-keys." - (minor-relinquish-keys outline-minor-prior-keys) -) - -;;;_ : Mode-Specific Variables Maintenance -;;;_ = outline-mode-prior-settings -(defvar outline-mode-prior-settings nil - "For internal use by outline mode, registers settings to be resumed -on mode deactivation.") -(make-variable-buffer-local 'outline-mode-prior-settings) -;;;_ > outline-resumptions (name &optional value) -(defun outline-resumptions (name &optional value) - - " Registers information for later reference, or performs resumption of - outline-mode specific values. First arg is NAME of variable affected. - optional second arg is list containing outline-mode-specific VALUE to - be impose on named variable, and to be registered. (It's a list so you - can specify registrations of null values.) If no value is specified, - the registered value is returned (encapsulated in the list, so the - caller can distinguish nil vs no value), and the registration is popped - from the list." - - (let ((on-list (assq name outline-mode-prior-settings)) - prior-capsule ; By 'capsule' i mean a list +;;;_ : Key bindings +;;;_ = allout-mode-map +(defvar allout-mode-map nil "Keybindings for (allout) outline minor mode.") +;;;_ > produce-allout-mode-map (keymap-alist &optional base-map) +(defun produce-allout-mode-map (keymap-list &optional base-map) + "Produce keymap for use as allout-mode-map, from KEYMAP-LIST. + +Built on top of optional BASE-MAP, or empty sparse map if none specified. +See doc string for allout-keybindings-list for format of binding list." + (let ((map (or base-map (make-sparse-keymap))) + (pref (list allout-command-prefix))) + (mapcar (function + (lambda (cell) + (let ((add-pref (null (cdr (cdr cell)))) + (key-suff (list (car cell)))) + (apply 'define-key + (list map + (apply 'concat (if add-pref + (append pref key-suff) + key-suff)) + (car (cdr cell))))))) + keymap-list) + map)) + +;;;_ : Menu bar +(defvar allout-mode-exposure-menu) +(defvar allout-mode-editing-menu) +(defvar allout-mode-navigation-menu) +(defvar allout-mode-misc-menu) +(defun produce-allout-mode-menubar-entries () + (require 'easymenu) + (easy-menu-define allout-mode-exposure-menu + allout-mode-map + "Allout outline exposure menu." + '("Exposure" + ["Show Entry" allout-show-current-entry t] + ["Show Children" allout-show-children t] + ["Show Subtree" allout-show-current-subtree t] + ["Hide Subtree" allout-hide-current-subtree t] + ["Hide Leaves" allout-hide-current-leaves t] + "----" + ["Show All" allout-show-all t])) + (easy-menu-define allout-mode-editing-menu + allout-mode-map + "Allout outline editing menu." + '("Headings" + ["Open Sibling" allout-open-sibtopic t] + ["Open Subtopic" allout-open-subtopic t] + ["Open Supertopic" allout-open-supertopic t] + "----" + ["Shift Topic In" allout-shift-in t] + ["Shift Topic Out" allout-shift-out t] + ["Rebullet Topic" allout-rebullet-topic t] + ["Rebullet Heading" allout-rebullet-current-heading t] + ["Number Siblings" allout-number-siblings t])) + (easy-menu-define allout-mode-navigation-menu + allout-mode-map + "Allout outline navigation menu." + '("Navigation" + ["Next Visible Heading" allout-next-visible-heading t] + ["Previous Visible Heading" + allout-previous-visible-heading t] + "----" + ["Up Level" allout-up-current-level t] + ["Forward Current Level" allout-forward-current-level t] + ["Backward Current Level" + allout-backward-current-level t] + "----" + ["Beginning of Entry" + allout-beginning-of-current-entry t] + ["End of Entry" allout-end-of-current-entry t] + ["End of Subtree" allout-end-of-current-subtree t])) + (easy-menu-define allout-mode-misc-menu + allout-mode-map + "Allout outlines miscellaneous bindings." + '("Misc" + ["Version" allout-version t] + "----" + ["Duplicate Exposed" allout-copy-exposed-to-buffer t] + ["Duplicate Exposed, numbered" + allout-flatten-exposed-to-buffer t] + ["Duplicate Exposed, indented" + allout-indented-exposed-to-buffer t] + "----" + ["Set Header Lead" allout-reset-header-lead t] + ["Set New Exposure" allout-expose-topic t]))) +;;;_ : Mode-Specific Variable Maintenance Utilities +;;;_ = allout-mode-prior-settings +(defvar allout-mode-prior-settings nil + "Internal `allout-mode' use; settings to be resumed on mode deactivation.") +(make-variable-buffer-local 'allout-mode-prior-settings) +;;;_ > allout-resumptions (name &optional value) +(defun allout-resumptions (name &optional value) + + "Registers or resumes settings over `allout-mode' activation/deactivation. + +First arg is NAME of variable affected. Optional second arg is list +containing allout-mode-specific VALUE to be imposed on named +variable, and to be registered. (It's a list so you can specify +registrations of null values.) If no value is specified, the +registered value is returned (encapsulated in the list, so the caller +can distinguish nil vs no value), and the registration is popped +from the list." + + (let ((on-list (assq name allout-mode-prior-settings)) + prior-capsule ; By `capsule' i mean a list ; containing a value, so we can ; distinguish nil from no value. ) @@ -491,12 +822,13 @@ on mode deactivation.") (if on-list nil ; Already preserved prior value - don't mess with it. ;; Register the old value, or nil if previously unbound: - (setq outline-mode-prior-settings + (setq allout-mode-prior-settings (cons (list name (if (boundp name) (list (symbol-value name)))) - outline-mode-prior-settings))) - ; And impose the new value: - (set name (car value))) + allout-mode-prior-settings))) + ; And impose the new value, locally: + (progn (make-local-variable name) + (set name (car value)))) ;; Relinquishing: (if (not on-list) @@ -512,1103 +844,1641 @@ on mode deactivation.") (makunbound name)) ; Previously unbound - demolish var. ; Remove registration: (let (rebuild) - (while outline-mode-prior-settings - (if (not (eq (car outline-mode-prior-settings) + (while allout-mode-prior-settings + (if (not (eq (car allout-mode-prior-settings) on-list)) (setq rebuild - (cons (car outline-mode-prior-settings) + (cons (car allout-mode-prior-settings) rebuild))) - (setq outline-mode-prior-settings - (cdr outline-mode-prior-settings))) - (setq outline-mode-prior-settings rebuild))))) + (setq allout-mode-prior-settings + (cdr allout-mode-prior-settings))) + (setq allout-mode-prior-settings rebuild))))) ) - -;;;_ : Overall -;;;_ = outline-mode -(defvar outline-mode () "Allout outline mode minor-mode flag.") -(make-variable-buffer-local 'outline-mode) -;;;_ > outline-mode (&optional toggle) -(defun outline-mode (&optional toggle) - " Set minor mode for editing outlines with selective display. - - Look below the description of the bindings for explanation of the - terminology use in outline-mode commands. - - (Note - this is not a proper minor mode, because it does affect key - bindings. It's not too improper, however, because it does resurrect - any bindings which have not been tampered with since it changed them.) - -Exposure Commands Movement Commands -C-c C-h outline-hide-current-subtree C-c C-n outline-next-visible-heading -C-c C-i outline-show-current-children C-c C-p outline-previous-visible-heading -C-c C-s outline-show-current-subtree C-c C-u outline-up-current-level -C-c C-o outline-show-current-entry C-c C-f outline-forward-current-level -C-c ! outline-show-all C-c C-b outline-backward-current-level - outline-hide-current-leaves C-c C-e outline-end-of-current-entry - C-c C-a outline-beginning-of-current-entry - - -Topic Header Generation Commands -C-c open-sibtopic Create a new sibling after current topic -C-c . open-subtopic ... an offspring of current topic -C-c , open-supertopic ... a sibling of the current topic's parent - -Level and Prefix Adjustment Commands -C-c > outline-shift-in Shift current topic and all offspring deeper -C-c < outline-shift-out ... less deep -C-c outline-rebullet-topic Reconcile bullets of topic and its offspring - - distinctive bullets are not changed, all - others set suitable according to depth -C-c b outline-rebullet-current-heading Prompt for alternate bullet for - current topic -C-c # outline-number-siblings Number bullets of topic and siblings - the +;;;_ : Mode-specific incidentals +;;;_ = allout-during-write-cue nil +(defvar allout-during-write-cue nil + "Used to inhibit outline change-protection during file write. + +See also `allout-post-command-business', `allout-write-file-hook', +`allout-before-change-protect', and `allout-post-command-business' +functions.") +;;;_ = allout-pre-was-isearching nil +(defvar allout-pre-was-isearching nil + "Cue for isearch-dynamic-exposure mechanism, implemented in +allout-pre- and -post-command-hooks.") +(make-variable-buffer-local 'allout-pre-was-isearching) +;;;_ = allout-isearch-prior-pos nil +(defvar allout-isearch-prior-pos nil + "Cue for isearch-dynamic-exposure tracking, used by `allout-isearch-expose'.") +(make-variable-buffer-local 'allout-isearch-prior-pos) +;;;_ = allout-override-protect nil +(defvar allout-override-protect nil + "Used in `allout-mode' for regulate of concealed-text protection mechanism. + +Allout outline mode regulates alteration of concealed text to protect +against inadvertent, unnoticed changes. This is for use by specific, +native outline functions to temporarily override that protection. +It's automatically reset to nil after every buffer modification.") +(make-variable-buffer-local 'allout-override-protect) +;;;_ > allout-unprotected (expr) +(defmacro allout-unprotected (expression) + "Evaluate EXPRESSION with `allout-override-protect' let-bound to t." + `(let ((allout-override-protect t)) + ,expression)) +;;;_ = allout-undo-aggregation +(defvar allout-undo-aggregation 30 + "Amount of successive self-insert actions to bunch together per undo. + +This is purely a kludge variable, regulating the compensation for a bug in +the way that `before-change-functions' and undo interact.") +(make-variable-buffer-local 'allout-undo-aggregation) +;;;_ = file-var-bug hack +(defvar allout-v18/19-file-var-hack nil + "Horrible hack used to prevent invalid multiple triggering of outline +mode from prop-line file-var activation. Used by `allout-mode' function +to track repeats.") +;;;_ > allout-write-file-hook () +(defun allout-write-file-hook () + "In `allout-mode', run as a `write-contents-functions' activity. + +Currently just sets `allout-during-write-cue', so outline change-protection +knows to keep inactive during file write." + (setq allout-during-write-cue t) + nil) + +;;;_ #2 Mode activation +;;;_ = allout-mode +(defvar allout-mode () "Allout outline mode minor-mode flag.") +(make-variable-buffer-local 'allout-mode) +;;;_ > allout-mode-p () +(defmacro allout-mode-p () + "Return t if `allout-mode' is active in current buffer." + 'allout-mode) +;;;_ = allout-explicitly-deactivated +(defvar allout-explicitly-deactivated nil + "Non-nil if `allout-mode' was last deliberately deactivated. +So `allout-post-command-business' should not reactivate it...") +(make-variable-buffer-local 'allout-explicitly-deactivated) +;;;_ > allout-init (&optional mode) +;;;###autoload +(defun allout-init (&optional mode) + "Prime `allout-mode' to enable/disable auto-activation, wrt `allout-layout'. + +MODE is one of the following symbols: + + - nil \(or no argument) deactivate auto-activation/layout; + - `activate', enable auto-activation only; + - `ask', enable auto-activation, and enable auto-layout but with + confirmation for layout operation solicited from user each time; + - `report', just report and return the current auto-activation state; + - anything else \(eg, t) for auto-activation and auto-layout, without + any confirmation check. + +Use this function to setup your Emacs session for automatic activation +of allout outline mode, contingent to the buffer-specific setting of +the `allout-layout' variable. (See `allout-layout' and +`allout-expose-topic' docstrings for more details on auto layout). + +`allout-init' works by setting up (or removing) +`allout-find-file-hook' in `find-file-hook', and giving +`allout-auto-activation' a suitable setting. + +To prime your Emacs session for full auto-outline operation, include +the following two lines in your Emacs init file: + +\(require 'allout) +\(allout-init t)" + + (interactive + (let ((m (completing-read + (concat "Select outline auto setup mode " + "(empty for report, ? for options) ") + '(("nil")("full")("activate")("deactivate") + ("ask") ("report") ("")) + nil + t))) + (if (string= m "") 'report + (intern-soft m)))) + (let + ;; convenience aliases, for consistent ref to respective vars: + ((hook 'allout-find-file-hook) + (curr-mode 'allout-auto-activation)) + + (cond ((not mode) + (setq find-file-hook (delq hook find-file-hook)) + (if (interactive-p) + (message "Allout outline mode auto-activation inhibited."))) + ((eq mode 'report) + (if (memq hook find-file-hook) + ;; Just punt and use the reports from each of the modes: + (allout-init (symbol-value curr-mode)) + (allout-init nil) + (message "Allout outline mode auto-activation inhibited."))) + (t (add-hook 'find-file-hook hook) + (set curr-mode ; `set', not `setq'! + (cond ((eq mode 'activate) + (message + "Outline mode auto-activation enabled.") + 'activate) + ((eq mode 'report) + ;; Return the current mode setting: + (allout-init mode)) + ((eq mode 'ask) + (message + (concat "Outline mode auto-activation and " + "-layout \(upon confirmation) enabled.")) + 'ask) + ((message + "Outline mode auto-activation and -layout enabled.") + 'full))))))) + +;;;_ > allout-setup-menubar () +(defun allout-setup-menubar () + "Populate the current buffer's menubar with `allout-mode' stuff." + (let ((menus (list allout-mode-exposure-menu + allout-mode-editing-menu + allout-mode-navigation-menu + allout-mode-misc-menu)) + cur) + (while menus + (setq cur (car menus) + menus (cdr menus)) + (easy-menu-add cur)))) +;;;_ > allout-mode (&optional toggle) +;;;_ : Defun: +(defun allout-mode (&optional toggle) +;;;_ . Doc string: + "Toggle minor mode for controlling exposure and editing of text outlines. + +Optional arg forces mode to re-initialize iff arg is positive num or +symbol. Allout outline mode always runs as a minor mode. + +Allout outline mode provides extensive outline oriented formatting and +manipulation. It enables structural editing of outlines, as well as +navigation and exposure. It also is specifically aimed at +accommodating syntax-sensitive text like programming languages. \(For +an example, see the allout code itself, which is organized as an allout +outline.) + +In addition to outline navigation and exposure, allout includes: + + - topic-oriented repositioning, cut, and paste + - integral outline exposure-layout + - incremental search with dynamic exposure and reconcealment of hidden text + - automatic topic-number maintenance + - \"Hot-spot\" operation, for single-keystroke maneuvering and + exposure control. \(See the allout-mode docstring.) + +and many other features. + +Below is a description of the bindings, and then explanation of +special `allout-mode' features and terminology. See also the outline +menubar additions for quick reference to many of the features, and see +the docstring of the function `allout-init' for instructions on +priming your Emacs session for automatic activation of `allout-mode'. + + +The bindings are dictated by the `allout-keybindings-list' and +`allout-command-prefix' variables. + + Navigation: Exposure Control: + ---------- ---------------- +C-c C-n allout-next-visible-heading | C-c C-h allout-hide-current-subtree +C-c C-p allout-previous-visible-heading | C-c C-i allout-show-children +C-c C-u allout-up-current-level | C-c C-s allout-show-current-subtree +C-c C-f allout-forward-current-level | C-c C-o allout-show-current-entry +C-c C-b allout-backward-current-level | ^U C-c C-s allout-show-all +C-c C-e allout-end-of-current-entry | allout-hide-current-leaves +C-c C-a allout-beginning-of-current-entry, alternately, goes to hot-spot + + Topic Header Production: + ----------------------- +C-c allout-open-sibtopic Create a new sibling after current topic. +C-c . allout-open-subtopic ... an offspring of current topic. +C-c , allout-open-supertopic ... a sibling of the current topic's parent. + + Topic Level and Prefix Adjustment: + --------------------------------- +C-c > allout-shift-in Shift current topic and all offspring deeper. +C-c < allout-shift-out ... less deep. +C-c allout-rebullet-topic Reconcile bullets of topic and its offspring + - distinctive bullets are not changed, others + alternated according to nesting depth. +C-c * allout-rebullet-current-heading Prompt for alternate bullet for + current topic. +C-c # allout-number-siblings Number bullets of topic and siblings - the offspring are not affected. With repeat count, revoke numbering. -Killing and Yanking - all keep siblings numbering reconciled as appropriate -C-k outline-kill-line Regular kill line, but respects numbering ,etc -C-c C-k outline-kill-topic Kill current topic, including offspring -C-y outline-yank Yank, adjusting depth of yanked topic to + Topic-oriented Killing and Yanking: + ---------------------------------- +C-c C-k allout-kill-topic Kill current topic, including offspring. +C-k allout-kill-line Like kill-line, but reconciles numbering, etc. +C-y allout-yank Yank, adjusting depth of yanked topic to depth of heading if yanking into bare topic - heading (ie, prefix sans text) -M-y outline-yank-pop Is to outline-yank as yank-pop is to yank - -Misc commands -C-c @ outline-resolve-xref pop-to-buffer named by xref (cf - outline-file-xref-bullet) -C-c c outline-copy-exposed Copy outline sans all hidden stuff to - another buffer whose name is derived - from the current one - \"XXX exposed\" -M-x outlinify-sticky Activate outline mode for current buffer - and establish -*- outline -*- mode specifier - as well as file local vars to automatically - set exposure. Try it. - - Terminology - -Topic: A basic cohesive component of an emacs outline, which can - be closed (made hidden), opened (revealed), generated, - traversed, and shifted as units, using outline-mode functions. - A topic is composed of a HEADER, a BODY, and SUBTOPICs (see below). - -Exposure: Hidden (~closed~) topics are represented by ellipses ('...') - at the end of the visible SUPERTOPIC which contains them, - rather than by their actual text. Hidden topics are still - susceptible to editing and regular movement functions, they - just are not displayed normally, effectively collapsed into - the ellipses which represent them. Outline mode provides - the means to selectively expose topics based on their - NESTING. - - SUBTOPICS of a topic can be hidden and subsequently revealed - based on their DEPTH relative to the supertopic from which - the exposure is being done. - - The BODIES of a topic do not generally become visible except - during exposure of entire subtrees (see documentation for - '-current-subtree'), or when the entry is explicitly exposed - with the 'outline-show-entry' function, or (if you have a - special version of isearch installed) when encountered by - incremental searches. - - The CURRENT topic is the more recent visible one before or - including the text cursor. - -Header: The initial portion of an outline topic. It is composed of a - topic header PREFIX at the beginning of the line, followed by - text to the end of the EFFECTIVE LINE. - -Body: Any subsequent lines of text following a topic header and preceding - the next one. This is also referred to as the entry for a topic. - -Prefix: The text which distinguishes topic headers from normal text - lines. There are two forms, both of which start at the beginning - of the topic header (EFFECTIVE) line. The length of the prefix - represents the DEPTH of the topic. The fundamental sort begins - either with solely an asterisk ('*') or else dot ('.') followed - by zero or more spaces and then an outline BULLET. [Note - you - can now designate your own, arbitrary HEADER-LEAD string, by - setting the variable 'outline-header-prefix'.] The second form - is for backwards compatibility with the original emacs outline - mode, and consists solely of asterisks. Both sorts are - recognized by all outline commands. The first sort is generated - by outline topic production commands if the emacs variable - outline-old-style-prefixes is nil, otherwise the second style is - used. - -Bullet: An outline prefix bullet is one of the characters on either - of the outline bullet string vars, 'outline-plain-bullets-string' - and 'outline-distinctive-bullets-string'. (See their - documentation for more details.) The default choice of bullet - for any prefix depends on the DEPTH of the topic. - -Depth and Nesting: - The length of a topic header prefix, from the initial - character to the bullet (inclusive), represents the depth of - the topic. A topic is considered to contain the subsequent - topics of greater depth up to the next topic of the same - depth, and the contained topics are recursively considered to - be nested within all containing topics. Contained topics are - called subtopics. Immediate subtopics are called 'children'. - Containing topics are supertopicsimmediate supertopics are - 'parents'. Contained topics of the same depth are called - siblings. - -Effective line: The regular ascii text in which form outlines are - saved are manipulated in outline-mode to engage emacs' - selective-display faculty. The upshot is that the - effective end of an outline line can be terminated by - either a normal Unix newline char, \n, or the special - outline-mode eol, ^M. This only matters at the user - level when you're doing searches which key on the end of - line character." - + heading (ie, prefix sans text). +M-y allout-yank-pop Is to allout-yank as yank-pop is to yank + + Misc commands: + ------------- +M-x outlineify-sticky Activate outline mode for current buffer, + and establish a default file-var setting + for `allout-layout'. +C-c C-SPC allout-mark-topic +C-c = c allout-copy-exposed-to-buffer + Duplicate outline, sans concealed text, to + buffer with name derived from derived from + that of current buffer - \"*XXX exposed*\". +C-c = p allout-flatten-exposed-to-buffer + Like above 'copy-exposed', but convert topic + prefixes to section.subsection... numeric + format. +ESC ESC (allout-init t) Setup Emacs session for outline mode + auto-activation. + + HOT-SPOT Operation + +Hot-spot operation provides a means for easy, single-keystroke outline +navigation and exposure control. + +\\ +When the text cursor is positioned directly on the bullet character of +a topic, regular characters (a to z) invoke the commands of the +corresponding allout-mode keymap control chars. For example, \"f\" +would invoke the command typically bound to \"C-c C-f\" +\(\\[allout-forward-current-level] `allout-forward-current-level'). + +Thus, by positioning the cursor on a topic bullet, you can execute +the outline navigation and manipulation commands with a single +keystroke. Non-literal chars never get this special translation, so +you can use them to get away from the hot-spot, and back to normal +operation. + +Note that the command `allout-beginning-of-current-entry' \(\\[allout-beginning-of-current-entry]\) +will move to the hot-spot when the cursor is already located at the +beginning of the current entry, so you can simply hit \\[allout-beginning-of-current-entry] +twice in a row to get to the hot-spot. + + Terminology + +Topic hierarchy constituents - TOPICS and SUBTOPICS: + +TOPIC: A basic, coherent component of an Emacs outline. It can + contain other topics, and it can be subsumed by other topics, +CURRENT topic: + The visible topic most immediately containing the cursor. +DEPTH: The degree of nesting of a topic; it increases with + containment. Also called the: +LEVEL: The same as DEPTH. + +ANCESTORS: + The topics that contain a topic. +PARENT: A topic's immediate ancestor. It has a depth one less than + the topic. +OFFSPRING: + The topics contained by a topic; +SUBTOPIC: + An immediate offspring of a topic; +CHILDREN: + The immediate offspring of a topic. +SIBLINGS: + Topics having the same parent and depth. + +Topic text constituents: + +HEADER: The first line of a topic, include the topic PREFIX and header + text. +PREFIX: The leading text of a topic which distinguishes it from + normal text. It has a strict form, which consists of a + prefix-lead string, padding, and a bullet. The bullet may be + followed by a number, indicating the ordinal number of the + topic among its siblings, a space, and then the header text. + + The relative length of the PREFIX determines the nesting depth + of the topic. +PREFIX-LEAD: + The string at the beginning of a topic prefix, normally a `.'. + It can be customized by changing the setting of + `allout-header-prefix' and then reinitializing `allout-mode'. + + By setting the prefix-lead to the comment-string of a + programming language, you can embed outline structuring in + program code without interfering with the language processing + of that code. See `allout-use-mode-specific-leader' + docstring for more detail. +PREFIX-PADDING: + Spaces or asterisks which separate the prefix-lead and the + bullet, according to the depth of the topic. +BULLET: A character at the end of the topic prefix, it must be one of + the characters listed on `allout-plain-bullets-string' or + `allout-distinctive-bullets-string'. (See the documentation + for these variables for more details.) The default choice of + bullet when generating varies in a cycle with the depth of the + topic. +ENTRY: The text contained in a topic before any offspring. +BODY: Same as ENTRY. + + +EXPOSURE: + The state of a topic which determines the on-screen visibility + of its offspring and contained text. +CONCEALED: + Topics and entry text whose display is inhibited. Contiguous + units of concealed text is represented by `...' ellipses. + (Ref the `selective-display' var.) + + Concealed topics are effectively collapsed within an ancestor. +CLOSED: A topic whose immediate offspring and body-text is concealed. +OPEN: A topic that is not closed, though its offspring or body may be." +;;;_ . Code (interactive "P") - (let* ((active (and (boundp 'outline-mode) outline-mode)) - (toggle (and toggle - (or (and (listp toggle)(car toggle)) - toggle))) - (explicit-activation (and toggle - (or (symbolp toggle) - (and (natnump toggle) - (not (zerop toggle))))))) - + (let* ((active (and (not (equal major-mode 'outline)) + (allout-mode-p))) + ; Massage universal-arg `toggle' val: + (toggle (and toggle + (or (and (listp toggle)(car toggle)) + toggle))) + ; Activation specifically demanded? + (explicit-activation (or + ;; + (and toggle + (or (symbolp toggle) + (and (natnump toggle) + (not (zerop toggle))))))) + ;; allout-mode already called once during this complex command? + (same-complex-command (eq allout-v18/19-file-var-hack + (car command-history))) + do-layout + ) + + ; See comments below re v19.18,.19 bug. + (setq allout-v18/19-file-var-hack (car command-history)) + (cond - ((and (not explicit-activation) (or active toggle)) - ;; Activation not explicitly requested, and either in active - ;; state or deactivation specifically requested: - (outline-minor-relinquish-keys) - (outline-resumptions 'selective-display) - (outline-resumptions 'indent-tabs-mode) - (outline-resumptions 'paragraph-start) - (outline-resumptions 'paragraph-separate) - (setq outline-mode nil)) - - ;; Deactivation *not* indicated. + ;; Provision for v19.18, 19.19 bug - + ;; Emacs v 19.18, 19.19 file-var code invokes prop-line-designated + ;; modes twice when file is visited. We have to avoid toggling mode + ;; off on second invocation, so we detect it as best we can, and + ;; skip everything. + ((and same-complex-command ; Still in same complex command + ; as last time `allout-mode' invoked. + active ; Already activated. + (not explicit-activation) ; Prop-line file-vars don't have args. + (string-match "^19.1[89]" ; Bug only known to be in v19.18 and + emacs-version)); 19.19. + t) + + ;; Deactivation: + ((and (not explicit-activation) + (or active toggle)) + ; Activation not explicitly + ; requested, and either in + ; active state or *de*activation + ; specifically requested: + (setq allout-explicitly-deactivated t) + + (if allout-old-style-prefixes + (progn + (allout-resumptions 'allout-primary-bullet) + (allout-resumptions 'allout-old-style-prefixes))) + (allout-resumptions 'selective-display) + (if (and (boundp 'before-change-functions) before-change-functions) + (allout-resumptions 'before-change-functions)) + (setq write-contents-functions + (delq 'allout-write-file-hook + write-contents-functions)) + (allout-resumptions 'paragraph-start) + (allout-resumptions 'paragraph-separate) + (allout-resumptions (if (string-match "^18" emacs-version) + 'auto-fill-hook + 'auto-fill-function)) + (allout-resumptions 'allout-former-auto-filler) + (setq allout-mode nil)) + + ;; Activation: ((not active) - ;; Not already active - activate: - (outline-minor-bind-keys) - (outline-resumptions 'selective-display '(t)) - (outline-resumptions 'indent-tabs-mode '(nil)) - (or (assq 'outline-mode minor-mode-alist) - (setq minor-mode-alist - (cons '(outline-mode " Outline") minor-mode-alist))) - (set-outline-regexp) - + (setq allout-explicitly-deactivated nil) + (if allout-old-style-prefixes + (progn ; Inhibit all the fancy formatting: + (allout-resumptions 'allout-primary-bullet '("*")) + (allout-resumptions 'allout-old-style-prefixes '(())))) + + (allout-infer-header-lead) + (allout-infer-body-reindent) + + (set-allout-regexp) + + ; Produce map from current version + ; of allout-keybindings-list: + (if (boundp 'minor-mode-map-alist) + + (progn ; V19, and maybe lucid and + ; epoch, minor-mode key bindings: + (setq allout-mode-map + (produce-allout-mode-map allout-keybindings-list)) + (produce-allout-mode-menubar-entries) + (fset 'allout-mode-map allout-mode-map) + ; Include on minor-mode-map-alist, + ; if not already there: + (if (not (member '(allout-mode . allout-mode-map) + minor-mode-map-alist)) + (setq minor-mode-map-alist + (cons '(allout-mode . allout-mode-map) + minor-mode-map-alist)))) + + ; and add them: + (use-local-map (produce-allout-mode-map allout-keybindings-list + (current-local-map))) + ) + + ; selective-display is the + ; Emacs conditional exposure + ; mechanism: + (allout-resumptions 'selective-display '(t)) + (if allout-inhibit-protection + t + (allout-resumptions 'before-change-functions + '(allout-before-change-protect))) + (add-hook 'pre-command-hook 'allout-pre-command-business) + (add-hook 'post-command-hook 'allout-post-command-business) + ; Temporarily set by any outline + ; functions that can be trusted to + ; deal properly with concealed text. + (add-hook 'write-contents-functions 'allout-write-file-hook) + ; Custom auto-fill func, to support + ; respect for topic headline, + ; hanging-indents, etc: + (let* ((fill-func-var (if (string-match "^18" emacs-version) + 'auto-fill-hook + 'auto-fill-function)) + (fill-func (symbol-value fill-func-var))) + ;; Register prevailing fill func for use by allout-auto-fill: + (allout-resumptions 'allout-former-auto-filler (list fill-func)) + ;; Register allout-auto-fill to be used if filling is active: + (allout-resumptions fill-func-var '(allout-auto-fill))) + ;; Paragraphs are broken by topic headlines. (make-local-variable 'paragraph-start) - (outline-resumptions 'paragraph-start - (list (concat paragraph-start "\\|^\\(" - outline-regexp "\\)"))) + (allout-resumptions 'paragraph-start + (list (concat paragraph-start "\\|^\\(" + allout-regexp "\\)"))) (make-local-variable 'paragraph-separate) - (outline-resumptions 'paragraph-separate - (list (concat paragraph-separate "\\|^\\(" - outline-regexp "\\)"))) - - (if outline-enwrap-isearch-mode - (outline-enwrap-isearch)) - (if (and outline-use-hanging-indents - (boundp 'filladapt-prefix-table)) - ;; Add outline-prefix recognition to filladapt - not standard: - (progn (setq filladapt-prefix-table - (cons (cons (concat "\\(" outline-regexp "\\) ") - 'filladapt-hanging-list) - filladapt-prefix-table)) - (setq filladapt-hanging-list-prefixes - (cons outline-regexp - filladapt-hanging-list-prefixes)))) - (run-hooks 'outline-mode-hook) - (setq outline-mode t)) - ) ; cond - ) ; let* - ) ; defun - - -;;;_ #2 Internal Position State-Tracking Variables -;;; All basic outline functions which directly do string matches to + (allout-resumptions 'paragraph-separate + (list (concat paragraph-separate "\\|^\\(" + allout-regexp "\\)"))) + + (or (assq 'allout-mode minor-mode-alist) + (setq minor-mode-alist + (cons '(allout-mode " Allout") minor-mode-alist))) + + (allout-setup-menubar) + + (if allout-layout + (setq do-layout t)) + + (if allout-isearch-dynamic-expose + (allout-enwrap-isearch)) + + (run-hooks 'allout-mode-hook) + (setq allout-mode t)) + + ;; Reactivation: + ((setq do-layout t) + (allout-infer-body-reindent)) + ) ; cond + + (if (and do-layout + allout-auto-activation + (listp allout-layout) + (and (not (eq allout-auto-activation 'activate)) + (if (eq allout-auto-activation 'ask) + (if (y-or-n-p (format "Expose %s with layout '%s'? " + (buffer-name) + allout-layout)) + t + (message "Skipped %s layout." (buffer-name)) + nil) + t))) + (save-excursion + (message "Adjusting '%s' exposure..." (buffer-name)) + (goto-char 0) + (allout-this-or-next-heading) + (condition-case err + (progn + (apply 'allout-expose-topic (list allout-layout)) + (message "Adjusting '%s' exposure... done." (buffer-name))) + ;; Problem applying exposure - notify user, but don't + ;; interrupt, eg, file visit: + (error (message "%s" (car (cdr err))) + (sit-for 1))))) + allout-mode + ) ; let* + ) ; defun +;;;_ > allout-minor-mode +;;; XXX released verion doesn't do this? +(defalias 'allout-minor-mode 'allout-mode) + +;;;_ #3 Internal Position State-Tracking - "allout-recent-*" funcs +;;; All the basic outline functions that directly do string matches to ;;; evaluate heading prefix location set the variables -;;; outline-recent-prefix-beginning and outline-recent-prefix-end when -;;; successful. Functions starting with 'outline-recent-' all use -;;; this state, providing the means to avoid redundant searches for -;;; just established data. This optimization can provide significant -;;; speed improvement, but it must be employed carefully. -;;;_ = outline-recent-prefix-beginning -(defvar outline-recent-prefix-beginning 0 - " Buffer point of the start of the last topic prefix encountered.") -(make-variable-buffer-local 'outline-recent-prefix-beginning) -;;;_ = outline-recent-prefix-end -(defvar outline-recent-prefix-end 0 - " Buffer point of the end of the last topic prefix encountered.") -(make-variable-buffer-local 'outline-recent-prefix-end) - -;;;_ #3 Exposure Control - -;;;_ : Fundamental -;;;_ > outline-flag-region (from to flag) -(defun outline-flag-region (from to flag) - " Hides or shows lines from FROM to TO, according to FLAG. - Uses emacs selective-display, where text is show if FLAG put at - beginning of line is `\\n' (newline character), while text is - hidden if FLAG is `\\^M' (control-M). - - returns nil iff no changes were effected." - (let ((buffer-read-only nil)) - (subst-char-in-region from to - (if (= flag ?\n) ?\^M ?\n) - flag t))) -;;;_ > outline-flag-current-subtree (flag) -(defun outline-flag-current-subtree (flag) - (save-excursion - (outline-back-to-current-heading) - (outline-flag-region (point) - (progn (outline-end-of-current-subtree) (point)) - flag))) - -;;;_ : Topic-specific -;;;_ > outline-hide-current-entry () -(defun outline-hide-current-entry () - "Hide the body directly following this heading." - (interactive) - (outline-back-to-current-heading) - (save-excursion - (outline-flag-region (point) - (progn (outline-end-of-current-entry) (point)) - ?\^M))) -;;;_ > outline-show-current-entry (&optional arg) -(defun outline-show-current-entry (&optional arg) - "Show body directly following this heading, or hide it if repeat count." - (interactive "P") - (if arg - (outline-hide-current-entry) - (save-excursion - (outline-flag-region (point) - (progn (outline-end-of-current-entry) (point)) - ?\n)))) -;;;_ > outline-show-entry () -; outline-show-entry basically for isearch dynamic exposure, as is... -(defun outline-show-entry () - " Like outline-show-current-entry, but reveals an entry that is nested - within hidden topics." - (interactive) - (save-excursion - (outline-goto-prefix) - (outline-flag-region (if (not (bobp)) (1- (point)) (point)) - (progn (outline-pre-next-preface) (point)) ?\n))) -;;;_ > outline-hide-current-entry-completely () -; ... outline-hide-current-entry-completely also for isearch dynamic exposure: -(defun outline-hide-current-entry-completely () - "Like outline-hide-current-entry, but conceal topic completely." - (interactive) - (save-excursion - (outline-goto-prefix) - (outline-flag-region (if (not (bobp)) (1- (point)) (point)) - (progn (outline-pre-next-preface) - (if (looking-at "\C-m") - (point) - (1- (point)))) - ?\C-m))) -;;;_ > outline-show-current-subtree () -(defun outline-show-current-subtree () - "Show everything after this heading at deeper levels." - (interactive) - (outline-flag-current-subtree ?\n)) -;;;_ > outline-hide-current-subtree (&optional just-close) -(defun outline-hide-current-subtree (&optional just-close) - - " Hide everything after this heading at deeper levels, or if it's - already closed, and optional arg JUST-CLOSE is nil, hide the current - level." - - (interactive) - (let ((orig-eol (save-excursion - (end-of-line)(outline-goto-prefix)(end-of-line)(point)))) - (outline-flag-current-subtree ?\^M) - (if (and (= orig-eol (save-excursion (goto-char orig-eol) - (end-of-line) - (point))) - ;; Structure didn't change - try hiding current level: - (if (not just-close) - (outline-up-current-level 1 t))) - (outline-hide-current-subtree)))) -;;;_ > outline-show-current-branches () -(defun outline-show-current-branches () - "Show all subheadings of this heading, but not their bodies." - (interactive) - (outline-show-current-children 1000)) -;;;_ > outline-hide-current-leaves () -(defun outline-hide-current-leaves () - "Hide all body after this heading at deeper levels." - (interactive) - (outline-back-to-current-heading) - (outline-hide-region-body (point) (progn (outline-end-of-current-subtree) - (point)))) -;;;_ > outline-show-current-children (&optional level) -(defun outline-show-current-children (&optional level) - " Show all direct subheadings of this heading. Optional LEVEL specifies - how many levels below the current level should be shown." - (interactive "p") - (or level (setq level 1)) - (save-excursion - (save-restriction - (beginning-of-line) - (setq level (+ level (progn (outline-back-to-current-heading) - (outline-recent-depth)))) - (narrow-to-region (point) - (progn (outline-end-of-current-subtree) (1+ (point)))) - (goto-char (point-min)) - (while (and (not (eobp)) - (outline-next-heading)) - (if (<= (outline-recent-depth) level) - (save-excursion - (let ((end (1+ (point)))) - (forward-char -1) - (if (memq (preceding-char) '(?\n ?\^M)) - (forward-char -1)) - (outline-flag-region (point) end ?\n)))))))) - -;;;_ : Region and beyond -;;;_ > outline-show-all () -(defun outline-show-all () - "Show all of the text in the buffer." - (interactive) - (outline-flag-region (point-min) (point-max) ?\n)) -;;;_ > outline-hide-bodies () -(defun outline-hide-bodies () - "Hide all of buffer except headings." - (interactive) - (outline-hide-region-body (point-min) (point-max))) -;;;_ > outline-hide-region-body (start end) -(defun outline-hide-region-body (start end) - "Hide all body lines in the region, but not headings." - (save-excursion - (save-restriction - (narrow-to-region start end) - (goto-char (point-min)) - (while (not (eobp)) - (outline-flag-region (point) - (progn (outline-pre-next-preface) (point)) ?\^M) - (if (not (eobp)) - (forward-char - (if (looking-at "[\n\^M][\n\^M]") - 2 1))))))) -;;;_ > outline-expose () -(defun outline-expose (spec &rest followers) - - "Dictate wholesale exposure scheme for current topic, according to SPEC. - -SPEC is either a number or a list of specs. Optional successive args -dictate exposure for subsequent siblings of current topic. - -Numbers, the symbols '*' and '+', and the null list dictate different -exposure depths for the corresponding topic. Numbers indicate the -depth to open, with negative numbers first forcing a close, and then -opening to their absolute value. Positive numbers jsut reopen, and 0 -just closes. '*' completely opens the topic, including bodies, and -'+' shows all the sub headers, but not the bodies. - -If the spec is a list, the first element must be a number which -dictates the exposure depth of the topic as a whole. Subsequent -elements of the list are nested SPECs, dictating the specific exposure -for the corresponding offspring of the topic, as the SPEC as a whole -does for the parent topic. - -Optional FOLLOWER elements dictate exposure for subsequent siblings -of the parent topic." - - (interactive "xExposure spec: ") - (save-excursion - (let ((start-point (progn (outline-goto-prefix)(point))) - done) - (cond ((null spec) nil) - ((symbolp spec) - (if (eq spec '*) (outline-show-current-subtree)) - (if (eq spec '+) (outline-show-current-branches))) - ((numberp spec) - (if (zerop spec) - ;; Just hide if zero: - (outline-hide-current-subtree t) - (if (> 0 spec) - ;; Close before opening if negative: - (progn (outline-hide-current-subtree) - (setq spec (* -1 spec)))) - (outline-show-current-children spec))) - ((listp spec) - (outline-expose (car spec)) - (if (and (outline-descend-to-depth (+ (outline-current-depth) 1)) - (not (outline-hidden-p))) - (while (and (setq spec (cdr spec)) - (not done)) - (outline-expose (car spec)) - (setq done (not (outline-next-sibling))))))))) - (while (and followers (outline-next-sibling)) - (outline-expose (car followers)) - (setq followers (cdr followers))) - ) -;;;_ > outline-exposure '() -(defmacro outline-exposure (&rest spec) - " Literal frontend for 'outline-expose', passes arguments unevaluated, - so you needn't quote them." - (cons 'outline-expose (mapcar '(lambda (x) (list 'quote x)) spec))) - -;;;_ #4 Navigation - -;;;_ : Position Assessment - -;;;_ . Residual state - from most recent outline context operation. -;;;_ > outline-recent-depth () -(defun outline-recent-depth () - " Return depth of last heading encountered by an outline maneuvering - function. - - All outline functions which directly do string matches to assess - headings set the variables outline-recent-prefix-beginning and - outline-recent-prefix-end if successful. This function uses those settings - to return the current depth." - - (max 1 - (- outline-recent-prefix-end - outline-recent-prefix-beginning - outline-header-subtraction))) -;;;_ > outline-recent-prefix () -(defun outline-recent-prefix () - " Like outline-recent-depth, but returns text of last encountered prefix. - - All outline functions which directly do string matches to assess - headings set the variables outline-recent-prefix-beginning and - outline-recent-prefix-end if successful. This function uses those settings - to return the current depth." - (buffer-substring outline-recent-prefix-beginning outline-recent-prefix-end)) -;;;_ > outline-recent-bullet () -(defun outline-recent-bullet () - " Like outline-recent-prefix, but returns bullet of last encountered - prefix. - - All outline functions which directly do string matches to assess - headings set the variables outline-recent-prefix-beginning and - outline-recent-prefix-end if successful. This function uses those settings - to return the current depth of the most recently matched topic." - (buffer-substring (1- outline-recent-prefix-end) outline-recent-prefix-end)) - -;;;_ . Active position evaluation - if you can't use the residual state. -;;;_ > outline-on-current-heading-p () -(defun outline-on-current-heading-p () - " Return prefix beginning point if point is on same line as current - visible topic's header line." +;;; `allout-recent-prefix-beginning' and `allout-recent-prefix-end' +;;; when successful. Functions starting with `allout-recent-' all +;;; use this state, providing the means to avoid redundant searches +;;; for just-established data. This optimization can provide +;;; significant speed improvement, but it must be employed carefully. +;;;_ = allout-recent-prefix-beginning +(defvar allout-recent-prefix-beginning 0 + "Buffer point of the start of the last topic prefix encountered.") +(make-variable-buffer-local 'allout-recent-prefix-beginning) +;;;_ = allout-recent-prefix-end +(defvar allout-recent-prefix-end 0 + "Buffer point of the end of the last topic prefix encountered.") +(make-variable-buffer-local 'allout-recent-prefix-end) +;;;_ = allout-recent-end-of-subtree +(defvar allout-recent-end-of-subtree 0 + "Buffer point last returned by `allout-end-of-current-subtree'.") +(make-variable-buffer-local 'allout-recent-end-of-subtree) +;;;_ > allout-prefix-data (beg end) +(defmacro allout-prefix-data (beginning end) + "Register allout-prefix state data - BEGINNING and END of prefix. + +For reference by `allout-recent' funcs. Returns BEGINNING." + `(setq allout-recent-prefix-end ,end + allout-recent-prefix-beginning ,beginning)) +;;;_ > allout-recent-depth () +(defmacro allout-recent-depth () + "Return depth of last heading encountered by an outline maneuvering function. + +All outline functions which directly do string matches to assess +headings set the variables `allout-recent-prefix-beginning' and +`allout-recent-prefix-end' if successful. This function uses those settings +to return the current depth." + + '(max 1 (- allout-recent-prefix-end + allout-recent-prefix-beginning + allout-header-subtraction))) +;;;_ > allout-recent-prefix () +(defmacro allout-recent-prefix () + "Like `allout-recent-depth', but returns text of last encountered prefix. + +All outline functions which directly do string matches to assess +headings set the variables `allout-recent-prefix-beginning' and +`allout-recent-prefix-end' if successful. This function uses those settings +to return the current depth." + '(buffer-substring allout-recent-prefix-beginning + allout-recent-prefix-end)) +;;;_ > allout-recent-bullet () +(defmacro allout-recent-bullet () + "Like allout-recent-prefix, but returns bullet of last encountered prefix. + +All outline functions which directly do string matches to assess +headings set the variables `allout-recent-prefix-beginning' and +`allout-recent-prefix-end' if successful. This function uses those settings +to return the current depth of the most recently matched topic." + '(buffer-substring (1- allout-recent-prefix-end) + allout-recent-prefix-end)) + +;;;_ #4 Navigation + +;;;_ - Position Assessment +;;;_ : Location Predicates +;;;_ > allout-on-current-heading-p () +(defun allout-on-current-heading-p () + "Return non-nil if point is on current visible topics' header line. + +Actually, returns prefix beginning point." (save-excursion (beginning-of-line) - (and (looking-at outline-regexp) - (setq outline-recent-prefix-end (match-end 0) - outline-recent-prefix-beginning (match-beginning 0))))) -;;;_ > outline-hidden-p () -(defun outline-hidden-p () + (and (looking-at allout-regexp) + (allout-prefix-data (match-beginning 0) (match-end 0))))) +;;;_ > allout-on-heading-p () +(defalias 'allout-on-heading-p 'allout-on-current-heading-p) +;;;_ > allout-e-o-prefix-p () +(defun allout-e-o-prefix-p () + "True if point is located where current topic prefix ends, heading begins." + (and (save-excursion (beginning-of-line) + (looking-at allout-regexp)) + (= (point)(save-excursion (allout-end-of-prefix)(point))))) +;;;_ > allout-hidden-p () +(defmacro allout-hidden-p () "True if point is in hidden text." + '(save-excursion + (and (re-search-backward "[\n\r]" () t) + (= ?\r (following-char))))) +;;;_ > allout-visible-p () +(defmacro allout-visible-p () + "True if point is not in hidden text." (interactive) + '(not (allout-hidden-p))) +;;;_ : Location attributes +;;;_ > allout-depth () +(defsubst allout-depth () + "Like `allout-current-depth', but respects hidden as well as visible topics." (save-excursion - (and (re-search-backward "[\C-j\C-m]" (point-min) t) - (looking-at "\C-m")))) -;;;_ > outline-current-depth () -(defun outline-current-depth () - " Return the depth to which the current containing visible topic is - nested in the outline." - (save-excursion - (if (outline-back-to-current-heading) - (max 1 - (- outline-recent-prefix-end - outline-recent-prefix-beginning - outline-header-subtraction)) - 0))) -;;;_ > outline-depth () -(defun outline-depth () - " Like outline-current-depth, but respects hidden as well as visible - topics." - (save-excursion - (if (outline-goto-prefix) - (outline-recent-depth) + (if (allout-goto-prefix) + (allout-recent-depth) (progn - (setq outline-recent-prefix-end (point) - outline-recent-prefix-beginning (point)) - 0)))) -;;;_ > outline-get-current-prefix () -(defun outline-get-current-prefix () - " Topic prefix of the current topic." + ;; Oops, no prefix, zero prefix data: + (allout-prefix-data (point)(point)) + ;; ... and return 0: + 0)))) +;;;_ > allout-current-depth () +(defmacro allout-current-depth () + "Return nesting depth of visible topic most immediately containing point." + '(save-excursion + (if (allout-back-to-current-heading) + (max 1 + (- allout-recent-prefix-end + allout-recent-prefix-beginning + allout-header-subtraction)) + 0))) +;;;_ > allout-get-current-prefix () +(defun allout-get-current-prefix () + "Topic prefix of the current topic." (save-excursion - (if (outline-goto-prefix) - (outline-recent-prefix)))) -;;;_ > outline-get-bullet () -(defun outline-get-bullet () - " Return bullet of containing topic (visible or not)." + (if (allout-goto-prefix) + (allout-recent-prefix)))) +;;;_ > allout-get-bullet () +(defun allout-get-bullet () + "Return bullet of containing topic (visible or not)." (save-excursion - (and (outline-goto-prefix) - (outline-recent-bullet)))) -;;;_ > outline-current-bullet () -(defun outline-current-bullet () - " Return bullet of current (visible) topic heading, or none if none found." + (and (allout-goto-prefix) + (allout-recent-bullet)))) +;;;_ > allout-current-bullet () +(defun allout-current-bullet () + "Return bullet of current (visible) topic heading, or none if none found." (condition-case err (save-excursion - (outline-back-to-current-heading) - (buffer-substring (- outline-recent-prefix-end 1) - outline-recent-prefix-end)) + (allout-back-to-current-heading) + (buffer-substring (- allout-recent-prefix-end 1) + allout-recent-prefix-end)) ;; Quick and dirty provision, ostensibly for missing bullet: - (args-out-of-range nil)) + ('args-out-of-range nil)) ) -;;;_ > outline-get-prefix-bullet (prefix) -(defun outline-get-prefix-bullet (prefix) - " Return the bullet of the header prefix string PREFIX." +;;;_ > allout-get-prefix-bullet (prefix) +(defun allout-get-prefix-bullet (prefix) + "Return the bullet of the header prefix string PREFIX." ;; Doesn't make sense if we're old-style prefixes, but this just ;; oughtn't be called then, so forget about it... - (if (string-match outline-regexp prefix) + (if (string-match allout-regexp prefix) (substring prefix (1- (match-end 0)) (match-end 0)))) +;;;_ > allout-sibling-index (&optional depth) +(defun allout-sibling-index (&optional depth) + "Item number of this prospective topic among its siblings. + +If optional arg DEPTH is greater than current depth, then we're +opening a new level, and return 0. + +If less than this depth, ascend to that depth and count..." + + (save-excursion + (cond ((and depth (<= depth 0) 0)) + ((or (not depth) (= depth (allout-depth))) + (let ((index 1)) + (while (allout-previous-sibling (allout-recent-depth) nil) + (setq index (1+ index))) + index)) + ((< depth (allout-recent-depth)) + (allout-ascend-to-depth depth) + (allout-sibling-index)) + (0)))) +;;;_ > allout-topic-flat-index () +(defun allout-topic-flat-index () + "Return a list indicating point's numeric section.subsect.subsubsect... +Outermost is first." + (let* ((depth (allout-depth)) + (next-index (allout-sibling-index depth)) + (rev-sibls nil)) + (while (> next-index 0) + (setq rev-sibls (cons next-index rev-sibls)) + (setq depth (1- depth)) + (setq next-index (allout-sibling-index depth))) + rev-sibls) + ) -;;;_ : Within Topic -;;;_ > outline-goto-prefix () -(defun outline-goto-prefix () - " Put point at beginning of outline prefix for current topic, visible - or not. - - Returns a list of char address of the beginning of the prefix and the - end of it, or nil if none." - - (cond ((and (or (save-excursion (beginning-of-line) (bobp)) - (memq (preceding-char) '(?\n ?\^M))) - (looking-at outline-regexp)) - (setq outline-recent-prefix-end (match-end 0) - outline-recent-prefix-beginning - (goto-char (match-beginning 0)))) - ((re-search-backward outline-line-boundary-regexp - ;; unbounded search, - ;; stay at limit and return nil if failed: - nil 1) - (setq outline-recent-prefix-end (match-end 2) - outline-recent-prefix-beginning - (goto-char (match-beginning 2)))) - ;; We should be at the beginning of the buffer if the last - ;; condition failed. line-boundary-regexp doesn't cover topic - ;; at bob - Check for it. - ((looking-at outline-regexp) - (setq outline-recent-prefix-end (match-end 0) - outline-recent-prefix-beginning - (goto-char (match-beginning 0))))) - ) -;;;_ > outline-end-of-prefix () -(defun outline-end-of-prefix () - " Position cursor at beginning of header text." - (if (not (outline-goto-prefix)) +;;;_ - Navigation macros +;;;_ > allout-next-heading () +(defsubst allout-next-heading () + "Move to the heading for the topic \(possibly invisible) before this one. + +Returns the location of the heading, or nil if none found." + + (if (and (bobp) (not (eobp))) + (forward-char 1)) + + (if (re-search-forward allout-line-boundary-regexp nil 0) + (allout-prefix-data ; Got valid location state - set vars: + (goto-char (or (match-beginning 2) + allout-recent-prefix-beginning)) + (or (match-end 2) allout-recent-prefix-end)))) +;;;_ : allout-this-or-next-heading +(defun allout-this-or-next-heading () + "Position cursor on current or next heading." + ;; A throwaway non-macro that is defined after allout-next-heading + ;; and usable by allout-mode. + (if (not (allout-goto-prefix)) (allout-next-heading))) +;;;_ > allout-previous-heading () +(defmacro allout-previous-heading () + "Move to the prior \(possibly invisible) heading line. + +Return the location of the beginning of the heading, or nil if not found." + + '(if (bobp) + nil + (allout-goto-prefix) + (if + ;; searches are unbounded and return nil if failed: + (or (re-search-backward allout-line-boundary-regexp nil 0) + (looking-at allout-bob-regexp)) + (progn ; Got valid location state - set vars: + (allout-prefix-data + (goto-char (or (match-beginning 2) + allout-recent-prefix-beginning)) + (or (match-end 2) allout-recent-prefix-end)))))) + +;;;_ - Subtree Charting +;;;_ " These routines either produce or assess charts, which are +;;; nested lists of the locations of topics within a subtree. +;;; +;;; Use of charts enables efficient navigation of subtrees, by +;;; requiring only a single regexp-search based traversal, to scope +;;; out the subtopic locations. The chart then serves as the basis +;;; for assessment or adjustment of the subtree, without redundant +;;; traversal of the structure. + +;;;_ > allout-chart-subtree (&optional levels orig-depth prev-depth) +(defun allout-chart-subtree (&optional levels orig-depth prev-depth) + "Produce a location \"chart\" of subtopics of the containing topic. + +Optional argument LEVELS specifies the depth \(relative to start +depth) for the chart. + +Charts are used to capture outline structure, so that outline altering +routines need assess the structure only once, and then use the chart +for their elaborate manipulations. + +Topics are entered in the chart so the last one is at the car. +The entry for each topic consists of an integer indicating the point +at the beginning of the topic. Charts for offspring consists of a +list containing, recursively, the charts for the respective subtopics. +The chart for a topics' offspring precedes the entry for the topic +itself. + +\(fn &optional LEVELS)" + + ;; The other function parameters are for internal recursion, and should + ;; not be specified by external callers. ORIG-DEPTH is depth of topic at + ;; starting point, and PREV-DEPTH is depth of prior topic." + + (let ((original (not orig-depth)) ; `orig-depth' set only in recursion. + chart curr-depth) + + (if original ; Just starting? + ; Register initial settings and + ; position to first offspring: + (progn (setq orig-depth (allout-depth)) + (or prev-depth (setq prev-depth (1+ orig-depth))) + (allout-next-heading))) + + ;; Loop over the current levels' siblings. Besides being more + ;; efficient than tail-recursing over a level, it avoids exceeding + ;; the typically quite constrained Emacs max-lisp-eval-depth. + ;; + ;; Probably would speed things up to implement loop-based stack + ;; operation rather than recursing for lower levels. Bah. + + (while (and (not (eobp)) + ; Still within original topic? + (< orig-depth (setq curr-depth (allout-recent-depth))) + (cond ((= prev-depth curr-depth) + ;; Register this one and move on: + (setq chart (cons (point) chart)) + (if (and levels (<= levels 1)) + ;; At depth limit - skip sublevels: + (or (allout-next-sibling curr-depth) + ;; or no more siblings - proceed to + ;; next heading at lesser depth: + (while (and (<= curr-depth + (allout-recent-depth)) + (allout-next-heading)))) + (allout-next-heading))) + + ((and (< prev-depth curr-depth) + (or (not levels) + (> levels 0))) + ;; Recurse on deeper level of curr topic: + (setq chart + (cons (allout-chart-subtree (and levels + (1- levels)) + orig-depth + curr-depth) + chart)) + ;; ... then continue with this one. + ) + + ;; ... else nil if we've ascended back to prev-depth. + + ))) + + (if original ; We're at the last sibling on + ; the original level. Position + ; to the end of it: + (progn (and (not (eobp)) (forward-char -1)) + (and (memq (preceding-char) '(?\n ?\r)) + (memq (aref (buffer-substring (max 1 (- (point) 3)) + (point)) + 1) + '(?\n ?\r)) + (forward-char -1)) + (setq allout-recent-end-of-subtree (point)))) + + chart ; (nreverse chart) not necessary, + ; and maybe not preferable. + )) +;;;_ > allout-chart-siblings (&optional start end) +(defun allout-chart-siblings (&optional start end) + "Produce a list of locations of this and succeeding sibling topics. +Effectively a top-level chart of siblings. See `allout-chart-subtree' +for an explanation of charts." + (save-excursion + (if (allout-goto-prefix) + (let ((chart (list (point)))) + (while (allout-next-sibling) + (setq chart (cons (point) chart))) + (if chart (setq chart (nreverse chart))))))) +;;;_ > allout-chart-to-reveal (chart depth) +(defun allout-chart-to-reveal (chart depth) + + "Return a flat list of hidden points in subtree CHART, up to DEPTH. + +Note that point can be left at any of the points on chart, or at the +start point." + + (let (result here) + (while (and (or (eq depth t) (> depth 0)) + chart) + (setq here (car chart)) + (if (listp here) + (let ((further (allout-chart-to-reveal here (or (eq depth t) + (1- depth))))) + ;; We're on the start of a subtree - recurse with it, if there's + ;; more depth to go: + (if further (setq result (append further result))) + (setq chart (cdr chart))) + (goto-char here) + (if (= (preceding-char) ?\r) + (setq result (cons here result))) + (setq chart (cdr chart)))) + result)) +;;;_ X allout-chart-spec (chart spec &optional exposing) +;; (defun allout-chart-spec (chart spec &optional exposing) +;; "Not yet \(if ever) implemented. + +;; Produce exposure directives given topic/subtree CHART and an exposure SPEC. + +;; Exposure spec indicates the locations to be exposed and the prescribed +;; exposure status. Optional arg EXPOSING is an integer, with 0 +;; indicating pending concealment, anything higher indicating depth to +;; which subtopic headers should be exposed, and negative numbers +;; indicating (negative of) the depth to which subtopic headers and +;; bodies should be exposed. + +;; The produced list can have two types of entries. Bare numbers +;; indicate points in the buffer where topic headers that should be +;; exposed reside. + +;; - bare negative numbers indicates that the topic starting at the +;; point which is the negative of the number should be opened, +;; including their entries. +;; - bare positive values indicate that this topic header should be +;; opened. +;; - Lists signify the beginning and end points of regions that should +;; be flagged, and the flag to employ. (For concealment: `\(\?r\)', and +;; exposure:" +;; (while spec +;; (cond ((listp spec) +;; ) +;; ) +;; (setq spec (cdr spec))) +;; ) + +;;;_ - Within Topic +;;;_ > allout-goto-prefix () +(defun allout-goto-prefix () + "Put point at beginning of immediately containing outline topic. + +Goes to most immediate subsequent topic if none immediately containing. + +Not sensitive to topic visibility. + +Returns the point at the beginning of the prefix, or nil if none." + + (let (done) + (while (and (not done) + (re-search-backward "[\n\r]" nil 1)) + (forward-char 1) + (if (looking-at allout-regexp) + (setq done (allout-prefix-data (match-beginning 0) + (match-end 0))) + (forward-char -1))) + (if (bobp) + (cond ((looking-at allout-regexp) + (allout-prefix-data (match-beginning 0)(match-end 0))) + ((allout-next-heading)) + (done)) + done))) +;;;_ > allout-end-of-prefix () +(defun allout-end-of-prefix (&optional ignore-decorations) + "Position cursor at beginning of header text. + +If optional IGNORE-DECORATIONS is non-nil, put just after bullet, +otherwise skip white space between bullet and ensuing text." + + (if (not (allout-goto-prefix)) nil (let ((match-data (match-data))) (goto-char (match-end 0)) - (while (looking-at "[0-9]") (forward-char 1)) - (if (and (not (eolp)) (looking-at "\\s-")) (forward-char 1)) + (if ignore-decorations + t + (while (looking-at "[0-9]") (forward-char 1)) + (if (and (not (eolp)) (looking-at "\\s-")) (forward-char 1))) (store-match-data match-data)) ;; Reestablish where we are: - (outline-current-depth)) - ) -;;;_ > outline-back-to-current-heading () -(defun outline-back-to-current-heading () - " Move to heading line of current visible topic, or beginning of heading - if already on visible heading line." + (allout-current-depth))) +;;;_ > allout-current-bullet-pos () +(defun allout-current-bullet-pos () + "Return position of current \(visible) topic's bullet." + + (if (not (allout-current-depth)) + nil + (1- (match-end 0)))) +;;;_ > allout-back-to-current-heading () +(defun allout-back-to-current-heading () + "Move to heading line of current topic, or beginning if already on the line." + (beginning-of-line) - (prog1 (or (outline-on-current-heading-p) - (and (re-search-backward (concat "^\\(" outline-regexp "\\)") + (prog1 (or (allout-on-current-heading-p) + (and (re-search-backward (concat "^\\(" allout-regexp "\\)") nil 'move) - (setq outline-recent-prefix-end (match-end 1) - outline-recent-prefix-beginning (match-beginning 1)))) - (if (interactive-p) (outline-end-of-prefix)) - ) - ) -;;;_ > outline-pre-next-preface () -(defun outline-pre-next-preface () + (allout-prefix-data (match-beginning 1)(match-end 1)))) + (if (interactive-p) (allout-end-of-prefix)))) +;;;_ > allout-back-to-heading () +(defalias 'allout-back-to-heading 'allout-back-to-current-heading) +;;;_ > allout-pre-next-preface () +(defun allout-pre-next-preface () "Skip forward to just before the next heading line. - Returns that character position." +Returns that character position." - (if (re-search-forward outline-line-boundary-regexp nil 'move) - (progn (goto-char (match-beginning 0)) - (setq outline-recent-prefix-end (match-end 2) - outline-recent-prefix-beginning (match-beginning 2)))) - ) -;;;_ > outline-end-of-current-subtree () -(defun outline-end-of-current-subtree () - " Put point at the end of the last leaf in the currently visible topic." + (if (re-search-forward allout-line-boundary-regexp nil 'move) + (prog1 (goto-char (match-beginning 0)) + (allout-prefix-data (match-beginning 2)(match-end 2))))) +;;;_ > allout-end-of-current-subtree () +(defun allout-end-of-current-subtree () + "Put point at the end of the last leaf in the currently visible topic." (interactive) - (outline-back-to-current-heading) - (let ((opoint (point)) - (level (outline-recent-depth))) - (outline-next-heading) + (allout-back-to-current-heading) + (let ((level (allout-recent-depth))) + (allout-next-heading) (while (and (not (eobp)) - (> (outline-recent-depth) level)) - (outline-next-heading)) - (if (not (eobp)) (forward-char -1)) - (if (memq (preceding-char) '(?\n ?\^M)) (forward-char -1)))) -;;;_ > outline-beginning-of-current-entry () -(defun outline-beginning-of-current-entry () - " Position the point at the beginning of the body of the current topic." + (> (allout-recent-depth) level)) + (allout-next-heading)) + (and (not (eobp)) (forward-char -1)) + (and (memq (preceding-char) '(?\n ?\r)) + (memq (aref (buffer-substring (max 1 (- (point) 3)) (point)) 1) + '(?\n ?\r)) + (forward-char -1)) + (setq allout-recent-end-of-subtree (point)))) +;;;_ > allout-beginning-of-current-entry () +(defun allout-beginning-of-current-entry () + "When not already there, position point at beginning of current topic's body. + +If already there, move cursor to bullet for hot-spot operation. +\(See `allout-mode' doc string for details on hot-spot operation.)" (interactive) - (outline-end-of-prefix)) -;;;_ > outline-beginning-of-current-entry () -(defun outline-end-of-current-entry () - " Position the point at the end of the current topic's entry." + (let ((start-point (point))) + (allout-end-of-prefix) + (if (and (interactive-p) + (= (point) start-point)) + (goto-char (allout-current-bullet-pos))))) +;;;_ > allout-end-of-current-entry () +(defun allout-end-of-current-entry () + "Position the point at the end of the current topics' entry." (interactive) - (outline-show-entry) - (prog1 (outline-pre-next-preface) + (allout-show-entry) + (prog1 (allout-pre-next-preface) (if (and (not (bobp))(looking-at "^$")) - (forward-char -1))) -) - -;;;_ : Depth-wise -;;;_ > outline-ascend-to-depth (depth) -(defun outline-ascend-to-depth (depth) - " Ascend to depth DEPTH, returning depth if successful, nil if not." - (if (and (> depth 0)(<= depth (outline-depth))) + (forward-char -1)))) +;;;_ > allout-end-of-current-heading () +(defun allout-end-of-current-heading () + (interactive) + (allout-beginning-of-current-entry) + (forward-line -1) + (end-of-line)) +(defalias 'allout-end-of-heading 'allout-end-of-current-heading) + +;;;_ - Depth-wise +;;;_ > allout-ascend-to-depth (depth) +(defun allout-ascend-to-depth (depth) + "Ascend to depth DEPTH, returning depth if successful, nil if not." + (if (and (> depth 0)(<= depth (allout-depth))) (let ((last-good (point))) - (while (and (< depth (outline-depth)) + (while (and (< depth (allout-depth)) (setq last-good (point)) - (outline-beginning-of-level) - (outline-previous-heading))) - (if (= (outline-recent-depth) depth) - (progn (goto-char outline-recent-prefix-beginning) + (allout-beginning-of-level) + (allout-previous-heading))) + (if (= (allout-recent-depth) depth) + (progn (goto-char allout-recent-prefix-beginning) depth) - (goto-char last-good) - nil)) - (if (interactive-p) (outline-end-of-prefix)) - ) - ) -;;;_ > outline-descend-to-depth (depth) -(defun outline-descend-to-depth (depth) - " Descend to depth DEPTH within current topic, returning depth if - successful, nil if not." + (goto-char last-good))))) +;;;_ > allout-ascend () +(defun allout-ascend () + "Ascend one level, returning t if successful, nil if not." + (if (allout-beginning-of-level) + (allout-previous-heading))) +;;;_ > allout-descend-to-depth (depth) +(defun allout-descend-to-depth (depth) + "Descend to depth DEPTH within current topic. + +Returning depth if successful, nil if not." (let ((start-point (point)) - (start-depth (outline-depth))) + (start-depth (allout-depth))) (while - (and (> (outline-depth) 0) - (not (= depth (outline-recent-depth))) ; ... not there yet - (outline-next-heading) ; ... go further - (< start-depth (outline-recent-depth)))) ; ... still in topic - (if (and (> (outline-depth) 0) - (= (outline-recent-depth) depth)) + (and (> (allout-depth) 0) + (not (= depth (allout-recent-depth))) ; ... not there yet + (allout-next-heading) ; ... go further + (< start-depth (allout-recent-depth)))) ; ... still in topic + (if (and (> (allout-depth) 0) + (= (allout-recent-depth) depth)) depth (goto-char start-point) nil)) ) -;;;_ > outline-up-current-level (arg &optional dont-complain) -(defun outline-up-current-level (arg &optional dont-complain) - " Move to the heading line of which the present line is a subheading. - With argument, move up ARG levels. Don't return an error if - second, optional argument DONT-COMPLAIN, is non-nil." - (interactive "p") - (outline-back-to-current-heading) - (let ((present-level (outline-recent-depth))) +;;;_ > allout-up-current-level (arg &optional dont-complain) +(defun allout-up-current-level (arg &optional dont-complain interactive) + "Move out ARG levels from current visible topic. + +Positions on heading line of containing topic. Error if unable to +ascend that far, or nil if unable to ascend but optional arg +DONT-COMPLAIN is non-nil." + (interactive "p\np") + (allout-back-to-current-heading) + (let ((present-level (allout-recent-depth)) + (last-good (point)) + failed + return) ;; Loop for iterating arg: - (while (and (> (outline-recent-depth) 1) + (while (and (> (allout-recent-depth) 1) (> arg 0) - (not (bobp))) + (not (bobp)) + (not failed)) + (setq last-good (point)) ;; Loop for going back over current or greater depth: - (while (and (not (< (outline-recent-depth) present-level)) - (outline-previous-visible-heading 1))) - (setq present-level (outline-current-depth)) + (while (and (not (< (allout-recent-depth) present-level)) + (or (allout-previous-visible-heading 1) + (not (setq failed present-level))))) + (setq present-level (allout-current-depth)) (setq arg (- arg 1))) - ) - (prog1 (if (<= arg 0) - outline-recent-prefix-beginning - (if (interactive-p) (outline-end-of-prefix)) - (if (not dont-complain) - (error "Can't ascend past outermost level."))) - (if (interactive-p) (outline-end-of-prefix))) - ) - -;;;_ : Linear -;;;_ > outline-next-visible-heading (arg) -(defun outline-next-visible-heading (arg) - " Move to the next visible heading line. + (if (or failed + (> arg 0)) + (progn (goto-char last-good) + (if interactive (allout-end-of-prefix)) + (if (not dont-complain) + (error "Can't ascend past outermost level") + (if interactive (allout-end-of-prefix)) + nil)) + (if interactive (allout-end-of-prefix)) + allout-recent-prefix-beginning))) - With argument, repeats, backward if negative." - (interactive "p") - (if (< arg 0) (beginning-of-line) (end-of-line)) - (if (re-search-forward (concat "^\\(" outline-regexp "\\)") - nil - 'go - arg) - (progn (outline-end-of-prefix) - (setq outline-recent-prefix-end (match-end 1) - outline-recent-prefix-beginning (match-beginning 1)))) - ) -;;;_ > outline-previous-visible-heading (arg) -(defun outline-previous-visible-heading (arg) - " Move to the previous heading line. +;;;_ - Linear +;;;_ > allout-next-sibling (&optional depth backward) +(defun allout-next-sibling (&optional depth backward) + "Like `allout-forward-current-level', but respects invisible topics. - With argument, repeats or can move forward if negative. - A heading line is one that starts with a `*' (or that outline-regexp - matches)." - (interactive "p") - (outline-next-visible-heading (- arg)) - ) -;;;_ > outline-next-heading (&optional backward) -(defun outline-next-heading (&optional backward) - " Move to the heading for the topic (possibly invisible) before this one. +Traverse at optional DEPTH, or current depth if none specified. - Optional arg BACKWARD means search for most recent prior heading. +Go backward if optional arg BACKWARD is non-nil. - Returns the location of the heading, or nil if none found." +Return depth if successful, nil otherwise." (if (and backward (bobp)) nil - (if backward (outline-goto-prefix) - (if (and (bobp) (not (eobp))) - (forward-char 1))) - - (if (if backward - ;; searches are unbounded and return nil if failed: - (or (re-search-backward outline-line-boundary-regexp - nil - 0) - (looking-at outline-bob-regexp)) - (re-search-forward outline-line-boundary-regexp - nil - 0)) - (progn;; Got some valid location state - set vars: - (setq outline-recent-prefix-end - (or (match-end 2) outline-recent-prefix-end)) - (goto-char (setq outline-recent-prefix-beginning - (or (match-beginning 2) - outline-recent-prefix-beginning)))) - ) - ) - ) -;;;_ > outline-previous-heading () -(defun outline-previous-heading () - " Move to the next (possibly invisible) heading line. - - Optional repeat-count arg means go that number of headings. - - Return the location of the beginning of the heading, or nil if not found." - - (outline-next-heading t) - ) -;;;_ > outline-next-sibling (&optional backward) -(defun outline-next-sibling (&optional backward) - " Like outline-forward-current-level, but respects invisible topics. - - Go backward if optional arg BACKWARD is non-nil. - - Return depth if successful, nil otherwise." - - (if (and backward (bobp)) - nil - (let ((start-depth (outline-depth)) + (let ((start-depth (or depth (allout-depth))) (start-point (point)) - last-good) + last-depth) (while (and (not (if backward (bobp) (eobp))) - (if backward (outline-previous-heading) - (outline-next-heading)) - (> (outline-recent-depth) start-depth))) + (if backward (allout-previous-heading) + (allout-next-heading)) + (> (setq last-depth (allout-recent-depth)) start-depth))) (if (and (not (eobp)) - (and (> (outline-depth) 0) - (= (outline-recent-depth) start-depth))) - outline-recent-prefix-beginning + (and (> (or last-depth (allout-depth)) 0) + (= (allout-recent-depth) start-depth))) + allout-recent-prefix-beginning (goto-char start-point) - nil) - ) - ) - ) -;;;_ > outline-previous-sibling (&optional arg) -(defun outline-previous-sibling (&optional arg) - " Like outline-forward-current-level, but goes backwards and respects - invisible topics. + (if depth (allout-depth) start-depth) + nil)))) +;;;_ > allout-previous-sibling (&optional depth backward) +(defun allout-previous-sibling (&optional depth backward) + "Like `allout-forward-current-level', but backwards & respect invisible topics. - Optional repeat count means go number backward. +Optional DEPTH specifies depth to traverse, default current depth. - Note that the beginning of a level is (currently) defined by this - implementation to be the first of previous successor topics of - equal or greater depth. +Optional BACKWARD reverses direction. - Return depth if successful, nil otherwise." - (outline-next-sibling t) - ) -;;;_ > outline-beginning-of-level () -(defun outline-beginning-of-level () - " Go back to the first sibling at this level, visible or not." - (outline-end-of-level 'backward)) -;;;_ > outline-end-of-level (&optional backward) -(defun outline-end-of-level (&optional backward) - " Go to the last sibling at this level, visible or not." - - (while (outline-previous-sibling)) - (prog1 (outline-recent-depth) - (if (interactive-p) (outline-end-of-prefix))) -) -;;;_ > outline-forward-current-level (arg &optional backward) -(defun outline-forward-current-level (arg &optional backward) - " Position the point at the next heading of the same level, taking - optional repeat-count. - - Returns that position, else nil if is not found." - (interactive "p") - (outline-back-to-current-heading) - (let ((amt (if arg (if (< arg 0) - ;; Negative arg - invert direction. - (progn (setq backward (not backward)) - (abs arg)) - arg);; Positive arg - just use it. - 1)));; No arg - use 1: - (while (and (> amt 0) - (outline-next-sibling backward)) - (setq amt (1- amt))) - (if (interactive-p) (outline-end-of-prefix)) - (if (> amt 0) - (error "This is the %s topic on level %d." - (if backward "first" "last") - (outline-current-depth)) - t) - ) +Return depth if successful, nil otherwise." + (allout-next-sibling depth (not backward)) ) -;;;_ > outline-backward-current-level (arg) -(defun outline-backward-current-level (arg) - " Position the point at the previous heading of the same level, taking - optional repeat-count. +;;;_ > allout-snug-back () +(defun allout-snug-back () + "Position cursor at end of previous topic. + +Presumes point is at the start of a topic prefix." + (if (or (bobp) (eobp)) + nil + (forward-char -1)) + (if (or (bobp) (not (memq (preceding-char) '(?\n ?\r)))) + nil + (forward-char -1) + (if (or (bobp) (not (memq (preceding-char) '(?\n ?\r)))) + (forward-char -1))) + (point)) +;;;_ > allout-beginning-of-level () +(defun allout-beginning-of-level () + "Go back to the first sibling at this level, visible or not." + (allout-end-of-level 'backward)) +;;;_ > allout-end-of-level (&optional backward) +(defun allout-end-of-level (&optional backward) + "Go to the last sibling at this level, visible or not." + + (let ((depth (allout-depth))) + (while (allout-previous-sibling depth nil)) + (prog1 (allout-recent-depth) + (allout-end-of-prefix)))) +;;;_ > allout-next-visible-heading (arg) +(defun allout-next-visible-heading (arg) + "Move to the next ARG'th visible heading line, backward if arg is negative. + +Move as far as possible in indicated direction \(beginning or end of +buffer) if headings are exhausted." - Returns that position, else nil if is not found." (interactive "p") - (unwind-protect - (outline-forward-current-level arg t) - (outline-end-of-prefix)) -) - -;;;_ : Search with Dynamic Exposure (requires isearch-mode) -;;;_ = outline-search-reconceal -(defvar outline-search-reconceal nil - "Used for outline isearch provisions, to track whether current search -match was concealed outside of search. The value is the location of the -match, if it was concealed, regular if the entire topic was concealed, in -a list if the entry was concealed.") -;;;_ = outline-search-quitting -(defconst outline-search-quitting nil - "Variable used by isearch-terminate/outline-provisions and -isearch-done/outline-provisions to distinguish between a conclusion -and cancellation of a search.") - -;;;_ > outline-enwrap-isearch () -(defun outline-enwrap-isearch () - " Impose isearch-mode wrappers so isearch progressively exposes and - reconceals hidden topics when working in outline mode, but works - elsewhere. - - The function checks to ensure that the rebindings are done only once." - - ; Should isearch-mode be employed, - (if (or (not outline-enwrap-isearch-mode) - ; or are preparations already done? - (fboundp 'real-isearch-terminate)) - - ;; ... no - skip this all: + (let* ((backward (if (< arg 0) (setq arg (* -1 arg)))) + (step (if backward -1 1)) + (start-point (point)) + prev got) + + (while (> arg 0) ; limit condition + (while (and (not (if backward (bobp)(eobp))) ; boundary condition + ;; Move, skipping over all those concealed lines: + (< -1 (forward-line step)) + (not (setq got (looking-at allout-regexp))))) + ;; Register this got, it may be the last: + (if got (setq prev got)) + (setq arg (1- arg))) + (cond (got ; Last move was to a prefix: + (allout-prefix-data (match-beginning 0) (match-end 0)) + (allout-end-of-prefix)) + (prev ; Last move wasn't, but prev was: + (allout-prefix-data (match-beginning 0) (match-end 0))) + ((not backward) (end-of-line) nil)))) +;;;_ > allout-previous-visible-heading (arg) +(defun allout-previous-visible-heading (arg) + "Move to the previous heading line. + +With argument, repeats or can move forward if negative. +A heading line is one that starts with a `*' (or that `allout-regexp' +matches)." + (interactive "p") + (allout-next-visible-heading (- arg))) +;;;_ > allout-forward-current-level (arg) +(defun allout-forward-current-level (arg &optional interactive) + "Position point at the next heading of the same level. + +Takes optional repeat-count, goes backward if count is negative. + +Returns resulting position, else nil if none found." + (interactive "p\np") + (let ((start-depth (allout-current-depth)) + (start-point (point)) + (start-arg arg) + (backward (> 0 arg)) + last-depth + (last-good (point)) + at-boundary) + (if (= 0 start-depth) + (error "No siblings, not in a topic...")) + (if backward (setq arg (* -1 arg))) + (while (not (or (zerop arg) + at-boundary)) + (while (and (not (if backward (bobp) (eobp))) + (if backward (allout-previous-visible-heading 1) + (allout-next-visible-heading 1)) + (> (setq last-depth (allout-recent-depth)) start-depth))) + (if (and last-depth (= last-depth start-depth) + (not (if backward (bobp) (eobp)))) + (setq last-good (point) + arg (1- arg)) + (setq at-boundary t))) + (if (and (not (eobp)) + (= arg 0) + (and (> (or last-depth (allout-depth)) 0) + (= (allout-recent-depth) start-depth))) + allout-recent-prefix-beginning + (goto-char last-good) + (if (not interactive) + nil + (allout-end-of-prefix) + (error "Hit %s level %d topic, traversed %d of %d requested" + (if backward "first" "last") + (allout-recent-depth) + (- (abs start-arg) arg) + (abs start-arg)))))) +;;;_ > allout-backward-current-level (arg) +(defun allout-backward-current-level (arg &optional interactive) + "Inverse of `allout-forward-current-level'." + (interactive "p\np") + (if interactive + (let ((current-prefix-arg (* -1 arg))) + (call-interactively 'allout-forward-current-level)) + (allout-forward-current-level (* -1 arg)))) + +;;;_ #5 Alteration + +;;;_ - Fundamental +;;;_ > allout-before-change-protect (beg end) +(defun allout-before-change-protect (beg end) + "Outline before-change hook, regulates changes to concealed text. + +Reveal concealed text that would be changed by current command, and +offer user choice to commit or forego the change. Unchanged text is +reconcealed. User has option to have changed text reconcealed. + +Undo commands are specially treated - the user is not prompted for +choice, the undoes are always committed (based on presumption that the +things being undone were already subject to this regulation routine), +and undoes always leave the changed stuff exposed. + +Changes to concealed regions are ignored while file is being written. +\(This is for the sake of functions that do change the file during +writes, like crypt and zip modes.) + +Locally bound in outline buffers to `before-change-functions', which +in Emacs 19 is run before any change to the buffer. + +Any functions which set [`this-command' to `undo', or which set] +`allout-override-protect' non-nil (as does, eg, allout-flag-chars) +are exempt from this restriction." + (if (and (allout-mode-p) + ; allout-override-protect + ; set by functions that know what + ; they're doing, eg outline internals: + (not allout-override-protect) + (not allout-during-write-cue) + (save-match-data ; Preserve operation position state. + ; Both beginning and end chars must + ; be exposed: + (save-excursion (if (memq this-command '(newline open-line)) + ;; Compensate for stupid Emacs {new, + ;; open-}line display optimization: + (setq beg (1+ beg) + end (1+ end))) + (goto-char beg) + (or (allout-hidden-p) + (and (not (= beg end)) + (goto-char end) + (allout-hidden-p)))))) + (save-match-data + (if (equal this-command 'undo) + ;; Allow undo without inhibition. + ;; - Undoing new and open-line hits stupid Emacs redisplay + ;; optimization (em 19 cmds.c, ~ line 200). + ;; - Presumably, undoing what was properly protected when + ;; done. + ;; - Undo may be users' only recourse in protection faults. + ;; So, expose what getting changed: + (progn (message "Undo! - exposing concealed target...") + (if (allout-hidden-p) + (allout-show-children)) + (message "Undo!")) + (let (response + (rehide-completely (save-excursion (allout-goto-prefix) + (allout-hidden-p))) + rehide-place) + + (save-excursion + (if (condition-case err + ;; Condition case to catch keyboard quits during reads. + (progn + ; Give them a peek where + (save-excursion + (if (eolp) (setq rehide-place + (allout-goto-prefix))) + (allout-show-entry)) + ; Present the message, but... + ; leave the cursor at the location + ; until they respond: + ; Then interpret the response: + (while + (progn + (message (concat "Change inside concealed" + " region - do it? " + "(n or 'y'/'r'eclose)")) + (setq response (read-char)) + (not + (cond ((memq response '(?r ?R)) + (setq response 'reclose)) + ((memq response '(?y ?Y ? )) + (setq response t)) + ((memq response '(?n ?N 127)) + (setq response nil) + t) + ((eq response ??) + (message + "`r' means `yes, then reclose'") + nil) + (t (message "Please answer y, n, or r") + (sit-for 1) + nil))))) + response) + ('quit nil)) + ; Continue: + (if (eq response 'reclose) + (save-excursion + (if rehide-place (goto-char rehide-place)) + (if rehide-completely + (allout-hide-current-entry-completely) + (allout-hide-current-entry))) + (if (allout-ascend-to-depth (1- (allout-recent-depth))) + (allout-show-children) + (allout-show-to-offshoot))) + ; Prevent: + (if rehide-completely + (save-excursion + (if rehide-place (goto-char rehide-place)) + (allout-hide-current-entry-completely)) + (allout-hide-current-entry)) + (error "Change within concealed region prevented")))))) + ) ; if + ) ; defun +;;;_ = allout-post-goto-bullet +(defvar allout-post-goto-bullet nil + "Outline internal var, for `allout-pre-command-business' hot-spot operation. + +When set, tells post-processing to reposition on topic bullet, and +then unset it. Set by `allout-pre-command-business' when implementing +hot-spot operation, where literal characters typed over a topic bullet +are mapped to the command of the corresponding control-key on the +`allout-mode-map'.") +(make-variable-buffer-local 'allout-post-goto-bullet) +;;;_ > allout-post-command-business () +(defun allout-post-command-business () + "Outline `post-command-hook' function. + +- Null `allout-override-protect', so it's not left open. + +- Implement (and clear) `allout-post-goto-bullet', for hot-spot + outline commands. + +- Massages `buffer-undo-list' so successive, standard character self-inserts + are aggregated. This kludge compensates for lack of undo bunching when + `before-change-functions' is used." + + ; Apply any external change func: + (if (not (allout-mode-p)) ; In allout-mode. nil - - ;; ... yes: - - ; Ensure load of isearch-mode: - (if (or (and (fboundp 'isearch-mode) - (fboundp 'isearch-quote-char)) - (condition-case error - (load-library outline-enwrap-isearch-mode) - (file-error (message "Skipping isearch-mode provisions - %s '%s'" - (car (cdr error)) - (car (cdr (cdr error)))) - (sit-for 1) - ;; Inhibit subsequent tries and return nil: - (setq outline-enwrap-isearch-mode nil)))) - ;; Isearch-mode loaded, encapsulate specific entry points for - ;; outline dynamic-exposure business: - (progn - - ; stash crucial isearch-mode - ; funcs under known, private - ; names, then register wrapper - ; functions under the old - ; names, in their stead: - ; 'isearch-quit' is pre v 1.2: - (fset 'real-isearch-terminate - ; 'isearch-quit is pre v 1.2: - (or (if (fboundp 'isearch-quit) - (symbol-function 'isearch-quit)) - (if (fboundp 'isearch-abort) - ; 'isearch-abort' is v 1.2 and on: - (symbol-function 'isearch-abort)))) - (fset 'isearch-quit 'isearch-terminate/outline-provisions) - (fset 'isearch-abort 'isearch-terminate/outline-provisions) - (fset 'real-isearch-done (symbol-function 'isearch-done)) - (fset 'isearch-done 'isearch-done/outline-provisions) - (fset 'real-isearch-update (symbol-function 'isearch-update)) - (fset 'isearch-update 'isearch-update/outline-provisions) - (make-variable-buffer-local 'outline-search-reconceal)) - ) - ) - ) -;;;_ > outline-isearch-arrival-business () -(defun outline-isearch-arrival-business () - " Do outline business like exposing current point, if necessary, - registering reconcealment requirements in outline-search-reconceal - accordingly. - - Set outline-search-reconceal to nil if current point is not - concealed, to value of point if entire topic is concealed, and a - list containing point if only the topic body is concealed. - - This will be used to determine whether outline-hide-current-entry - or outline-hide-current-entry-completely will be necessary to - restore the prior concealment state." - - (if (and (boundp 'outline-mode) outline-mode) - (setq outline-search-reconceal - (if (outline-hidden-p) - (save-excursion - (if (re-search-backward outline-line-boundary-regexp nil 1) - ;; Nil value means we got to b-o-b - wouldn't need - ;; to advance. - (forward-char 1)) - ; We'll return point or list - ; containing point, depending - ; on concealment state of - ; topic prefix. - (prog1 (if (outline-hidden-p) (point) (list (point))) - ; And reveal the current - ; search target: - (outline-show-entry))))))) -;;;_ > outline-isearch-advancing-business () -(defun outline-isearch-advancing-business () - " Do outline business like deexposing current point, if necessary, - according to reconceal state registration." - (if (and (boundp 'outline-mode) outline-mode outline-search-reconceal) - (save-excursion - (if (listp outline-search-reconceal) - ;; Leave the topic visible: - (progn (goto-char (car outline-search-reconceal)) - (outline-hide-current-entry)) - ;; Rehide the entire topic: - (goto-char outline-search-reconceal) - (outline-hide-current-entry-completely)))) - ) -;;;_ > isearch-terminate/outline-provisions () -(defun isearch-terminate/outline-provisions () - (interactive) - (if (and (boundp 'outline-mode) - outline-mode - outline-enwrap-isearch-mode) - (outline-isearch-advancing-business)) - (let ((outline-search-quitting t) - (outline-search-reconceal nil)) - (real-isearch-terminate))) -;;;_ > isearch-done/outline-provisions () -(defun isearch-done/outline-provisions (&optional nopush) - (interactive) - (if (and (boundp 'outline-mode) - outline-mode - outline-enwrap-isearch-mode) - (progn (save-excursion - (if (and outline-search-reconceal - (not (listp outline-search-reconceal))) - ;; The topic was concealed - reveal it, its siblings, - ;; and any ancestors that are still concealed: - (progn - (message "(exposing destination)")(sit-for 0) - ;; Ensure target topic's siblings are exposed: - (outline-ascend-to-depth (1- (outline-current-depth))) - ;; Ensure that the target topic's ancestors are exposed - (while (outline-hidden-p) - (outline-show-current-children)) - (outline-show-current-children) - (outline-show-current-entry))) - (outline-isearch-arrival-business)) - (if (not (and (boundp 'outline-search-quitting) - outline-search-quitting)) - (outline-show-current-children)))) - (if nopush - ;; isearch-done in newer version of isearch mode takes arg: - (real-isearch-done nopush) - (real-isearch-done))) -;;;_ > isearch-update/outline-provisions () -(defun isearch-update/outline-provisions () - " Wrapper around isearch which exposes and conceals hidden outline - portions encountered in the course of searching." - (if (not (and (boundp 'outline-mode) - outline-mode - outline-enwrap-isearch-mode)) - ;; Just do the plain business: - (real-isearch-update) - - ;; Ah - provide for outline conditions: - (outline-isearch-advancing-business) - (real-isearch-update) - (cond (isearch-success (outline-isearch-arrival-business)) - ((not isearch-success) (outline-isearch-advancing-business))) - ) - ) - -;;;_ #5 Manipulation - -;;;_ : Topic Format Assessment -;;;_ > outline-solicit-alternate-bullet (depth &optional current-bullet) -(defun outline-solicit-alternate-bullet (depth &optional current-bullet) - - " Prompt for and return a bullet char as an alternative to the - current one, but offer one suitable for current depth DEPTH - as default." - - (let* ((default-bullet (or current-bullet - (outline-bullet-for-depth depth))) - (choice (solicit-char-in-string - (format "Select bullet: %s ('%s' default): " - outline-bullets-string - default-bullet) - (string-sans-char outline-bullets-string ?\\) - t))) + (setq allout-override-protect nil) + (if allout-isearch-dynamic-expose + (allout-isearch-rectification)) + (if allout-during-write-cue + ;; Was used by allout-before-change-protect, done with it now: + (setq allout-during-write-cue nil)) + ;; Undo bunching business: + (if (and (listp buffer-undo-list) ; Undo history being kept. + (equal this-command 'self-insert-command) + (equal last-command 'self-insert-command)) + (let* ((prev-stuff (cdr buffer-undo-list)) + (before-prev-stuff (cdr (cdr prev-stuff))) + cur-cell cur-from cur-to + prev-cell prev-from prev-to) + (if (and before-prev-stuff ; Goes back far enough to bother, + (not (car prev-stuff)) ; and break before current, + (not (car before-prev-stuff)) ; !and break before prev! + (setq prev-cell (car (cdr prev-stuff))) ; contents now, + (setq cur-cell (car buffer-undo-list)) ; contents prev. + + ;; cur contents denote a single char insertion: + (numberp (setq cur-from (car cur-cell))) + (numberp (setq cur-to (cdr cur-cell))) + (= 1 (- cur-to cur-from)) + + ;; prev contents denote fewer than aggregate-limit + ;; insertions: + (numberp (setq prev-from (car prev-cell))) + (numberp (setq prev-to (cdr prev-cell))) + ; Below threshold: + (> allout-undo-aggregation (- prev-to prev-from))) + (setq buffer-undo-list + (cons (cons prev-from cur-to) + (cdr (cdr (cdr buffer-undo-list)))))))) + ;; Implement -post-goto-bullet, if set: (must be after undo business) + (if (and allout-post-goto-bullet + (allout-current-bullet-pos)) + (progn (goto-char (allout-current-bullet-pos)) + (setq allout-post-goto-bullet nil))) + )) +;;;_ > allout-pre-command-business () +(defun allout-pre-command-business () + "Outline `pre-command-hook' function for outline buffers. +Implements special behavior when cursor is on bullet character. + +When the cursor is on the bullet character, self-insert characters are +reinterpreted as the corresponding control-character in the +`allout-mode-map'. The `allout-mode' `post-command-hook' insures that +the cursor which has moved as a result of such reinterpretation is +positioned on the bullet character of the destination topic. + +The upshot is that you can get easy, single (ie, unmodified) key +outline maneuvering operations by positioning the cursor on the bullet +char. When in this mode you can use regular cursor-positioning +command/keystrokes to relocate the cursor off of a bullet character to +return to regular interpretation of self-insert characters." + (if (not (allout-mode-p)) + ;; Shouldn't be invoked if not in allout allout-mode, but just in case: + nil + ;; Register isearch status: + (if (and (boundp 'isearch-mode) isearch-mode) + (setq allout-pre-was-isearching t) + (setq allout-pre-was-isearching nil)) + ;; Hot-spot navigation provisions: + (if (and (eq this-command 'self-insert-command) + (eq (point)(allout-current-bullet-pos))) + (let* ((this-key-num (cond + ((numberp last-command-char) + last-command-char) + ((fboundp 'char-to-int) + (char-to-int last-command-char)) + (t 0))) + mapped-binding) + (if (zerop this-key-num) + nil + ; Map upper-register literals + ; to lower register: + (if (<= 96 this-key-num) + (setq this-key-num (- this-key-num 32))) + ; Check if we have a literal: + (if (and (<= 64 this-key-num) + (>= 96 this-key-num)) + (setq mapped-binding + (lookup-key 'allout-mode-map + (concat allout-command-prefix + (char-to-string (- this-key-num + 64)))))) + (if mapped-binding + (setq allout-post-goto-bullet t + this-command mapped-binding))))))) +;;;_ > allout-find-file-hook () +(defun allout-find-file-hook () + "Activate `allout-mode' when `allout-auto-activation' & `allout-layout' are non-nil. + +See `allout-init' for setup instructions." + (if (and allout-auto-activation + (not (allout-mode-p)) + allout-layout) + (allout-mode t))) +;;;_ > allout-isearch-rectification +(defun allout-isearch-rectification () + "Rectify outline exposure before, during, or after isearch. + +Called as part of `allout-post-command-business'." + + (let ((isearching isearch-mode)) + (cond ((and isearching (not allout-pre-was-isearching)) + (allout-isearch-expose 'start)) + ((and isearching allout-pre-was-isearching) + (allout-isearch-expose 'continue)) + ((and (not isearching) allout-pre-was-isearching) + (allout-isearch-expose 'final)) + ;; Not and wasn't isearching: + (t (setq allout-isearch-prior-pos nil))))) +;;;_ = allout-isearch-was-font-lock +(defvar allout-isearch-was-font-lock + (and (boundp 'font-lock-mode) font-lock-mode)) + +;;;_ > allout-flag-region (from to flag) +(defmacro allout-flag-region (from to flag) + "Hide or show lines from FROM to TO, via Emacs `selective-display' FLAG char. +Ie, text following flag C-m \(carriage-return) is hidden until the +next C-j (newline) char. + +Returns the endpoint of the region." + `(let ((buffer-read-only nil) + (allout-override-protect t)) + (subst-char-in-region ,from ,to + (if (= ,flag ?\n) ?\r ?\n) + ,flag t))) + +;;;_ > allout-isearch-expose (mode) +(defun allout-isearch-expose (mode) + "MODE is either 'clear, 'start, 'continue, or 'final." + ;; allout-isearch-prior-pos encodes exposure status of prior pos: + ;; (pos was-vis header-pos end-pos) + ;; pos - point of concern + ;; was-vis - t, else 'topic if entire topic was exposed, 'entry otherwise + ;; Do reclosure or prior pos, as necessary: + (if (eq mode 'start) + (setq allout-isearch-was-font-lock (and (boundp 'font-lock-mode) + font-lock-mode) + font-lock-mode nil) + (if (eq mode 'final) + (setq font-lock-mode allout-isearch-was-font-lock)) + (if (and allout-isearch-prior-pos + (listp allout-isearch-prior-pos)) + ;; Conceal prior peek: + (allout-flag-region (car (cdr allout-isearch-prior-pos)) + (car (cdr (cdr allout-isearch-prior-pos))) + ?\r))) + (if (allout-visible-p) + (setq allout-isearch-prior-pos nil) + (if (not (eq mode 'final)) + (setq allout-isearch-prior-pos (cons (point) (allout-show-entry))) + (if isearch-mode-end-hook-quit + nil + (setq allout-isearch-prior-pos nil) + (allout-show-children))))) +;;;_ > allout-enwrap-isearch () +(defun allout-enwrap-isearch () + "Impose `isearch-abort' wrapper for dynamic exposure in isearch. + +The function checks to ensure that the rebinding is done only once." + (add-hook 'isearch-mode-end-hook 'allout-isearch-rectification)) + +;;; Prevent unnecessary font-lock while isearching! +(defvar isearch-was-font-locking nil) +(defun isearch-inhibit-font-lock () + "Inhibit `font-lock-mode' while isearching - for use on `isearch-mode-hook'." + (if (and (allout-mode-p) (boundp 'font-lock-mode) font-lock-mode) + (setq isearch-was-font-locking t + font-lock-mode nil))) +(add-hook 'isearch-mode-hook 'isearch-inhibit-font-lock) +(defun isearch-reenable-font-lock () + "Reenable font-lock after isearching - for use on `isearch-mode-end-hook'." + (if (and (boundp 'font-lock-mode) font-lock-mode) + (if (and (allout-mode-p) isearch-was-font-locking) + (setq isearch-was-font-locking nil + font-lock-mode t)))) +(add-hook 'isearch-mode-end-hook 'isearch-reenable-font-lock) + +;;;_ - Topic Format Assessment +;;;_ > allout-solicit-alternate-bullet (depth &optional current-bullet) +(defun allout-solicit-alternate-bullet (depth &optional current-bullet) + + "Prompt for and return a bullet char as an alternative to the current one. + +Offer one suitable for current depth DEPTH as default." + + (let* ((default-bullet (or (and (stringp current-bullet) current-bullet) + (allout-bullet-for-depth depth))) + (sans-escapes (regexp-sans-escapes allout-bullets-string)) + choice) + (save-excursion + (goto-char (allout-current-bullet-pos)) + (setq choice (solicit-char-in-string + (format "Select bullet: %s ('%s' default): " + sans-escapes + default-bullet) + sans-escapes + t))) + (message "") (if (string= choice "") default-bullet choice)) ) -;;;_ > outline-sibling-index (&optional depth) -(defun outline-sibling-index (&optional depth) - " Item number of this prospective topic among it's siblings. - - If optional arg depth is greater than current depth, then we're - opening a new level, and return 0. - - If less than this depth, ascend to that depth and count..." - - (save-excursion - (cond ((and depth (<= depth 0) 0)) - ((or (not depth) (= depth (outline-depth))) - (let ((index 1)) - (while (outline-previous-sibling) (setq index (1+ index))) - index)) - ((< depth (outline-recent-depth)) - (outline-ascend-to-depth depth) - (outline-sibling-index)) - (0)))) -;;;_ > outline-distinctive-bullet (bullet) -(defun outline-distinctive-bullet (bullet) - " True if bullet is one of those on outline-distinctive-bullets-string." - (string-match (regexp-quote bullet) outline-distinctive-bullets-string)) -;;;_ > outline-numbered-type-prefix (&optional prefix) -(defun outline-numbered-type-prefix (&optional prefix) - " True if current header prefix bullet is numbered bullet." - (and outline-numbered-bullet - (string= outline-numbered-bullet +;;;_ > allout-distinctive-bullet (bullet) +(defun allout-distinctive-bullet (bullet) + "True if BULLET is one of those on `allout-distinctive-bullets-string'." + (string-match (regexp-quote bullet) allout-distinctive-bullets-string)) +;;;_ > allout-numbered-type-prefix (&optional prefix) +(defun allout-numbered-type-prefix (&optional prefix) + "True if current header prefix bullet is numbered bullet." + (and allout-numbered-bullet + (string= allout-numbered-bullet (if prefix - (outline-get-prefix-bullet prefix) - (outline-get-bullet))))) -;;;_ > outline-bullet-for-depth (&optional depth) -(defun outline-bullet-for-depth (&optional depth) - " Return outline topic bullet suited to DEPTH, or for current depth if none - specified." + (allout-get-prefix-bullet prefix) + (allout-get-bullet))))) +;;;_ > allout-bullet-for-depth (&optional depth) +(defun allout-bullet-for-depth (&optional depth) + "Return outline topic bullet suited to optional DEPTH, or current depth." ;; Find bullet in plain-bullets-string modulo DEPTH. - (if outline-stylish-prefixes - (char-to-string (aref outline-plain-bullets-string + (if allout-stylish-prefixes + (char-to-string (aref allout-plain-bullets-string (% (max 0 (- depth 2)) - outline-plain-bullets-string-len))) - outline-primary-bullet) + allout-plain-bullets-string-len))) + allout-primary-bullet) ) -;;;_ : Topic Production -;;;_ > outline-make-topic-prefix (&optional prior-bullet -(defun outline-make-topic-prefix (&optional prior-bullet +;;;_ - Topic Production +;;;_ > allout-make-topic-prefix (&optional prior-bullet +(defun allout-make-topic-prefix (&optional prior-bullet new depth solicit @@ -1618,47 +2488,50 @@ and cancellation of a search.") ;; opening a new topic after current topic, lower or higher, or we're ;; changing level of current topic. ;; Solicit dominates specified bullet-char. - " Generate a topic prefix suitable for optional arg DEPTH, or current - depth if not specified. - - All the arguments are optional. - - PRIOR-BULLET indicates the bullet of the prefix being changed, or - nil if none. This bullet may be preserved (other options - notwithstanding) if it is on the outline-distinctive-bullets-string, - for instance. - - Second arg NEW indicates that a new topic is being opened after the - topic at point, if non-nil. Default bullet for new topics, eg, may - be set (contingent to other args) to numbered bullets if previous - sibling is one. The implication otherwise is that the current topic - is being adjusted - shifted or rebulleted - and we don't consider - bullet or previous sibling. - - Third arg DEPTH forces the topic prefix to that depth, regardless of - the current topics' depth. - - Fourth arg SOLICIT non-nil provokes solicitation from the user of a - choice among the valid bullets. (This overrides other all the - options, including, eg, a distinctive PRIOR-BULLET.) - - Fifth arg, NUMBER-CONTROL, matters only if 'outline-numbered-bullet' - is non-nil *and* soliciting was not explicitly invoked. Then - NUMBER-CONTROL non-nil forces prefix to either numbered or - denumbered format, depending on the value of the sixth arg, INDEX. - - (Note that NUMBER-CONTROL does *not* apply to level 1 topics. Sorry...) - - If NUMBER-CONTROL is non-nil and sixth arg INDEX is non-nil then - the prefix of the topic is forced to be numbered. Non-nil - NUMBER-CONTROL and nil INDEX forces non-numbered format on the - bullet. Non-nil NUMBER-CONTROL and non-nil, non-number INDEX means - that the index for the numbered prefix will be derived, by counting - siblings back to start of level. If INDEX is a number, then that - number is used as the index for the numbered prefix (allowing, eg, - sequential renumbering to not require this function counting back the - index for each successive sibling)." - +;;;_ . Doc string: + "Generate a topic prefix suitable for optional arg DEPTH, or current depth. + +All the arguments are optional. + +PRIOR-BULLET indicates the bullet of the prefix being changed, or +nil if none. This bullet may be preserved (other options +notwithstanding) if it is on the `allout-distinctive-bullets-string', +for instance. + +Second arg NEW indicates that a new topic is being opened after the +topic at point, if non-nil. Default bullet for new topics, eg, may +be set (contingent to other args) to numbered bullets if previous +sibling is one. The implication otherwise is that the current topic +is being adjusted - shifted or rebulleted - and we don't consider +bullet or previous sibling. + +Third arg DEPTH forces the topic prefix to that depth, regardless of +the current topics' depth. + +If SOLICIT is non-nil, then the choice of bullet is solicited from +user. If it's a character, then that character is offered as the +default, otherwise the one suited to the context \(according to +distinction or depth) is offered. \(This overrides other options, +including, eg, a distinctive PRIOR-BULLET.) If non-nil, then the +context-specific bullet is used. + +Fifth arg, NUMBER-CONTROL, matters only if `allout-numbered-bullet' +is non-nil *and* soliciting was not explicitly invoked. Then +NUMBER-CONTROL non-nil forces prefix to either numbered or +denumbered format, depending on the value of the sixth arg, INDEX. + +\(Note that NUMBER-CONTROL does *not* apply to level 1 topics. Sorry...) + +If NUMBER-CONTROL is non-nil and sixth arg INDEX is non-nil then +the prefix of the topic is forced to be numbered. Non-nil +NUMBER-CONTROL and nil INDEX forces non-numbered format on the +bullet. Non-nil NUMBER-CONTROL and non-nil, non-number INDEX means +that the index for the numbered prefix will be derived, by counting +siblings back to start of level. If INDEX is a number, then that +number is used as the index for the numbered prefix (allowing, eg, +sequential renumbering to not require this function counting back the +index for each successive sibling)." +;;;_ . Code: ;; The options are ordered in likely frequence of use, most common ;; highest, least lowest. Ie, more likely to be doing prefix ;; adjustments than soliciting, and yet more than numbering. @@ -1668,21 +2541,21 @@ and cancellation of a search.") (let* (body numbering denumbering - (depth (or depth (outline-depth))) - (header-lead outline-header-prefix) + (depth (or depth (allout-depth))) + (header-lead allout-header-prefix) (bullet-char ;; Getting value for bullet char is practically the whole job: (cond ; Simplest situation - level 1: - ((<= depth 1) (setq header-lead "") outline-primary-bullet) + ((<= depth 1) (setq header-lead "") allout-primary-bullet) ; Simple, too: all asterisks: - (outline-old-style-prefixes + (allout-old-style-prefixes ;; Cheat - make body the whole thing, null out header-lead and ;; bullet-char: (setq body (make-string depth - (string-to-char outline-primary-bullet))) + (string-to-char allout-primary-bullet))) (setq header-lead "") "") @@ -1693,351 +2566,455 @@ and cancellation of a search.") ((progn (setq body (make-string (- depth 2) ?\ )) ;; The actual condition: solicit) - (let* ((got (outline-solicit-alternate-bullet depth))) + (let* ((got (allout-solicit-alternate-bullet depth solicit))) ;; Gotta check whether we're numbering and got a numbered bullet: - (setq numbering (and outline-numbered-bullet + (setq numbering (and allout-numbered-bullet (not (and number-control (not index))) - (string= got outline-numbered-bullet))) + (string= got allout-numbered-bullet))) ;; Now return what we got, regardless: got)) ;; Numbering invoked through args: - ((and outline-numbered-bullet number-control) + ((and allout-numbered-bullet number-control) (if (setq numbering (not (setq denumbering (not index)))) - outline-numbered-bullet - (if (and current-bullet - (not (string= outline-numbered-bullet - current-bullet))) - current-bullet - (outline-bullet-for-depth depth)))) + allout-numbered-bullet + (if (and prior-bullet + (not (string= allout-numbered-bullet + prior-bullet))) + prior-bullet + (allout-bullet-for-depth depth)))) ;;; Neither soliciting nor controlled numbering ;;; ;;; (may be controlled denumbering, tho) ;;; ;; Check wrt previous sibling: ((and new ; only check for new prefixes - (<= depth (outline-depth)) - outline-numbered-bullet ; ... & numbering enabled + (<= depth (allout-depth)) + allout-numbered-bullet ; ... & numbering enabled (not denumbering) (let ((sibling-bullet (save-excursion ;; Locate correct sibling: - (or (>= depth (outline-depth)) - (outline-ascend-to-depth depth)) - (outline-get-bullet)))) + (or (>= depth (allout-depth)) + (allout-ascend-to-depth depth)) + (allout-get-bullet)))) (if (and sibling-bullet - (string= outline-numbered-bullet sibling-bullet)) + (string= allout-numbered-bullet sibling-bullet)) (setq numbering sibling-bullet))))) ;; Distinctive prior bullet? ((and prior-bullet - (outline-distinctive-bullet prior-bullet) + (allout-distinctive-bullet prior-bullet) ;; Either non-numbered: - (or (not (and outline-numbered-bullet - (string= prior-bullet outline-numbered-bullet))) + (or (not (and allout-numbered-bullet + (string= prior-bullet allout-numbered-bullet))) ;; or numbered, and not denumbering: (setq numbering (not denumbering))) ;; Here 'tis: prior-bullet)) ;; Else, standard bullet per depth: - ((outline-bullet-for-depth depth))))) + ((allout-bullet-for-depth depth))))) (concat header-lead body bullet-char (if numbering (format "%d" (cond ((and index (numberp index)) index) - (new (1+ (outline-sibling-index depth))) - ((outline-sibling-index)))))) + (new (1+ (allout-sibling-index depth))) + ((allout-sibling-index)))))) ) ) -;;;_ > open-topic (relative-depth &optional before) -(defun open-topic (relative-depth &optional before) - " Open a new topic at depth DEPTH. New topic is situated after current - one, unless optional flag BEFORE is non-nil, or unless current line - is complete empty (not even whitespace), in which case open is done - on current line. - - Nuances: - - - Creation of new topics is with respect to the visible topic - containing the cursor, regardless of intervening concealed ones. - - - New headers are generally created after/before the body of a - topic. However, they are created right at cursor location if the - cursor is on a blank line, even if that breaks the current topic - body. This is intentional, to provide a simple means for - deliberately dividing topic bodies. - - - Double spacing of topic lists is preserved. Also, the first - level two topic is created double-spaced (and so would be - subsequent siblings, if that's left intact). Otherwise, - single-spacing is used. - - - Creation of sibling or nested topics is with respect to the topic - you're starting from, even when creating backwards. This way you - can easily create a sibling in front of the current topic without - having to go to its preceding sibling, and then open forward - from there." - - (let* ((depth (+ (outline-current-depth) relative-depth)) +;;;_ > allout-open-topic (relative-depth &optional before use-sib-bullet) +(defun allout-open-topic (relative-depth &optional before use-sib-bullet) + "Open a new topic at depth RELATIVE-DEPTH. + +New topic is situated after current one, unless optional flag BEFORE +is non-nil, or unless current line is complete empty (not even +whitespace), in which case open is done on current line. + +If USE-SIB-BULLET is true, use the bullet of the prior sibling. + +Nuances: + +- Creation of new topics is with respect to the visible topic + containing the cursor, regardless of intervening concealed ones. + +- New headers are generally created after/before the body of a + topic. However, they are created right at cursor location if the + cursor is on a blank line, even if that breaks the current topic + body. This is intentional, to provide a simple means for + deliberately dividing topic bodies. + +- Double spacing of topic lists is preserved. Also, the first + level two topic is created double-spaced (and so would be + subsequent siblings, if that's left intact). Otherwise, + single-spacing is used. + +- Creation of sibling or nested topics is with respect to the topic + you're starting from, even when creating backwards. This way you + can easily create a sibling in front of the current topic without + having to go to its preceding sibling, and then open forward + from there." + + (let* ((depth (+ (allout-current-depth) relative-depth)) (opening-on-blank (if (looking-at "^\$") (not (setq before nil)))) opening-numbered ; Will get while computing ref-topic, below - ref-depth ; Will get while computing ref-topic, next + ref-depth ; Will get while computing ref-topic, below + ref-bullet ; Will get while computing ref-topic, next (ref-topic (save-excursion (cond ((< relative-depth 0) - (outline-ascend-to-depth depth)) + (allout-ascend-to-depth depth)) ((>= relative-depth 1) nil) - (t (outline-back-to-current-heading))) - (setq ref-depth (outline-recent-depth)) + (t (allout-back-to-current-heading))) + (setq ref-depth (allout-recent-depth)) + (setq ref-bullet + (if (> allout-recent-prefix-end 1) + (allout-recent-bullet) + "")) (setq opening-numbered (save-excursion - (and outline-numbered-bullet + (and allout-numbered-bullet (or (<= relative-depth 0) - (outline-descend-to-depth depth)) - (if (outline-numbered-type-prefix) - outline-numbered-bullet)))) + (allout-descend-to-depth depth)) + (if (allout-numbered-type-prefix) + allout-numbered-bullet)))) (point))) dbl-space - doing-beginning - ) + doing-beginning) (if (not opening-on-blank) ; Positioning and vertical ; padding - only if not ; opening-on-blank: - (progn + (progn (goto-char ref-topic) (setq dbl-space ; Determine double space action: - (or (and (not (> relative-depth 0)) - ;; not descending, + (or (and (<= relative-depth 0) ; not descending; (save-excursion - ;; preceded by a blank line? - (forward-line -1) - (looking-at "^\\s-*$"))) + ;; at b-o-b or preceded by a blank line? + (or (> 0 (forward-line -1)) + (looking-at "^\\s-*$") + (bobp))) + (save-excursion + ;; succeeded by a blank line? + (allout-end-of-current-subtree) + (bolp))) (and (= ref-depth 1) (or before (= depth 1) (save-excursion ;; Don't already have following ;; vertical padding: - (not (outline-pre-next-preface))))))) + (not (allout-pre-next-preface))))))) ; Position to prior heading, - ; if inserting backwards: - (if before (progn (outline-back-to-current-heading) + ; if inserting backwards, and + ; not going outwards: + (if (and before (>= relative-depth 0)) + (progn (allout-back-to-current-heading) (setq doing-beginning (bobp)) - (if (and (not (outline-previous-sibling)) - (not (bobp))) - (outline-previous-heading)))) + (if (not (bobp)) + (allout-previous-heading))) + (if (and before (bobp)) + (allout-unprotected (open-line 1)))) - (if (and (<= depth ref-depth) - (= ref-depth (outline-current-depth))) + (if (<= relative-depth 0) ;; Not going inwards, don't snug up: (if doing-beginning - (open-line (if dbl-space 2 1)) - (outline-end-of-current-subtree)) + (allout-unprotected (open-line (if dbl-space 2 1))) + (if before + (progn (end-of-line) + (allout-pre-next-preface) + (while (= ?\r (following-char)) + (forward-char 1)) + (if (not (looking-at "^$")) + (allout-unprotected (open-line 1)))) + (allout-end-of-current-subtree))) ;; Going inwards - double-space if first offspring is, ;; otherwise snug up. (end-of-line) ; So we skip any concealed progeny. - (outline-pre-next-preface) + (allout-pre-next-preface) (if (bolp) ;; Blank lines between current header body and next ;; header - get to last substantive (non-white-space) ;; line in body: (re-search-backward "[^ \t\n]" nil t)) (if (save-excursion - (outline-next-heading) - (if (> (outline-recent-depth) ref-depth) + (allout-next-heading) + (if (> (allout-recent-depth) ref-depth) ;; This is an offspring. (progn (forward-line -1) (looking-at "^\\s-*$")))) (progn (forward-line 1) - (open-line 1))) + (allout-unprotected (open-line 1)))) (end-of-line)) ;;(if doing-beginning (goto-char doing-beginning)) - (if (not (bobp)) (newline (if dbl-space 2 1))) + (if (not (bobp)) + (progn (if (and (not (> depth ref-depth)) + (not before)) + (allout-unprotected (open-line 1)) + (if (> depth ref-depth) + (allout-unprotected (newline 1)) + (if dbl-space + (allout-unprotected (open-line 1)) + (if (not before) + (allout-unprotected (newline 1)))))) + (if dbl-space + (allout-unprotected (newline 1))) + (if (and (not (eobp)) + (not (bolp))) + (forward-char 1)))) )) - (insert-string (concat (outline-make-topic-prefix opening-numbered - t - depth) - " ")) + (insert (concat (allout-make-topic-prefix opening-numbered + t + depth) + " ")) ;;(if doing-beginning (save-excursion (newline (if dbl-space 2 1)))) - (outline-rebullet-heading nil ;;; solicit - depth ;;; depth - nil ;;; number-control - nil ;;; index + (allout-rebullet-heading (and use-sib-bullet ref-bullet);;; solicit + depth ;;; depth + nil ;;; number-control + nil ;;; index t) (end-of-line) ) ) -;;;_ > open-subtopic (arg) -(defun open-subtopic (arg) - " Open new topic header at deeper level than the current one. - - Negative universal arg means to open deeper, but place the new topic - prior to the current one." - (interactive "p") - (open-topic 1 (> 0 arg))) -;;;_ > open-sibtopic (arg) -(defun open-sibtopic (arg) - " Open new topic header at same level as the current one. Negative - universal arg means to place the new topic prior to the current - one." +;;;_ . open-topic contingencies +;;;_ ; base topic - one from which open was issued +;;;_ , beginning char +;;;_ , amount of space before will be used, unless opening in place +;;;_ , end char will be used, unless opening before (and it still may) +;;;_ ; absolute depth of new topic +;;;_ ! insert in place - overrides most stuff +;;;_ ; relative depth of new re base +;;;_ ; before or after base topic +;;;_ ; spacing around topic, if any, prior to new topic and at same depth +;;;_ ; buffer boundaries - special provisions for beginning and end ob +;;;_ ; level 1 topics have special provisions also - double space. +;;;_ ; location of new topic +;;;_ > allout-open-subtopic (arg) +(defun allout-open-subtopic (arg) + "Open new topic header at deeper level than the current one. + +Negative universal arg means to open deeper, but place the new topic +prior to the current one." (interactive "p") - (open-topic 0 (> 0 arg))) -;;;_ > open-supertopic (arg) -(defun open-supertopic (arg) - " Open new topic header at shallower level than the current one. - Negative universal arg means to open shallower, but place the new - topic prior to the current one." + (allout-open-topic 1 (> 0 arg))) +;;;_ > allout-open-sibtopic (arg) +(defun allout-open-sibtopic (arg) + "Open new topic header at same level as the current one. +Positive universal arg means to use the bullet of the prior sibling. + +Negative universal arg means to place the new topic prior to the current +one." (interactive "p") - (open-topic -1 (> 0 arg))) + (allout-open-topic 0 (> 0 arg) (< 1 arg))) +;;;_ > allout-open-supertopic (arg) +(defun allout-open-supertopic (arg) + "Open new topic header at shallower level than the current one. -;;;_ : Outline Alteration -;;;_ . Topic Form Modification -;;;_ > outline-reindent-body (old-depth new-depth) -(defun outline-reindent-body (old-depth new-depth) - " Reindent body lines which were indented at old-depth to new-depth. +Negative universal arg means to open shallower, but place the new +topic prior to the current one." - Note that refill of indented paragraphs is not done, and tabs are - not accommodated. ('untabify' your outline if you want to preserve - hanging body indents.)" + (interactive "p") + (allout-open-topic -1 (> 0 arg))) + +;;;_ - Outline Alteration +;;;_ : Topic Modification +;;;_ = allout-former-auto-filler +(defvar allout-former-auto-filler nil + "Name of modal fill function being wrapped by `allout-auto-fill'.") +;;;_ > allout-auto-fill () +(defun allout-auto-fill () + "`allout-mode' autofill function. + +Maintains outline hanging topic indentation if +`allout-use-hanging-indents' is set." + (let ((fill-prefix (if allout-use-hanging-indents + ;; Check for topic header indentation: + (save-excursion + (beginning-of-line) + (if (looking-at allout-regexp) + ;; ... construct indentation to account for + ;; length of topic prefix: + (make-string (progn (allout-end-of-prefix) + (current-column)) + ?\ )))))) + (if (or allout-former-auto-filler allout-use-hanging-indents) + (do-auto-fill)))) +;;;_ > allout-reindent-body (old-depth new-depth &optional number) +(defun allout-reindent-body (old-depth new-depth &optional number) + "Reindent body lines which were indented at OLD-DEPTH to NEW-DEPTH. + +Optional arg NUMBER indicates numbering is being added, and it must +be accommodated. + +Note that refill of indented paragraphs is not done." (save-excursion - (save-restriction - (outline-goto-prefix) - (forward-char 1) - (let* ((old-spaces-expr (make-string (1+ old-depth) ?\ )) - (new-spaces-expr (concat (make-string (1+ new-depth) ?\ ) - ;; spaces followed by non-space: - "\\1"))) - (while (and (re-search-forward "[\C-j\C-m]" nil t) - (not (looking-at outline-regexp))) - (if (looking-at old-spaces-expr) - (replace-match new-spaces-expr))))))) -;;;_ > outline-rebullet-current-heading (arg) -(defun outline-rebullet-current-heading (arg) - " Like non-interactive version 'outline-rebullet-heading', but work on - (only) visible heading containing point. - - With repeat count, solicit for bullet." - (interactive "P") - (save-excursion (outline-back-to-current-heading) - (outline-end-of-prefix) - (outline-rebullet-heading (not arg) ;;; solicit - nil ;;; depth - nil ;;; number-control - nil ;;; index - t) ;;; do-successors - ) - ) -;;;_ > outline-rebullet-heading (&optional solicit ...) -(defvar current-bullet nil - "Variable local to outline-rebullet-heading,but referenced by -outline-make-topic-prefix, also. Should be resolved with explicitly -parameterized communication between the two, if suitable.") -(defun outline-rebullet-heading (&optional solicit + (allout-end-of-prefix) + (let* ((new-margin (current-column)) + excess old-indent-begin old-indent-end + curr-ind + ;; We want the column where the header-prefix text started + ;; *before* the prefix was changed, so we infer it relative + ;; to the new margin and the shift in depth: + (old-margin (+ old-depth (- new-margin new-depth)))) + + ;; Process lines up to (but excluding) next topic header: + (allout-unprotected + (save-match-data + (while + (and (re-search-forward "[\n\r]\\(\\s-*\\)" + nil + t) + ;; Register the indent data, before we reset the + ;; match data with a subsequent `looking-at': + (setq old-indent-begin (match-beginning 1) + old-indent-end (match-end 1)) + (not (looking-at allout-regexp))) + (if (> 0 (setq excess (- (current-column) + old-margin))) + ;; Text starts left of old margin - don't adjust: + nil + ;; Text was hanging at or right of old left margin - + ;; reindent it, preserving its existing indentation + ;; beyond the old margin: + (delete-region old-indent-begin old-indent-end) + (indent-to (+ new-margin excess))))))))) +;;;_ > allout-rebullet-current-heading (arg) +(defun allout-rebullet-current-heading (arg) + "Solicit new bullet for current visible heading." + (interactive "p") + (let ((initial-col (current-column)) + (on-bullet (eq (point)(allout-current-bullet-pos))) + (backwards (if (< arg 0) + (setq arg (* arg -1))))) + (while (> arg 0) + (save-excursion (allout-back-to-current-heading) + (allout-end-of-prefix) + (allout-rebullet-heading t ;;; solicit + nil ;;; depth + nil ;;; number-control + nil ;;; index + t)) ;;; do-successors + (setq arg (1- arg)) + (if (<= arg 0) + nil + (setq initial-col nil) ; Override positioning back to init col + (if (not backwards) + (allout-next-visible-heading 1) + (allout-goto-prefix) + (allout-next-visible-heading -1)))) + (message "Done.") + (cond (on-bullet (goto-char (allout-current-bullet-pos))) + (initial-col (move-to-column initial-col))))) +;;;_ > allout-rebullet-heading (&optional solicit ...) +(defun allout-rebullet-heading (&optional solicit new-depth number-control index do-successors) - " Adjust bullet of current topic prefix. - - All args are optional. + "Adjust bullet of current topic prefix. - If SOLICIT is non-nil then the choice of bullet is solicited from - user. Otherwise the distinctiveness of the bullet or the topic - depth determines it. +If SOLICIT is non-nil, then the choice of bullet is solicited from +user. If it's a character, then that character is offered as the +default, otherwise the one suited to the context \(according to +distinction or depth) is offered. If non-nil, then the +context-specific bullet is just used. - Second arg DEPTH forces the topic prefix to that depth, regardless - of the topic's current depth. +Second arg NEW-DEPTH forces the topic prefix to that depth, regardless +of the topic's current depth. - Third arg NUMBER-CONTROL can force the prefix to or away from - numbered form. It has effect only if 'outline-numbered-bullet' is - non-nil and soliciting was not explicitly invoked (via first arg). - Its effect, numbering or denumbering, then depends on the setting - of the forth arg, INDEX. +Third arg NUMBER-CONTROL can force the prefix to or away from +numbered form. It has effect only if `allout-numbered-bullet' is +non-nil and soliciting was not explicitly invoked (via first arg). +Its effect, numbering or denumbering, then depends on the setting +of the fourth arg, INDEX. - If NUMBER-CONTROL is non-nil and forth arg INDEX is nil, then the - prefix of the topic is forced to be non-numbered. Null index and - non-nil NUMBER-CONTROL forces denumbering. Non-nil INDEX (and - non-nil NUMBER-CONTROL) forces a numbered-prefix form. If non-nil - INDEX is a number, then that number is used for the numbered - prefix. Non-nil and non-number means that the index for the - numbered prefix will be derived by outline-make-topic-prefix. +If NUMBER-CONTROL is non-nil and fourth arg INDEX is nil, then the +prefix of the topic is forced to be non-numbered. Null index and +non-nil NUMBER-CONTROL forces denumbering. Non-nil INDEX (and +non-nil NUMBER-CONTROL) forces a numbered-prefix form. If non-nil +INDEX is a number, then that number is used for the numbered +prefix. Non-nil and non-number means that the index for the +numbered prefix will be derived by `allout-make-topic-prefix'. - Fifth arg DO-SUCCESSORS t means re-resolve count on succeeding - siblings. +Fifth arg DO-SUCCESSORS t means re-resolve count on succeeding +siblings. - Cf vars 'outline-stylish-prefixes', 'outline-old-style-prefixes', - and 'outline-numbered-bullet', which all affect the behavior of - this function." +Cf vars `allout-stylish-prefixes', `allout-old-style-prefixes', +and `allout-numbered-bullet', which all affect the behavior of +this function." - (let* ((current-depth (outline-depth)) + (let* ((current-depth (allout-depth)) (new-depth (or new-depth current-depth)) - (mb outline-recent-prefix-beginning) - (me outline-recent-prefix-end) + (mb allout-recent-prefix-beginning) + (me allout-recent-prefix-end) (current-bullet (buffer-substring (- me 1) me)) - (new-prefix (outline-make-topic-prefix current-bullet + (new-prefix (allout-make-topic-prefix current-bullet nil new-depth solicit number-control index))) - ;; Don't need to reinsert identical one: + ;; Is new one is identical to old? (if (and (= current-depth new-depth) (string= current-bullet (substring new-prefix (1- (length new-prefix))))) + ;; Nothing to do: t ;; New prefix probably different from old: - ;; get rid of old one: - (delete-region mb me) + ; get rid of old one: + (allout-unprotected (delete-region mb me)) (goto-char mb) - ;; Dispense with number if numbered-bullet prefix: - (if (and outline-numbered-bullet - (string= outline-numbered-bullet current-bullet) + ; Dispense with number if + ; numbered-bullet prefix: + (if (and allout-numbered-bullet + (string= allout-numbered-bullet current-bullet) (looking-at "[0-9]+")) - (delete-region (match-beginning 0)(match-end 0))) + (allout-unprotected + (delete-region (match-beginning 0)(match-end 0)))) - ;; Put in new prefix: - (insert-string new-prefix) - ) + ; Put in new prefix: + (allout-unprotected (insert new-prefix)) - ;; Reindent the body if elected and depth changed: - (if (and outline-reindent-bodies - (not (= new-depth current-depth))) - (outline-reindent-body current-depth new-depth)) + ;; Reindent the body if elected and margin changed: + (if (and allout-reindent-bodies + (not (= new-depth current-depth))) + (allout-reindent-body current-depth new-depth)) - ;; Recursively rectify successive siblings if selected: - (if do-successors - (save-excursion - (while (outline-next-sibling) - (setq index - (cond ((numberp index) (1+ index)) - ((not number-control) (outline-sibling-index)))) - (if (outline-numbered-type-prefix) - (outline-rebullet-heading nil ;;; solicit - new-depth ;;; new-depth - number-control;;; number-control - index ;;; index - nil))))) ;;;(dont!)do-successors - ) - ) -;;;_ > outline-rebullet-topic (arg) -(defun outline-rebullet-topic (arg) - " Like outline-rebullet-topic-grunt, but start from topic visible at point. - Descends into invisible as well as visible topics, however. + ;; Recursively rectify successive siblings of orig topic if + ;; caller elected for it: + (if do-successors + (save-excursion + (while (allout-next-sibling new-depth nil) + (setq index + (cond ((numberp index) (1+ index)) + ((not number-control) (allout-sibling-index)))) + (if (allout-numbered-type-prefix) + (allout-rebullet-heading nil ;;; solicit + new-depth ;;; new-depth + number-control;;; number-control + index ;;; index + nil))))) ;;;(dont!)do-successors + ) ; (if (and (= current-depth new-depth)...)) + ) ; let* ((current-depth (allout-depth))...) + ) ; defun +;;;_ > allout-rebullet-topic (arg) +(defun allout-rebullet-topic (arg) + "Like `allout-rebullet-topic-grunt', but start from topic visible at point. - With repeat count, shift topic depth by that amount." +Descends into invisible as well as visible topics, however. + +With repeat count, shift topic depth by that amount." (interactive "P") (let ((start-col (current-column)) (was-eol (eolp))) @@ -2047,34 +3024,33 @@ parameterized communication between the two, if suitable.") ((listp arg) (setq arg (car arg)))) ;; Fill the user in, in case we're shifting a big topic: (if (not (zerop arg)) (message "Shifting...")) - (outline-back-to-current-heading) - (if (<= (+ (outline-recent-depth) arg) 0) + (allout-back-to-current-heading) + (if (<= (+ (allout-recent-depth) arg) 0) (error "Attempt to shift topic below level 1")) - (outline-rebullet-topic-grunt arg) + (allout-rebullet-topic-grunt arg) (if (not (zerop arg)) (message "Shifting... done."))) - (move-to-column (max 0 (+ start-col arg)))) - ) -;;;_ > outline-rebullet-topic-grunt (&optional relative-depth ...) -(defun outline-rebullet-topic-grunt (&optional relative-depth + (move-to-column (max 0 (+ start-col arg))))) +;;;_ > allout-rebullet-topic-grunt (&optional relative-depth ...) +(defun allout-rebullet-topic-grunt (&optional relative-depth starting-depth starting-point index do-successors) - " Rebullet the topic at point, visible or invisible, and all - contained subtopics. See outline-rebullet-heading for rebulleting - behavior. + "Rebullet the topic at point, visible or invisible, and all +contained subtopics. See `allout-rebullet-heading' for rebulleting +behavior. - All arguments are optional. +Arg RELATIVE-DEPTH means to shift the depth of the entire +topic that amount. - First arg RELATIVE-DEPTH means to shift the depth of the entire - topic that amount. +\(fn &optional RELATIVE-DEPTH)" - The rest of the args are for internal recursive use by the function - itself. The are STARTING-DEPTH, STARTING-POINT, and INDEX." + ;; All args except the first one are for internal recursive use by the + ;; function itself. (let* ((relative-depth (or relative-depth 0)) - (new-depth (outline-depth)) + (new-depth (allout-depth)) (starting-depth (or starting-depth new-depth)) (on-starting-call (null starting-point)) (index (or index @@ -2082,7 +3058,7 @@ parameterized communication between the two, if suitable.") ;; calculates it at what might be new depth: (and (or (zerop relative-depth) (not on-starting-call)) - (outline-sibling-index)))) + (allout-sibling-index)))) (moving-outwards (< 0 relative-depth)) (starting-point (or starting-point (point)))) @@ -2090,11 +3066,11 @@ parameterized communication between the two, if suitable.") (and on-starting-call moving-outwards (> 0 (+ starting-depth relative-depth)) - (error "Attempt to shift topic out beyond level 1.")) ;;; ====> + (error "Attempt to shift topic out beyond level 1")) ;;; ====> (cond ((= starting-depth new-depth) ;; We're at depth to work on this one: - (outline-rebullet-heading nil ;;; solicit + (allout-rebullet-heading nil ;;; solicit (+ starting-depth ;;; starting-depth relative-depth) nil ;;; number @@ -2105,11 +3081,11 @@ parameterized communication between the two, if suitable.") nil) ;;; do-successors ;; ... and work on subsequent ones which are at greater depth: (setq index 0) - (outline-next-heading) + (allout-next-heading) (while (and (not (eobp)) - (< starting-depth (outline-recent-depth))) + (< starting-depth (allout-recent-depth))) (setq index (1+ index)) - (outline-rebullet-topic-grunt relative-depth ;;; relative-depth + (allout-rebullet-topic-grunt relative-depth ;;; relative-depth (1+ starting-depth);;;starting-depth starting-point ;;; starting-point index))) ;;; index @@ -2117,7 +3093,7 @@ parameterized communication between the two, if suitable.") ((< starting-depth new-depth) ;; Rare case - subtopic more than one level deeper than parent. ;; Treat this one at an even deeper level: - (outline-rebullet-topic-grunt relative-depth ;;; relative-depth + (allout-rebullet-topic-grunt relative-depth ;;; relative-depth new-depth ;;; starting-depth starting-point ;;; starting-point index))) ;;; index @@ -2128,103 +3104,116 @@ parameterized communication between the two, if suitable.") ;; if topic has changed depth (if (or do-successors (and (not (zerop relative-depth)) - (or (= (outline-recent-depth) starting-depth) - (= (outline-recent-depth) (+ starting-depth + (or (= (allout-recent-depth) starting-depth) + (= (allout-recent-depth) (+ starting-depth relative-depth))))) - (outline-rebullet-heading nil nil nil nil t)) + (allout-rebullet-heading nil nil nil nil t)) ;; Now rectify numbering of new siblings of the adjusted topic, ;; if depth has been changed: (progn (goto-char starting-point) (if (not (zerop relative-depth)) - (outline-rebullet-heading nil nil nil nil t))))) + (allout-rebullet-heading nil nil nil nil t))))) ) ) -;;;_ > outline-number-siblings (&optional denumber) -(defun outline-number-siblings (&optional denumber) - " Assign numbered topic prefix to this topic and its siblings. +;;;_ > allout-renumber-to-depth (&optional depth) +(defun allout-renumber-to-depth (&optional depth) + "Renumber siblings at current depth. - With universal argument, denumber - assign default bullet to this - topic and its siblings. +Affects superior topics if optional arg DEPTH is less than current depth. - With repeated universal argument (`^U^U'), solicit bullet for each - rebulleting each topic at this level." +Returns final depth." + + ;; Proceed by level, processing subsequent siblings on each, + ;; ascending until we get shallower than the start depth: + + (let ((ascender (allout-depth)) + was-eobp) + (while (and (not (eobp)) + (allout-depth) + (>= (allout-recent-depth) depth) + (>= ascender depth)) + ; Skip over all topics at + ; lesser depths, which can not + ; have been disturbed: + (while (and (not (setq was-eobp (eobp))) + (> (allout-recent-depth) ascender)) + (allout-next-heading)) + ; Prime ascender for ascension: + (setq ascender (1- (allout-recent-depth))) + (if (>= (allout-recent-depth) depth) + (allout-rebullet-heading nil ;;; solicit + nil ;;; depth + nil ;;; number-control + nil ;;; index + t)) ;;; do-successors + (if was-eobp (goto-char (point-max))))) + (allout-recent-depth)) +;;;_ > allout-number-siblings (&optional denumber) +(defun allout-number-siblings (&optional denumber) + "Assign numbered topic prefix to this topic and its siblings. + +With universal argument, denumber - assign default bullet to this +topic and its siblings. + +With repeated universal argument (`^U^U'), solicit bullet for each +rebulleting each topic at this level." (interactive "P") (save-excursion - (outline-back-to-current-heading) - (outline-beginning-of-level) - (let ((index (if (not denumber) 1)) + (allout-back-to-current-heading) + (allout-beginning-of-level) + (let ((depth (allout-recent-depth)) + (index (if (not denumber) 1)) (use-bullet (equal '(16) denumber)) (more t)) (while more - (outline-rebullet-heading use-bullet ;;; solicit - nil ;;; depth + (allout-rebullet-heading use-bullet ;;; solicit + depth ;;; depth t ;;; number-control index ;;; index nil) ;;; do-successors (if index (setq index (1+ index))) - (setq more (outline-next-sibling))) - ) - ) - ) -;;;_ > outline-shift-in (arg) -(defun outline-shift-in (arg) - " Decrease prefix depth of current heading and any topics collapsed - within it." + (setq more (allout-next-sibling depth nil)))))) +;;;_ > allout-shift-in (arg) +(defun allout-shift-in (arg) + "Increase depth of current heading and any topics collapsed within it." (interactive "p") - (outline-rebullet-topic arg)) -;;;_ > outline-shift-out (arg) -(defun outline-shift-out (arg) - " Decrease prefix depth of current heading and any topics collapsed - within it." + (allout-rebullet-topic arg)) +;;;_ > allout-shift-out (arg) +(defun allout-shift-out (arg) + "Decrease depth of current heading and any topics collapsed within it." (interactive "p") - (outline-rebullet-topic (* arg -1))) -;;;_ . Surgery (kill-ring) functions with special provisions for outlines: -;;;_ > outline-kill-line (&optional arg) -(defun outline-kill-line (&optional arg) - " Kill line, adjusting subsequent lines suitably for outline mode." + (allout-rebullet-topic (* arg -1))) +;;;_ : Surgery (kill-ring) functions with special provisions for outlines: +;;;_ > allout-kill-line (&optional arg) +(defun allout-kill-line (&optional arg) + "Kill line, adjusting subsequent lines suitably for outline mode." (interactive "*P") - (if (not (and - (boundp 'outline-mode) outline-mode ; active outline mode, - outline-numbered-bullet ; numbers may need adjustment, - (bolp) ; may be clipping topic head, - (looking-at outline-regexp))) ; are clipping topic head. + (if (not (and (allout-mode-p) ; active outline mode, + allout-numbered-bullet ; numbers may need adjustment, + (bolp) ; may be clipping topic head, + (looking-at allout-regexp))) ; are clipping topic head. ;; Above conditions do not obtain - just do a regular kill: (kill-line arg) ;; Ah, have to watch out for adjustments: - (let* ((depth (outline-depth)) - (ascender depth)) + (let* ((depth (allout-depth))) + ; Do the kill: (kill-line arg) + ; Provide some feedback: (sit-for 0) (save-excursion - (if (not (looking-at outline-regexp)) - (outline-next-heading)) - (if (> (outline-depth) depth) - ;; An intervening parent was removed from after a subtree: - (setq depth (outline-recent-depth))) - (while (and (> (outline-depth) 0) - (> (outline-recent-depth) ascender) - (outline-ascend-to-depth (setq ascender - (1- ascender))))) - ;; Have to try going forward until we find another at - ;; desired depth: - (if (and outline-numbered-bullet - (outline-descend-to-depth depth)) - (outline-rebullet-heading nil ;;; solicit - depth ;;; depth - nil ;;; number-control - nil ;;; index - t) ;;; do-successors - ) - ) - ) - ) - ) -;;;_ > outline-kill-topic () -(defun outline-kill-topic () - " Kill topic together with subtopics." + ; Start with the topic + ; following killed line: + (if (not (looking-at allout-regexp)) + (allout-next-heading)) + (allout-renumber-to-depth depth))))) +;;;_ > allout-kill-topic () +(defun allout-kill-topic () + "Kill topic together with subtopics. + +Leaves primary topic's trailing vertical whitespace, if any." ;; Some finagling is done to make complex topic kills appear faster ;; than they actually are. A redisplay is performed immediately @@ -2233,174 +3222,218 @@ parameterized communication between the two, if suitable.") ;; a lag *after* the kill has been performed. (interactive) - (let* ((beg (outline-back-to-current-heading)) - (depth (outline-recent-depth))) - (outline-end-of-current-subtree) + (let* ((beg (prog1 (allout-back-to-current-heading)(beginning-of-line))) + (depth (allout-recent-depth))) + (allout-end-of-current-subtree) (if (not (eobp)) - (forward-char 1)) + (if (or (not (looking-at "^$")) + ;; A blank line - cut it with this topic *unless* this + ;; is the last topic at this level, in which case + ;; we'll leave the blank line as part of the + ;; containing topic: + (save-excursion + (and (allout-next-heading) + (>= (allout-recent-depth) depth)))) + (forward-char 1))) + (kill-region beg (point)) (sit-for 0) (save-excursion - (if (and outline-numbered-bullet - (outline-descend-to-depth depth)) - (outline-rebullet-heading nil ;;; solicit - depth ;;; depth - nil ;;; number-control - nil ;;; index - t) ;;; do-successors - ) - ) - ) - ) -;;;_ > outline-yank (&optional arg) -(defun outline-yank (&optional arg) - " Like regular yank, except does depth adjustment of yanked topics, when: + (allout-renumber-to-depth depth)))) +;;;_ > allout-yank-processing () +(defun allout-yank-processing (&optional arg) + + "Incidental outline specific business to be done just after text yanks. + +Does depth adjustment of yanked topics, when: - 1 the stuff being yanked starts with a valid outline header prefix, and - 2 it is being yanked at the end of a line which consists of only a valid +1 the stuff being yanked starts with a valid outline header prefix, and +2 it is being yanked at the end of a line which consists of only a valid topic prefix. - If these two conditions hold then the depth of the yanked topics - are all adjusted the amount it takes to make the first one at the - depth of the header into which it's being yanked. +Also, adjusts numbering of subsequent siblings when appropriate. - The point is left in from of yanked, adjusted topics, rather than - at the end (and vice-versa with the mark). Non-adjusted yanks, - however, (ones that don't qualify for adjustment) are handled - exactly like normal yanks. +Depth adjustment alters the depth of all the topics being yanked +the amount it takes to make the first topic have the depth of the +header into which it's being yanked. - Outline-yank-pop is used with outline-yank just as normal yank-pop - is used with normal yank in non-outline buffers." +The point is left in front of yanked, adjusted topics, rather than +at the end (and vice-versa with the mark). Non-adjusted yanks, +however, are left exactly like normal, not outline specific yanks." + + (interactive "*P") + ; Get to beginning, leaving + ; region around subject: + (if (< (my-mark-marker t) (point)) + (exchange-point-and-mark)) + (let* ((subj-beg (point)) + (subj-end (my-mark-marker t)) + ;; 'resituate' if yanking an entire topic into topic header: + (resituate (and (allout-e-o-prefix-p) + (looking-at (concat "\\(" allout-regexp "\\)")) + (allout-prefix-data (match-beginning 1) + (match-end 1)))) + ;; `rectify-numbering' if resituating (where several topics may + ;; be resituating) or yanking a topic into a topic slot (bol): + (rectify-numbering (or resituate + (and (bolp) (looking-at allout-regexp))))) + (if resituate + ; The yanked stuff is a topic: + (let* ((prefix-len (- (match-end 1) subj-beg)) + (subj-depth (allout-recent-depth)) + (prefix-bullet (allout-recent-bullet)) + (adjust-to-depth + ;; Nil if adjustment unnecessary, otherwise depth to which + ;; adjustment should be made: + (save-excursion + (and (goto-char subj-end) + (eolp) + (goto-char subj-beg) + (and (looking-at allout-regexp) + (progn + (beginning-of-line) + (not (= (point) subj-beg))) + (looking-at allout-regexp) + (allout-prefix-data (match-beginning 0) + (match-end 0))) + (allout-recent-depth)))) + done + (more t)) + (setq rectify-numbering allout-numbered-bullet) + (if adjust-to-depth + ; Do the adjustment: + (progn + (message "... yanking") (sit-for 0) + (save-restriction + (narrow-to-region subj-beg subj-end) + ; Trim off excessive blank + ; line at end, if any: + (goto-char (point-max)) + (if (looking-at "^$") + (allout-unprotected (delete-char -1))) + ; Work backwards, with each + ; shallowest level, + ; successively excluding the + ; last processed topic from + ; the narrow region: + (while more + (allout-back-to-current-heading) + ; go as high as we can in each bunch: + (while (allout-ascend-to-depth (1- (allout-depth)))) + (save-excursion + (allout-rebullet-topic-grunt (- adjust-to-depth + subj-depth)) + (allout-depth)) + (if (setq more (not (bobp))) + (progn (widen) + (forward-char -1) + (narrow-to-region subj-beg (point)))))) + (message "") + ;; Preserve new bullet if it's a distinctive one, otherwise + ;; use old one: + (if (string-match (regexp-quote prefix-bullet) + allout-distinctive-bullets-string) + ; Delete from bullet of old to + ; before bullet of new: + (progn + (beginning-of-line) + (delete-region (point) subj-beg) + (set-marker (my-mark-marker t) subj-end) + (goto-char subj-beg) + (allout-end-of-prefix)) + ; Delete base subj prefix, + ; leaving old one: + (delete-region (point) (+ (point) + prefix-len + (- adjust-to-depth subj-depth))) + ; and delete residual subj + ; prefix digits and space: + (while (looking-at "[0-9]") (delete-char 1)) + (if (looking-at " ") (delete-char 1)))) + (exchange-point-and-mark)))) + (if rectify-numbering + (progn + (save-excursion + ; Give some preliminary feedback: + (message "... reconciling numbers") (sit-for 0) + ; ... and renumber, in case necessary: + (goto-char subj-beg) + (if (allout-goto-prefix) + (allout-rebullet-heading nil ;;; solicit + (allout-depth) ;;; depth + nil ;;; number-control + nil ;;; index + t)) + (message "")))) + (if (not resituate) + (exchange-point-and-mark)))) +;;;_ > allout-yank (&optional arg) +(defun allout-yank (&optional arg) + "`allout-mode' yank, with depth and numbering adjustment of yanked topics. + +Non-topic yanks work no differently than normal yanks. + +If a topic is being yanked into a bare topic prefix, the depth of the +yanked topic is adjusted to the depth of the topic prefix. + + 1 we're yanking in an `allout-mode' buffer + 2 the stuff being yanked starts with a valid outline header prefix, and + 3 it is being yanked at the end of a line which consists of only a valid + topic prefix. + +If these conditions hold then the depth of the yanked topics are all +adjusted the amount it takes to make the first one at the depth of the +header into which it's being yanked. + +The point is left in front of yanked, adjusted topics, rather than +at the end (and vice-versa with the mark). Non-adjusted yanks, +however, (ones that don't qualify for adjustment) are handled +exactly like normal yanks. + +Numbering of yanked topics, and the successive siblings at the depth +into which they're being yanked, is adjusted. + +`allout-yank-pop' works with `allout-yank' just like normal `yank-pop' +works with normal `yank' in non-outline buffers." (interactive "*P") (setq this-command 'yank) - (if (not (and (boundp 'outline-mode) outline-mode)) - - ;; Outline irrelevant - just do regular yank: - (yank arg) - - ;; Outline *is* relevant: - (let ((beginning (point)) - topic-yanked - established-depth) ; Depth of the prefix into which we're yanking. - ;; Get current depth and numbering ... Oops, not doing anything - ;; with the number just yet... - (if (and (eolp) - (save-excursion (beginning-of-line) - (looking-at outline-regexp))) - (setq established-depth (- (match-end 0) (match-beginning 0)))) - (yank arg) - (exchange-dot-and-mark) - (if (and established-depth ; the established stuff qualifies. - ;; The yanked stuff also qualifies - is topic(s): - (looking-at (concat "\\(" outline-regexp "\\)"))) - ;; Ok, adjust the depth of the yanked stuff. Note that the - ;; stuff may have more than a single root, so we have to - ;; iterate over all the top level ones yanked, and do them in - ;; such a way that the adjustment of one new one won't affect - ;; any of the other new ones. We use the focus of the - ;; narrowed region to successively exclude processed siblings. - (let* ((yanked-beg (match-beginning 1)) - (yanked-end (match-end 1)) - (yanked-bullet (buffer-substring (1- yanked-end) yanked-end)) - (yanked-depth (- yanked-end yanked-beg)) - (depth-diff (- established-depth yanked-depth)) - done - (more t)) - (setq topic-yanked t) - (save-excursion - (save-restriction - (narrow-to-region yanked-beg (mark)) - ;; First trim off excessive blank line at end, if any: - (goto-char (point-max)) - (if (looking-at "^$") (delete-char -1)) - (goto-char (point-min)) - ;; Work backwards, with each shallowest level, - ;; successively excluding the last processed topic - ;; from the narrow region: - (goto-char (point-max)) - (while more - (outline-back-to-current-heading) - ;; go as high as we can in each bunch: - (while (outline-ascend-to-depth - (1- (outline-depth)))) - (save-excursion - (outline-rebullet-topic-grunt depth-diff - (outline-depth) - (point))) - (if (setq more (not (bobp))) - (progn (widen) - (forward-char -1) - (narrow-to-region yanked-beg (point))))))) - ;; Preserve new bullet if it's a distinctive one, otherwise - ;; use old one: - (if (string-match yanked-bullet outline-distinctive-bullets-string) - (delete-region (save-excursion - (beginning-of-line) - (point)) - yanked-beg) - (delete-region yanked-beg (+ yanked-beg established-depth)) - ;; and extraneous digits and a space: - (while (looking-at "[0-9]") (delete-char 1)) - (if (looking-at " ") (delete-char 1)) - ) - (goto-char yanked-beg) - ) - ;; Not established-depth or looking-at... - (setq topic-yanked (looking-at outline-regexp)) - (exchange-dot-and-mark)) - (if (and topic-yanked outline-numbered-bullet) - (progn - ;; Renumber, in case necessary: - (sit-for 0) - (save-excursion - (goto-char beginning) - (if (outline-goto-prefix) - (outline-rebullet-heading nil ;;; solicit - (outline-depth) ;;; depth - nil ;;; number-control - nil ;;; index - t) ;;; do-successors - ) - ) - ) - ) - ) - ) - ) -;;;_ > outline-yank-pop (&optional arg) -(defun outline-yank-pop (&optional arg) - " Just like yank-pop, but works like outline-yank when popping - topics just after fresh outline prefixes. Adapts level of popped - stuff to level of fresh prefix." + (yank arg) + (if (allout-mode-p) + (allout-yank-processing))) +;;;_ > allout-yank-pop (&optional arg) +(defun allout-yank-pop (&optional arg) + "Yank-pop like `allout-yank' when popping to bare outline prefixes. + +Adapts level of popped topics to level of fresh prefix. + +Note - prefix changes to distinctive bullets will stick, if followed +by pops to non-distinctive yanks. Bug..." (interactive "*p") - (if (not (eq last-command 'yank)) - (error "Previous command was not a yank")) (setq this-command 'yank) - (delete-region (point) (mark)) - (rotate-yank-pointer arg) - (outline-yank) - ) + (yank-pop arg) + (if (allout-mode-p) + (allout-yank-processing))) -;;;_ : Specialty bullet functions -;;;_ . File Cross references -;;;_ > outline-resolve-xref () -(defun outline-resolve-xref () - " Pop to file associated with current heading, if it has an xref bullet - (according to setting of 'outline-file-xref-bullet')." +;;;_ - Specialty bullet functions +;;;_ : File Cross references +;;;_ > allout-resolve-xref () +(defun allout-resolve-xref () + "Pop to file associated with current heading, if it has an xref bullet. + +\(Works according to setting of `allout-file-xref-bullet')." (interactive) - (if (not outline-file-xref-bullet) + (if (not allout-file-xref-bullet) (error - "outline cross references disabled - no 'outline-file-xref-bullet'") - (if (not (string= (outline-current-bullet) outline-file-xref-bullet)) - (error "current heading lacks cross-reference bullet '%s'" - outline-file-xref-bullet) + "Outline cross references disabled - no `allout-file-xref-bullet'") + (if (not (string= (allout-current-bullet) allout-file-xref-bullet)) + (error "Current heading lacks cross-reference bullet `%s'" + allout-file-xref-bullet) (let (file-name) (save-excursion - (let* ((text-start outline-recent-prefix-end) - (heading-end (progn (outline-pre-next-preface) - (point)))) + (let* ((text-start allout-recent-prefix-end) + (heading-end (progn (end-of-line) (point)))) (goto-char text-start) (setq file-name (if (re-search-forward "\\s-\\(\\S-*\\)" heading-end t) @@ -2408,7 +3441,7 @@ parameterized communication between the two, if suitable.") (setq file-name (if (not (= (aref file-name 0) ?:)) (expand-file-name file-name) - ; A registry-files ref, strip the ':' + ; A registry-files ref, strip the `:' ; and try to follow it: (let ((reg-ref (reference-registered-file (substring file-name 1) nil t))) @@ -2420,142 +3453,1112 @@ parameterized communication between the two, if suitable.") (error "%s not found and can't be created" file-name))) (condition-case failure (find-file-other-window file-name) - (error failure)) + ('error failure)) (error "%s not found" file-name)) ) ) ) ) -;;;_ > outline-to-entry-end - Unmaintained compatibility - ignore this! -;------------------------------------------------------------------- -; Something added solely for use by a "smart menu" package someone got -; off the net. I have no idea whether this is appropriate code. - -(defvar next-entry-exists nil "Used by outline-to-entry-end, dunno why.") -(defun outline-to-entry-end (&optional include-sub-entries curr-entry-level) - " Go to end of whole entry if optional INCLUDE-SUB-ENTRIES is non-nil. - CURR-ENTRY-LEVEL is an integer representing the length of the current level - string which matched to 'outline-regexp'. If INCLUDE-SUB-ENTRIES is nil, - CURR-ENTRY-LEVEL is not needed." - (while (and (setq next-entry-exists - (re-search-forward outline-regexp nil t)) - include-sub-entries - (save-excursion - (beginning-of-line) - (> (outline-depth) curr-entry-level)))) - (if next-entry-exists - (progn (beginning-of-line) (point)) - (goto-char (point-max)))) -;;; Outline topic prefix and level adjustment funcs: - -;;;_ #6 miscellaneous -;;;_ > outline-copy-exposed (&optional workbuf) -(defun outline-copy-exposed (&optional workbuf) - " Duplicate buffer to other buffer, sans hidden stuff. - - Without repeat count, this simple-minded function just generates - the new buffer by concatenating the current buffer name with \" - exposed\", and doing a 'get-buffer' on it." + +;;;_ #6 Exposure Control + +;;;_ - Fundamental +;;;_ > allout-flag-current-subtree (flag) +(defun allout-flag-current-subtree (flag) + "Hide or show subtree of currently-visible topic. + +See `allout-flag-region' for more details." + + (save-excursion + (allout-back-to-current-heading) + (allout-flag-region (point) + (progn (allout-end-of-current-subtree) (1- (point))) + flag))) + +;;;_ - Topic-specific +;;;_ > allout-show-entry () +(defun allout-show-entry () + "Like `allout-show-current-entry', reveals entries nested in hidden topics. + +This is a way to give restricted peek at a concealed locality without the +expense of exposing its context, but can leave the outline with aberrant +exposure. `allout-hide-current-entry-completely' or `allout-show-to-offshoot' +should be used after the peek to rectify the exposure." (interactive) - (if (not workbuf) (setq workbuf (concat (buffer-name) " exposed"))) - (let ((buf (current-buffer))) - (if (not (get-buffer workbuf)) - (generate-new-buffer workbuf)) - (pop-to-buffer workbuf) - (erase-buffer) - (insert-buffer buf) - (replace-regexp "\^M[^\^M\^J]*" "") - (goto-char (point-min)) - ) - ) -;;;_ > outlinify-sticky () -(defun outlinify-sticky (&optional arg) - " Activate outline mode and establish file eval to set initial exposure. - - Invoke with a string argument to designate a string to prepend to - topic prefixs, or with a universal argument to be prompted for the - string to be used. Suitable defaults are provided for lisp, - emacs-lisp, c, c++, awk, sh, csh, and perl modes." - - (interactive "P") (outline-mode t) - (cond (arg - (if (stringp arg) - ;; Use arg as the header-prefix: - (outline-lead-with-comment-string arg) - ;; Otherwise, let function solicit string: - (setq arg (outline-lead-with-comment-string)))) - ((member major-mode '(emacs-lisp-mode lisp-mode)) - (setq arg (outline-lead-with-comment-string ";;;_"))) - ((member major-mode '(awk-mode csh-mode sh-mode perl-mode)) - ;; Bare '#' (ie, not '#_') so we don't break the magic number: - (setq arg (outline-lead-with-comment-string "#"))) - ((eq major-mode 'c++-mode) - (setq arg (outline-lead-with-comment-string "//_"))) - ((eq major-mode 'c-mode) - ;; User's will have to know to close off the comments: - (setq arg (outline-lead-with-comment-string "/*_")))) - (let* ((lead-prefix (format "%s%s" - (concat outline-header-prefix (if arg " " "")) - outline-primary-bullet)) - (lead-line (format "%s%s %s\n%s %s\n %s %s %s" - (if arg outline-header-prefix "") - outline-primary-bullet - "Local emacs vars." - "'(This topic sets initial outline exposure" - "of the file when loaded by emacs," - "Encapsulate it in comments if" - "file is a program" - "otherwise ignore it,"))) + (save-excursion + (let ((at (point)) + beg end) + (allout-goto-prefix) + (setq beg (if (= (preceding-char) ?\r) (1- (point)) (point))) + (re-search-forward "[\n\r]" nil t) + (setq end (1- (if (< at (point)) + ;; We're on topic head line - show only it: + (point) + ;; or we're in body - include it: + (max beg (or (allout-pre-next-preface) (point)))))) + (allout-flag-region beg end ?\n) + (list beg end)))) +;;;_ > allout-show-children (&optional level strict) +(defun allout-show-children (&optional level strict) + + "If point is visible, show all direct subheadings of this heading. + +Otherwise, do `allout-show-to-offshoot', and then show subheadings. + +Optional LEVEL specifies how many levels below the current level +should be shown, or all levels if t. Default is 1. + +Optional STRICT means don't resort to -show-to-offshoot, no matter +what. This is basically so -show-to-offshoot, which is called by +this function, can employ the pure offspring-revealing capabilities of +it. + +Returns point at end of subtree that was opened, if any. (May get a +point of non-opened subtree?)" + + (interactive "p") + (let (max-pos) + (if (and (not strict) + (allout-hidden-p)) + + (progn (allout-show-to-offshoot) ; Point's concealed, open to + ; expose it. + ;; Then recurse, but with "strict" set so we don't + ;; infinite regress: + (setq max-pos (allout-show-children level t))) + + (save-excursion + (save-restriction + (let* ((start-pt (point)) + (chart (allout-chart-subtree (or level 1))) + (to-reveal (allout-chart-to-reveal chart (or level 1)))) + (goto-char start-pt) + (if (and strict (= (preceding-char) ?\r)) + ;; Concealed root would already have been taken care of, + ;; unless strict was set. + (progn + (allout-flag-region (point) (allout-snug-back) ?\n) + (if allout-show-bodies + (progn (goto-char (car to-reveal)) + (allout-show-current-entry))))) + (while to-reveal + (goto-char (car to-reveal)) + (allout-flag-region (point) (allout-snug-back) ?\n) + (if allout-show-bodies + (progn (goto-char (car to-reveal)) + (allout-show-current-entry))) + (setq to-reveal (cdr to-reveal))))))))) +;;;_ > allout-hide-point-reconcile () +(defun allout-hide-reconcile () + "Like `allout-hide-current-entry'; hides completely if within hidden region. + +Specifically intended for aberrant exposure states, like entries that were +exposed by `allout-show-entry' but are within otherwise concealed regions." + (interactive) + (save-excursion + (allout-goto-prefix) + (allout-flag-region (if (not (bobp)) (1- (point)) (point)) + (progn (allout-pre-next-preface) + (if (= ?\r (following-char)) + (point) + (1- (point)))) + ?\r))) +;;;_ > allout-show-to-offshoot () +(defun allout-show-to-offshoot () + "Like `allout-show-entry', but reveals all concealed ancestors, as well. +As with `allout-hide-current-entry-completely', useful for rectifying +aberrant exposure states produced by `allout-show-entry'." + + (interactive) + (save-excursion + (let ((orig-pt (point)) + (orig-pref (allout-goto-prefix)) + (last-at (point)) + bag-it) + (while (or bag-it (= (preceding-char) ?\r)) + (beginning-of-line) + (if (= last-at (setq last-at (point))) + ;; Oops, we're not making any progress! Show the current + ;; topic completely, and bag this try. + (progn (beginning-of-line) + (allout-show-current-subtree) + (goto-char orig-pt) + (setq bag-it t) + (beep) + (message "%s: %s" + "allout-show-to-offshoot: " + "Aberrant nesting encountered."))) + (allout-show-children) + (goto-char orig-pref)) + (goto-char orig-pt))) + (if (allout-hidden-p) + (allout-show-entry))) +;;;_ > allout-hide-current-entry () +(defun allout-hide-current-entry () + "Hide the body directly following this heading." + (interactive) + (allout-back-to-current-heading) + (save-excursion + (allout-flag-region (point) + (progn (allout-end-of-current-entry) (point)) + ?\r))) +;;;_ > allout-show-current-entry (&optional arg) +(defun allout-show-current-entry (&optional arg) + + "Show body following current heading, or hide the entry if repeat count." + + (interactive "P") + (if arg + (allout-hide-current-entry) (save-excursion - ; Put a topic at the top, if - ; none there already: + (allout-flag-region (point) + (progn (allout-end-of-current-entry) (point)) + ?\n)))) +;;;_ > allout-hide-current-entry-completely () +; ... allout-hide-current-entry-completely also for isearch dynamic exposure: +(defun allout-hide-current-entry-completely () + "Like `allout-hide-current-entry', but conceal topic completely. + +Specifically intended for aberrant exposure states, like entries that were +exposed by `allout-show-entry' but are within otherwise concealed regions." + (interactive) + (save-excursion + (allout-goto-prefix) + (allout-flag-region (if (not (bobp)) (1- (point)) (point)) + (progn (allout-pre-next-preface) + (if (= ?\r (following-char)) + (point) + (1- (point)))) + ?\r))) +;;;_ > allout-show-current-subtree (&optional arg) +(defun allout-show-current-subtree (&optional arg) + "Show everything within the current topic. With a repeat-count, +expose this topic and its siblings." + (interactive "P") + (save-excursion + (if (<= (allout-current-depth) 0) + ;; Outside any topics - try to get to the first: + (if (not (allout-next-heading)) + (error "No topics") + ;; got to first, outermost topic - set to expose it and siblings: + (message "Above outermost topic - exposing all.") + (allout-flag-region (point-min)(point-max) ?\n)) + (if (not arg) + (allout-flag-current-subtree ?\n) + (allout-beginning-of-level) + (allout-expose-topic '(* :)))))) +;;;_ > allout-hide-current-subtree (&optional just-close) +(defun allout-hide-current-subtree (&optional just-close) + "Close the current topic, or containing topic if this one is already closed. + +If this topic is closed and it's a top level topic, close this topic +and its siblings. + +If optional arg JUST-CLOSE is non-nil, do not treat the parent or +siblings, even if the target topic is already closed." + + (interactive) + (let ((from (point)) + (orig-eol (progn (end-of-line) + (if (not (allout-goto-prefix)) + (error "No topics found") + (end-of-line)(point))))) + (allout-flag-current-subtree ?\r) + (goto-char from) + (if (and (= orig-eol (progn (goto-char orig-eol) + (end-of-line) + (point))) + (not just-close) + ;; Structure didn't change - try hiding current level: + (goto-char from) + (if (allout-up-current-level 1 t) + t + (goto-char 0) + (let ((msg + "Top-level topic already closed - closing siblings...")) + (message msg) + (allout-expose-topic '(0 :)) + (message (concat msg " Done."))) + nil) + (/= (allout-recent-depth) 0)) + (allout-hide-current-subtree)) + (goto-char from))) +;;;_ > allout-show-current-branches () +(defun allout-show-current-branches () + "Show all subheadings of this heading, but not their bodies." + (interactive) + (beginning-of-line) + (allout-show-children t)) +;;;_ > allout-hide-current-leaves () +(defun allout-hide-current-leaves () + "Hide the bodies of the current topic and all its offspring." + (interactive) + (allout-back-to-current-heading) + (allout-hide-region-body (point) (progn (allout-end-of-current-subtree) + (point)))) + +;;;_ - Region and beyond +;;;_ > allout-show-all () +(defun allout-show-all () + "Show all of the text in the buffer." + (interactive) + (message "Exposing entire buffer...") + (allout-flag-region (point-min) (point-max) ?\n) + (message "Exposing entire buffer... Done.")) +;;;_ > allout-hide-bodies () +(defun allout-hide-bodies () + "Hide all of buffer except headings." + (interactive) + (allout-hide-region-body (point-min) (point-max))) +;;;_ > allout-hide-region-body (start end) +(defun allout-hide-region-body (start end) + "Hide all body lines in the region, but not headings." + (save-excursion + (save-restriction + (narrow-to-region start end) (goto-char (point-min)) - (if (not (looking-at outline-regexp)) - (insert-string - (if (not arg) outline-primary-bullet - (format "%s%s\n" outline-header-prefix outline-primary-bullet)))) - - ; File-vars stuff, at the bottom: + (while (not (eobp)) + (allout-flag-region (point) + (progn (allout-pre-next-preface) (point)) ?\r) + (if (not (eobp)) + (forward-char + (if (looking-at "[\n\r][\n\r]") + 2 1))))))) + +;;;_ > allout-expose-topic (spec) +(defun allout-expose-topic (spec) + "Apply exposure specs to successive outline topic items. + +Use the more convenient frontend, `allout-new-exposure', if you don't +need evaluation of the arguments, or even better, the `allout-layout' +variable-keyed mode-activation/auto-exposure feature of allout outline +mode. See the respective documentation strings for more details. + +Cursor is left at start position. + +SPEC is either a number or a list. + +Successive specs on a list are applied to successive sibling topics. + +A simple spec \(either a number, one of a few symbols, or the null +list) dictates the exposure for the corresponding topic. + +Non-null lists recursively designate exposure specs for respective +subtopics of the current topic. + +The `:' repeat spec is used to specify exposure for any number of +successive siblings, up to the trailing ones for which there are +explicit specs following the `:'. + +Simple (numeric and null-list) specs are interpreted as follows: + + Numbers indicate the relative depth to open the corresponding topic. + - negative numbers force the topic to be closed before opening to the + absolute value of the number, so all siblings are open only to + that level. + - positive numbers open to the relative depth indicated by the + number, but do not force already opened subtopics to be closed. + - 0 means to close topic - hide all offspring. + : - `repeat' + apply prior element to all siblings at current level, *up to* + those siblings that would be covered by specs following the `:' + on the list. Ie, apply to all topics at level but the last + ones. \(Only first of multiple colons at same level is + respected - subsequent ones are discarded.) + * - completely opens the topic, including bodies. + + - shows all the sub headers, but not the bodies + - - exposes the body of the corresponding topic. + +Examples: +\(allout-expose-topic '(-1 : 0)) + Close this and all following topics at current level, exposing + only their immediate children, but close down the last topic + at this current level completely. +\(allout-expose-topic '(-1 () : 1 0)) + Close current topic so only the immediate subtopics are shown; + show the children in the second to last topic, and completely + close the last one. +\(allout-expose-topic '(-2 : -1 *)) + Expose children and grandchildren of all topics at current + level except the last two; expose children of the second to + last and completely open the last one." + + (interactive "xExposure spec: ") + (if (not (listp spec)) + nil + (let ((depth (allout-depth)) + (max-pos 0) + prev-elem curr-elem + stay done + snug-back + ) + (while spec + (setq prev-elem curr-elem + curr-elem (car spec) + spec (cdr spec)) + (cond ; Do current element: + ((null curr-elem) nil) + ((symbolp curr-elem) + (cond ((eq curr-elem '*) (allout-show-current-subtree) + (if (> allout-recent-end-of-subtree max-pos) + (setq max-pos allout-recent-end-of-subtree))) + ((eq curr-elem '+) (allout-show-current-branches) + (if (> allout-recent-end-of-subtree max-pos) + (setq max-pos allout-recent-end-of-subtree))) + ((eq curr-elem '-) (allout-show-current-entry)) + ((eq curr-elem ':) + (setq stay t) + ;; Expand the `repeat' spec to an explicit version, + ;; w.r.t. remaining siblings: + (let ((residue ; = # of sibs not covered by remaining spec + ;; Dang - could be nice to make use of the chart, sigh: + (- (length (allout-chart-siblings)) + (length spec)))) + (if (< 0 residue) + ;; Some residue - cover it with prev-elem: + (setq spec (append (make-list residue prev-elem) + spec))))))) + ((numberp curr-elem) + (if (and (>= 0 curr-elem) (allout-visible-p)) + (save-excursion (allout-hide-current-subtree t) + (if (> 0 curr-elem) + nil + (if (> allout-recent-end-of-subtree max-pos) + (setq max-pos + allout-recent-end-of-subtree))))) + (if (> (abs curr-elem) 0) + (progn (allout-show-children (abs curr-elem)) + (if (> allout-recent-end-of-subtree max-pos) + (setq max-pos allout-recent-end-of-subtree))))) + ((listp curr-elem) + (if (allout-descend-to-depth (1+ depth)) + (let ((got (allout-expose-topic curr-elem))) + (if (and got (> got max-pos)) (setq max-pos got)))))) + (cond (stay (setq stay nil)) + ((listp (car spec)) nil) + ((> max-pos (point)) + ;; Capitalize on max-pos state to get us nearer next sibling: + (progn (goto-char (min (point-max) max-pos)) + (allout-next-heading))) + ((allout-next-sibling depth)))) + max-pos))) +;;;_ > allout-old-expose-topic (spec &rest followers) +(defun allout-old-expose-topic (spec &rest followers) + "Dictate wholesale exposure scheme for current topic, according to SPEC. + +SPEC is either a number or a list. Optional successive args +dictate exposure for subsequent siblings of current topic. + +A simple spec (either a number, a special symbol, or the null list) +dictates the overall exposure for a topic. Non null lists are +composite specs whose first element dictates the overall exposure for +a topic, with the subsequent elements in the list interpreted as specs +that dictate the exposure for the successive offspring of the topic. + +Simple (numeric and null-list) specs are interpreted as follows: + + - Numbers indicate the relative depth to open the corresponding topic: + - negative numbers force the topic to be close before opening to the + absolute value of the number. + - positive numbers just open to the relative depth indicated by the number. + - 0 just closes + - `*' completely opens the topic, including bodies. + - `+' shows all the sub headers, but not the bodies + - `-' exposes the body and immediate offspring of the corresponding topic. + +If the spec is a list, the first element must be a number, which +dictates the exposure depth of the topic as a whole. Subsequent +elements of the list are nested SPECs, dictating the specific exposure +for the corresponding offspring of the topic. + +Optional FOLLOWERS arguments dictate exposure for succeeding siblings." + + (interactive "xExposure spec: ") + (let ((depth (allout-current-depth)) + done + max-pos) + (cond ((null spec) nil) + ((symbolp spec) + (if (eq spec '*) (allout-show-current-subtree)) + (if (eq spec '+) (allout-show-current-branches)) + (if (eq spec '-) (allout-show-current-entry))) + ((numberp spec) + (if (>= 0 spec) + (save-excursion (allout-hide-current-subtree t) + (end-of-line) + (if (or (not max-pos) + (> (point) max-pos)) + (setq max-pos (point))) + (if (> 0 spec) + (setq spec (* -1 spec))))) + (if (> spec 0) + (allout-show-children spec))) + ((listp spec) + ;(let ((got (allout-old-expose-topic (car spec)))) + ; (if (and got (or (not max-pos) (> got max-pos))) + ; (setq max-pos got))) + (let ((new-depth (+ (allout-current-depth) 1)) + got) + (setq max-pos (allout-old-expose-topic (car spec))) + (setq spec (cdr spec)) + (if (and spec + (allout-descend-to-depth new-depth) + (not (allout-hidden-p))) + (progn (setq got (apply 'allout-old-expose-topic spec)) + (if (and got (or (not max-pos) (> got max-pos))) + (setq max-pos got))))))) + (while (and followers + (progn (if (and max-pos (< (point) max-pos)) + (progn (goto-char max-pos) + (setq max-pos nil))) + (end-of-line) + (allout-next-sibling depth))) + (allout-old-expose-topic (car followers)) + (setq followers (cdr followers))) + max-pos)) +(make-obsolete 'allout-old-expose-topic + "use `allout-expose-topic' (with different schema format) instead." + "19.23") +;;;_ > allout-new-exposure '() +(defmacro allout-new-exposure (&rest spec) + "Literal frontend for `allout-expose-topic', doesn't evaluate arguments. +Some arguments that would need to be quoted in `allout-expose-topic' +need not be quoted in `allout-new-exposure'. + +Cursor is left at start position. + +Examples: +\(allout-new-exposure (-1 () () () 1) 0) + Close current topic at current level so only the immediate + subtopics are shown, except also show the children of the + third subtopic; and close the next topic at the current level. +\(allout-new-exposure : -1 0) + Close all topics at current level to expose only their + immediate children, except for the last topic at the current + level, in which even its immediate children are hidden. +\(allout-new-exposure -2 : -1 *) + Expose children and grandchildren of first topic at current + level, and expose children of subsequent topics at current + level *except* for the last, which should be opened completely." + (list 'save-excursion + '(if (not (or (allout-goto-prefix) + (allout-next-heading))) + (error "allout-new-exposure: Can't find any outline topics")) + (list 'allout-expose-topic (list 'quote spec)))) + +;;;_ #7 Systematic outline presentation - copying, printing, flattening + +;;;_ - Mapping and processing of topics +;;;_ ( See also Subtree Charting, in Navigation code.) +;;;_ > allout-stringify-flat-index (flat-index) +(defun allout-stringify-flat-index (flat-index &optional context) + "Convert list representing section/subsection/... to document string. + +Optional arg CONTEXT indicates interior levels to include." + (let ((delim ".") + result + numstr + (context-depth (or (and context 2) 1))) + ;; Take care of the explicit context: + (while (> context-depth 0) + (setq numstr (int-to-string (car flat-index)) + flat-index (cdr flat-index) + result (if flat-index + (cons delim (cons numstr result)) + (cons numstr result)) + context-depth (if flat-index (1- context-depth) 0))) + (setq delim " ") + ;; Take care of the indentation: + (if flat-index + (progn + (while flat-index + (setq result + (cons delim + (cons (make-string + (1+ (truncate (if (zerop (car flat-index)) + 1 + (log10 (car flat-index))))) + ? ) + result))) + (setq flat-index (cdr flat-index))) + ;; Dispose of single extra delim: + (setq result (cdr result)))) + (apply 'concat result))) +;;;_ > allout-stringify-flat-index-plain (flat-index) +(defun allout-stringify-flat-index-plain (flat-index) + "Convert list representing section/subsection/... to document string." + (let ((delim ".") + result) + (while flat-index + (setq result (cons (int-to-string (car flat-index)) + (if result + (cons delim result)))) + (setq flat-index (cdr flat-index))) + (apply 'concat result))) +;;;_ > allout-stringify-flat-index-indented (flat-index) +(defun allout-stringify-flat-index-indented (flat-index) + "Convert list representing section/subsection/... to document string." + (let ((delim ".") + result + numstr) + ;; Take care of the explicit context: + (setq numstr (int-to-string (car flat-index)) + flat-index (cdr flat-index) + result (if flat-index + (cons delim (cons numstr result)) + (cons numstr result))) + (setq delim " ") + ;; Take care of the indentation: + (if flat-index + (progn + (while flat-index + (setq result + (cons delim + (cons (make-string + (1+ (truncate (if (zerop (car flat-index)) + 1 + (log10 (car flat-index))))) + ? ) + result))) + (setq flat-index (cdr flat-index))) + ;; Dispose of single extra delim: + (setq result (cdr result)))) + (apply 'concat result))) +;;;_ > allout-listify-exposed (&optional start end format) +(defun allout-listify-exposed (&optional start end format) + + "Produce a list representing exposed topics in current region. + +This list can then be used by `allout-process-exposed' to manipulate +the subject region. + +Optional START and END indicate bounds of region. + +optional arg, FORMAT, designates an alternate presentation form for +the prefix: + + list - Present prefix as numeric section.subsection..., starting with + section indicated by the list, innermost nesting first. + `indent' \(symbol) - Convert header prefixes to all white space, + except for distinctive bullets. + +The elements of the list produced are lists that represents a topic +header and body. The elements of that list are: + + - a number representing the depth of the topic, + - a string representing the header-prefix, including trailing whitespace and + bullet. + - a string representing the bullet character, + - and a series of strings, each containing one line of the exposed + portion of the topic entry." + + (interactive "r") + (save-excursion + (let* + ;; state vars: + (strings prefix pad result depth new-depth out gone-out bullet beg + next done) + + (goto-char start) + (beginning-of-line) + ;; Goto initial topic, and register preceeding stuff, if any: + (if (> (allout-goto-prefix) start) + ;; First topic follows beginning point - register preliminary stuff: + (setq result (list (list 0 "" nil + (buffer-substring start (1- (point))))))) + (while (and (not done) + (not (eobp)) ; Loop until we've covered the region. + (not (> (point) end))) + (setq depth (allout-recent-depth) ; Current topics depth, + bullet (allout-recent-bullet) ; ... bullet, + prefix (allout-recent-prefix) + beg (progn (allout-end-of-prefix t) (point))) ; and beginning. + (setq done ; The boundary for the current topic: + (not (allout-next-visible-heading 1))) + (setq new-depth (allout-recent-depth)) + (setq gone-out out + out (< new-depth depth)) + (beginning-of-line) + (setq next (point)) + (goto-char beg) + (setq strings nil) + (while (> next (point)) ; Get all the exposed text in + (setq strings + (cons (buffer-substring + beg + ;To hidden text or end of line: + (progn + (search-forward "\r" + (save-excursion (end-of-line) + (point)) + 1) + (if (= (preceding-char) ?\r) + (1- (point)) + (point)))) + strings)) + (if (< (point) next) ; Resume from after hid text, if any. + (forward-line 1)) + (setq beg (point))) + ;; Accumulate list for this topic: + (setq strings (nreverse strings)) + (setq result + (cons + (if format + (let ((special (if (string-match + (regexp-quote bullet) + allout-distinctive-bullets-string) + bullet))) + (cond ((listp format) + (list depth + (if allout-abbreviate-flattened-numbering + (allout-stringify-flat-index format + gone-out) + (allout-stringify-flat-index-plain + format)) + strings + special)) + ((eq format 'indent) + (if special + (list depth + (concat (make-string (1+ depth) ? ) + (substring prefix -1)) + strings) + (list depth + (make-string depth ? ) + strings))) + (t (error "allout-listify-exposed: %s %s" + "invalid format" format)))) + (list depth prefix strings)) + result)) + ;; Reasses format, if any: + (if (and format (listp format)) + (cond ((= new-depth depth) + (setq format (cons (1+ (car format)) + (cdr format)))) + ((> new-depth depth) ; descending - assume by 1: + (setq format (cons 1 format))) + (t + ; Pop the residue: + (while (< new-depth depth) + (setq format (cdr format)) + (setq depth (1- depth))) + ; And increment the current one: + (setq format + (cons (1+ (or (car format) + -1)) + (cdr format))))))) + ;; Put the list with first at front, to last at back: + (nreverse result)))) +;;;_ > allout-process-exposed (&optional func from to frombuf +;;; tobuf format) +(defun allout-process-exposed (&optional func from to frombuf tobuf + format start-num) + "Map function on exposed parts of current topic; results to another buffer. + +Apply FUNC to exposed portions FROM position TO position in buffer +FROMBUF to buffer TOBUF. Sixth optional arg, FORMAT, designates an +alternate presentation form: + + `flat' - Present prefix as numeric section.subsection..., starting with + section indicated by the start-num, innermost nesting first. + X`flat-indented' - Prefix is like `flat' for first topic at each + X level, but subsequent topics have only leaf topic + X number, padded with blanks to line up with first. + `indent' \(symbol) - Convert header prefixes to all white space, + except for distinctive bullets. + +Defaults: + FUNC: `allout-insert-listified' + FROM: region start, if region active, else start of buffer + TO: region end, if region active, else end of buffer + FROMBUF: current buffer + TOBUF: buffer name derived: \"*current-buffer-name exposed*\" + FORMAT: nil" + + ; Resolve arguments, + ; defaulting if necessary: + (if (not func) (setq func 'allout-insert-listified)) + (if (not (and from to)) + (if (my-region-active-p) + (setq from (region-beginning) to (region-end)) + (setq from (point-min) to (point-max)))) + (if frombuf + (if (not (bufferp frombuf)) + ;; Specified but not a buffer - get it: + (let ((got (get-buffer frombuf))) + (if (not got) + (error (concat "allout-process-exposed: source buffer " + frombuf + " not found.")) + (setq frombuf got)))) + ;; not specified - default it: + (setq frombuf (current-buffer))) + (if tobuf + (if (not (bufferp tobuf)) + (setq tobuf (get-buffer-create tobuf))) + ;; not specified - default it: + (setq tobuf (concat "*" (buffer-name frombuf) " exposed*"))) + (if (listp format) + (nreverse format)) + + (let* ((listified + (progn (set-buffer frombuf) + (allout-listify-exposed from to format)))) + (set-buffer tobuf) + (mapcar func listified) + (pop-to-buffer tobuf))) + +;;;_ - Copy exposed +;;;_ > allout-insert-listified (listified) +(defun allout-insert-listified (listified) + "Insert contents of listified outline portion in current buffer. + +LISTIFIED is a list representing each topic header and body: + + \`(depth prefix text)' + +or + + \`(depth prefix text bullet-plus)' + +If `bullet-plus' is specified, it is inserted just after the entire prefix." + (setq listified (cdr listified)) + (let ((prefix (prog1 + (car listified) + (setq listified (cdr listified)))) + (text (prog1 + (car listified) + (setq listified (cdr listified)))) + (bullet-plus (car listified))) + (insert prefix) + (if bullet-plus (insert (concat " " bullet-plus))) + (while text + (insert (car text)) + (if (setq text (cdr text)) + (insert "\n"))) + (insert "\n"))) +;;;_ > allout-copy-exposed-to-buffer (&optional arg tobuf format) +(defun allout-copy-exposed-to-buffer (&optional arg tobuf format) + "Duplicate exposed portions of current outline to another buffer. + +Other buffer has current buffers name with \" exposed\" appended to it. + +With repeat count, copy the exposed parts of only the current topic. + +Optional second arg TOBUF is target buffer name. + +Optional third arg FORMAT, if non-nil, symbolically designates an +alternate presentation format for the outline: + + `flat' - Convert topic header prefixes to numeric + section.subsection... identifiers. + `indent' - Convert header prefixes to all white space, except for + distinctive bullets. + `indent-flat' - The best of both - only the first of each level has + the full path, the rest have only the section number + of the leaf, preceded by the right amount of indentation." + + (interactive "P") + (if (not tobuf) + (setq tobuf (get-buffer-create (concat "*" (buffer-name) " exposed*")))) + (let* ((start-pt (point)) + (beg (if arg (allout-back-to-current-heading) (point-min))) + (end (if arg (allout-end-of-current-subtree) (point-max))) + (buf (current-buffer)) + (start-list ())) + (if (eq format 'flat) + (setq format (if arg (save-excursion + (goto-char beg) + (allout-topic-flat-index)) + '(1)))) + (save-excursion (set-buffer tobuf)(erase-buffer)) + (allout-process-exposed 'allout-insert-listified + beg + end + (current-buffer) + tobuf + format start-list) + (goto-char (point-min)) + (pop-to-buffer buf) + (goto-char start-pt))) +;;;_ > allout-flatten-exposed-to-buffer (&optional arg tobuf) +(defun allout-flatten-exposed-to-buffer (&optional arg tobuf) + "Present numeric outline of outline's exposed portions in another buffer. + +The resulting outline is not compatible with outline mode - use +`allout-copy-exposed-to-buffer' if you want that. + +Use `allout-indented-exposed-to-buffer' for indented presentation. + +With repeat count, copy the exposed portions of only current topic. + +Other buffer has current buffer's name with \" exposed\" appended to +it, unless optional second arg TOBUF is specified, in which case it is +used verbatim." + (interactive "P") + (allout-copy-exposed-to-buffer arg tobuf 'flat)) +;;;_ > allout-indented-exposed-to-buffer (&optional arg tobuf) +(defun allout-indented-exposed-to-buffer (&optional arg tobuf) + "Present indented outline of outline's exposed portions in another buffer. + +The resulting outline is not compatible with outline mode - use +`allout-copy-exposed-to-buffer' if you want that. + +Use `allout-flatten-exposed-to-buffer' for numeric sectional presentation. + +With repeat count, copy the exposed portions of only current topic. + +Other buffer has current buffer's name with \" exposed\" appended to +it, unless optional second arg TOBUF is specified, in which case it is +used verbatim." + (interactive "P") + (allout-copy-exposed-to-buffer arg tobuf 'indent)) + +;;;_ - LaTeX formatting +;;;_ > allout-latex-verb-quote (string &optional flow) +(defun allout-latex-verb-quote (string &optional flow) + "Return copy of STRING for literal reproduction across LaTeX processing. +Expresses the original characters \(including carriage returns) of the +string across LaTeX processing." + (mapconcat (function + (lambda (char) + (cond ((memq char '(?\\ ?$ ?% ?# ?& ?{ ?} ?_ ?^ ?- ?*)) + (concat "\\char" (number-to-string char) "{}")) + ((= char ?\n) "\\\\") + (t (char-to-string char))))) + string + "")) +;;;_ > allout-latex-verbatim-quote-curr-line () +(defun allout-latex-verbatim-quote-curr-line () + "Express line for exact \(literal) representation across LaTeX processing. + +Adjust line contents so it is unaltered \(from the original line) +across LaTeX processing, within the context of a `verbatim' +environment. Leaves point at the end of the line." + (beginning-of-line) + (let ((beg (point)) + (end (progn (end-of-line)(point)))) + (goto-char beg) + (while (re-search-forward "\\\\" + ;;"\\\\\\|\\{\\|\\}\\|\\_\\|\\$\\|\\\"\\|\\&\\|\\^\\|\\-\\|\\*\\|#" + end ; bounded by end-of-line + 1) ; no matches, move to end & return nil + (goto-char (match-beginning 0)) + (insert "\\") + (setq end (1+ end)) + (goto-char (1+ (match-end 0)))))) +;;;_ > allout-insert-latex-header (buffer) +(defun allout-insert-latex-header (buffer) + "Insert initial LaTeX commands at point in BUFFER." + ;; Much of this is being derived from the stuff in appendix of E in + ;; the TeXBook, pg 421. + (set-buffer buffer) + (let ((doc-style (format "\n\\documentstyle{%s}\n" + "report")) + (page-numbering (if allout-number-pages + "\\pagestyle{empty}\n" + "")) + (linesdef (concat "\\def\\beginlines{" + "\\par\\begingroup\\nobreak\\medskip" + "\\parindent=0pt\n" + " \\kern1pt\\nobreak \\obeylines \\obeyspaces " + "\\everypar{\\strut}}\n" + "\\def\\endlines{" + "\\kern1pt\\endgroup\\medbreak\\noindent}\n")) + (titlecmd (format "\\newcommand{\\titlecmd}[1]{{%s #1}}\n" + allout-title-style)) + (labelcmd (format "\\newcommand{\\labelcmd}[1]{{%s #1}}\n" + allout-label-style)) + (headlinecmd (format "\\newcommand{\\headlinecmd}[1]{{%s #1}}\n" + allout-head-line-style)) + (bodylinecmd (format "\\newcommand{\\bodylinecmd}[1]{{%s #1}}\n" + allout-body-line-style)) + (setlength (format "%s%s%s%s" + "\\newlength{\\stepsize}\n" + "\\setlength{\\stepsize}{" + allout-indent + "}\n")) + (oneheadline (format "%s%s%s%s%s%s%s" + "\\newcommand{\\OneHeadLine}[3]{%\n" + "\\noindent%\n" + "\\hspace*{#2\\stepsize}%\n" + "\\labelcmd{#1}\\hspace*{.2cm}" + "\\headlinecmd{#3}\\\\[" + allout-line-skip + "]\n}\n")) + (onebodyline (format "%s%s%s%s%s%s" + "\\newcommand{\\OneBodyLine}[2]{%\n" + "\\noindent%\n" + "\\hspace*{#1\\stepsize}%\n" + "\\bodylinecmd{#2}\\\\[" + allout-line-skip + "]\n}\n")) + (begindoc "\\begin{document}\n\\begin{center}\n") + (title (format "%s%s%s%s" + "\\titlecmd{" + (allout-latex-verb-quote (if allout-title + (condition-case err + (eval allout-title) + ('error "")) + "Unnamed Outline")) + "}\n" + "\\end{center}\n\n")) + (hsize "\\hsize = 7.5 true in\n") + (hoffset "\\hoffset = -1.5 true in\n") + (vspace "\\vspace{.1cm}\n\n")) + (insert (concat doc-style + page-numbering + titlecmd + labelcmd + headlinecmd + bodylinecmd + setlength + oneheadline + onebodyline + begindoc + title + hsize + hoffset + vspace) + ))) +;;;_ > allout-insert-latex-trailer (buffer) +(defun allout-insert-latex-trailer (buffer) + "Insert concluding LaTeX commands at point in BUFFER." + (set-buffer buffer) + (insert "\n\\end{document}\n")) +;;;_ > allout-latexify-one-item (depth prefix bullet text) +(defun allout-latexify-one-item (depth prefix bullet text) + "Insert LaTeX commands for formatting one outline item. + +Args are the topics numeric DEPTH, the header PREFIX lead string, the +BULLET string, and a list of TEXT strings for the body." + (let* ((head-line (if text (car text))) + (body-lines (cdr text)) + (curr-line) + body-content bop) + ; Do the head line: + (insert (concat "\\OneHeadLine{\\verb\1 " + (allout-latex-verb-quote bullet) + "\1}{" + depth + "}{\\verb\1 " + (if head-line + (allout-latex-verb-quote head-line) + "") + "\1}\n")) + (if (not body-lines) + nil + ;;(insert "\\beginlines\n") + (insert "\\begin{verbatim}\n") + (while body-lines + (setq curr-line (car body-lines)) + (if (and (not body-content) + (not (string-match "^\\s-*$" curr-line))) + (setq body-content t)) + ; Mangle any occurrences of + ; "\end{verbatim}" in text, + ; it's special: + (if (and body-content + (setq bop (string-match "\\end{verbatim}" curr-line))) + (setq curr-line (concat (substring curr-line 0 bop) + ">" + (substring curr-line bop)))) + ;;(insert "|" (car body-lines) "|") + (insert curr-line) + (allout-latex-verbatim-quote-curr-line) + (insert "\n") + (setq body-lines (cdr body-lines))) + (if body-content + (setq body-content nil) + (forward-char -1) + (insert "\\ ") + (forward-char 1)) + ;;(insert "\\endlines\n") + (insert "\\end{verbatim}\n") + ))) +;;;_ > allout-latexify-exposed (arg &optional tobuf) +(defun allout-latexify-exposed (arg &optional tobuf) + "Format current topics exposed portions to TOBUF for LaTeX processing. +TOBUF defaults to a buffer named the same as the current buffer, but +with \"*\" prepended and \" latex-formed*\" appended. + +With repeat count, copy the exposed portions of entire buffer." + + (interactive "P") + (if (not tobuf) + (setq tobuf + (get-buffer-create (concat "*" (buffer-name) " latexified*")))) + (let* ((start-pt (point)) + (beg (if arg (point-min) (allout-back-to-current-heading))) + (end (if arg (point-max) (allout-end-of-current-subtree))) + (buf (current-buffer))) + (set-buffer tobuf) + (erase-buffer) + (allout-insert-latex-header tobuf) + (goto-char (point-max)) + (allout-process-exposed 'allout-latexify-one-item + beg + end + buf + tobuf) + (goto-char (point-max)) + (allout-insert-latex-trailer tobuf) + (goto-char (point-min)) + (pop-to-buffer buf) + (goto-char start-pt))) + +;;;_ #8 miscellaneous +;;;_ > allout-mark-topic () +(defun allout-mark-topic () + "Put the region around topic currently containing point." + (interactive) + (beginning-of-line) + (allout-goto-prefix) + (push-mark (point)) + (allout-end-of-current-subtree) + (exchange-point-and-mark)) +;;;_ > outlineify-sticky () +;; outlinify-sticky is correct spelling; provide this alias for sticklers: +(defalias 'outlinify-sticky 'outlineify-sticky) +(defun outlineify-sticky (&optional arg) + "Activate outline mode and establish file var so it is started subsequently. + +See doc-string for `allout-layout' and `allout-init' for details on +setup for auto-startup." + + (interactive "P") + + (allout-mode t) + + (save-excursion + (goto-char (point-min)) + (if (looking-at allout-regexp) + t + (allout-open-topic 2) + (insert (concat "Dummy outline topic header - see" + "`allout-mode' docstring: `^Hm'.")) + (forward-line 1) (goto-char (point-max)) - ; Insert preamble: - (insert-string (format "\n\n%s\n%s %s %s\n%s %s " - lead-line - lead-prefix - "local" - "variables:" - lead-prefix - "eval:")) - ; Insert outline-mode activation: - (insert-string - (format "%s\n\t\t%s\n\t\t\t%s\n" - "(condition-case err" - "(save-excursion" - "(outline-mode t)")) - ; Conditionally insert prefix - ; leader customization: - (if arg (insert-string (format "\t\t\t(%s \"%s\")\n" - "outline-lead-with-comment-string" - arg))) - ; Insert announcement and - ; exposure control: - (insert-string - (format "\t\t\t%s %s\n\t\t\t%s %s\n\t\t%s %s" - "(message \"Adjusting '%s' visibility\"" - "(buffer-name))" - "(goto-char 0)" - "(outline-exposure -1 0))" - "(error (message " - "\"Failed file var 'allout' provisions\")))")) - ; Insert postamble: - (insert-string (format "\n%s End: )\n" - lead-prefix))))) -;;;_ > solicit-char-in-string (prompt string &optional do-defaulting) + (open-line 1) + (allout-open-topic 0) + (insert "Local emacs vars.\n") + (allout-open-topic 1) + (insert "(`allout-layout' is for allout.el allout-mode)\n") + (allout-open-topic 0) + (insert "Local variables:\n") + (allout-open-topic 0) + (insert (format "allout-layout: %s\n" + (or allout-layout + '(-1 : 0)))) + (allout-open-topic 0) + (insert "End:\n")))) +;;;_ > solicit-char-in-string (prompt string &optional do-defaulting) (defun solicit-char-in-string (prompt string &optional do-defaulting) - " Solicit (with first arg PROMPT) choice of a character from string STRING. + "Solicit (with first arg PROMPT) choice of a character from string STRING. - Optional arg DO-DEFAULTING indicates to accept empty input (CR)." +Optional arg DO-DEFAULTING indicates to accept empty input (CR)." (let ((new-prompt prompt) got) @@ -2564,51 +4567,114 @@ parameterized communication between the two, if suitable.") (message "%s" new-prompt) ;; We do our own reading here, so we can circumvent, eg, special - ;; treatment for '?' character. (Might oughta change minibuffer - ;; keymap instead, oh well.) + ;; treatment for `?' character. (Oughta use minibuffer keymap instead.) + (setq got + (char-to-string (let ((cursor-in-echo-area nil)) (read-char)))) + (setq got - (char-to-string (let ((cursor-in-echo-area t)) (read-char)))) - - (if (null (string-match got string)) - (if (and do-defaulting (string= got "\^M")) - ;; We're defaulting, return null string to indicate that: - (setq got "") - ;; Failed match and not defaulting, - ;; set the prompt to give feedback, - (setq new-prompt (concat prompt - got - " ...pick from: " - string - "")) - ;; and set loop to try again: - (setq got nil)) - ;; Got a match - give feedback: - (message ""))) - ;; got something out of loop - return it: - got) + (cond ((string-match (regexp-quote got) string) got) + ((and do-defaulting (string= got "\r")) + ;; Return empty string to default: + "") + ((string= got "\C-g") (signal 'quit nil)) + (t + (setq new-prompt (concat prompt + got + " ...pick from: " + string + "")) + nil)))) + ;; got something out of loop - return it: + got) ) -;;;_ > string-sans-char (string char) -(defun string-sans-char (string char) - " Return a copy of STRING that lacks all instances of CHAR." - (cond ((string= string "") "") - ((= (aref string 0) char) (string-sans-char (substring string 1) char)) - ((concat (substring string 0 1) - (string-sans-char (substring string 1) char))))) +;;;_ > regexp-sans-escapes (string) +(defun regexp-sans-escapes (regexp &optional successive-backslashes) + "Return a copy of REGEXP with all character escapes stripped out. + +Representations of actual backslashes - '\\\\\\\\' - are left as a +single backslash. + +\(fn REGEXP)" +;; Optional arg SUCCESSIVE-BACKSLASHES is used internally for recursion. + + (if (string= regexp "") + "" + ;; Set successive-backslashes to number if current char is + ;; backslash, or else to nil: + (setq successive-backslashes + (if (= (aref regexp 0) ?\\) + (if successive-backslashes (1+ successive-backslashes) 1) + nil)) + (if (or (not successive-backslashes) (= 2 successive-backslashes)) + ;; Include first char: + (concat (substring regexp 0 1) + (regexp-sans-escapes (substring regexp 1))) + ;; Exclude first char, but maintain count: + (regexp-sans-escapes (substring regexp 1) successive-backslashes)))) +;;;_ > my-region-active-p () +(defmacro my-region-active-p () + (if (fboundp 'region-active-p) + '(region-active-p) + 'mark-active)) +;;;_ - add-hook definition for divergent emacsen +;;;_ > add-hook (hook function &optional append) +(if (not (fboundp 'add-hook)) + (defun add-hook (hook function &optional append) + "Add to the value of HOOK the function FUNCTION unless already present. +\(It becomes the first hook on the list unless optional APPEND is non-nil, in +which case it becomes the last). HOOK should be a symbol, and FUNCTION may be +any valid function. HOOK's value should be a list of functions, not a single +function. If HOOK is void, it is first set to nil." + (or (boundp hook) (set hook nil)) + (or (if (consp function) + ;; Clever way to tell whether a given lambda-expression + ;; is equal to anything in the hook. + (let ((tail (assoc (cdr function) (symbol-value hook)))) + (equal function tail)) + (memq function (symbol-value hook))) + (set hook + (if append + (nconc (symbol-value hook) (list function)) + (cons function (symbol-value hook))))))) +;;;_ : my-mark-marker to accommodate divergent emacsen: +(defun my-mark-marker (&optional force buffer) + "Accommodate the different signature for `mark-marker' across Emacsen. + +XEmacs takes two optional args, while GNU Emacs does not, +so pass them along when appropriate." + (if (featurep 'xemacs) + (mark-marker force buffer) + (mark-marker))) + +;;;_ #9 Under development +;;;_ > allout-bullet-isearch (&optional bullet) +(defun allout-bullet-isearch (&optional bullet) + "Isearch \(regexp) for topic with bullet BULLET." + (interactive) + (if (not bullet) + (setq bullet (solicit-char-in-string + "ISearch for topic with bullet: " + (regexp-sans-escapes allout-bullets-string)))) + + (let ((isearch-regexp t) + (isearch-string (concat "^" + allout-header-prefix + "[ \t]*" + bullet))) + (isearch-repeat 'forward) + (isearch-mode t))) +;;;_ ? Re hooking up with isearch - use isearch-op-fun rather than +;;; wrapping the isearch functions. ;;;_* Local emacs vars. -'( -Local variables: -eval: (save-excursion - (if (not (condition-case err (outline-mode t) - (wrong-number-of-arguments nil))) - (progn - (message - "Allout outline-mode not loaded, not adjusting buffer exposure") - (sit-for 1)) - (message "Adjusting '%s' visibility" (buffer-name)) - (outline-lead-with-comment-string ";;;_") - (goto-char 0) - (outline-exposure (-1 () () () 1) 0))) -End: -) - +;;; The following `allout-layout' local variable setting: +;;; - closes all topics from the first topic to just before the third-to-last, +;;; - shows the children of the third to last (config vars) +;;; - and the second to last (code section), +;;; - and closes the last topic (this local-variables section). +;;;Local variables: +;;;allout-layout: (0 : -1 -1 0) +;;;End: + +;;; arch-tag: cf38fbc3-c044-450f-8bff-afed8ba5681c +;;; allout.el ends here